mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-15 17:42:05 +03:00
225 lines
8.2 KiB
Haskell
225 lines
8.2 KiB
Haskell
|
{-# LANGUAGE RecordWildCards #-}
|
||
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||
|
{-# LANGUAGE TemplateHaskell #-}
|
||
|
module Keter.LabelMap
|
||
|
( -- * Types
|
||
|
Port
|
||
|
, PortEntry (..)
|
||
|
, LabelMap
|
||
|
-- * Helper functions
|
||
|
, insert
|
||
|
, delete
|
||
|
, lookup
|
||
|
, empty
|
||
|
) where
|
||
|
|
||
|
import Prelude (undefined, error, show)
|
||
|
import Keter.Prelude hiding (show)
|
||
|
import qualified Data.Map as Map
|
||
|
import Data.Map (Map)
|
||
|
import qualified Data.Text as Text
|
||
|
import Data.Text (Text)
|
||
|
import qualified Keter.ReverseProxy as ReverseProxy (RPEntry)
|
||
|
|
||
|
import Debug.Trace (trace)
|
||
|
|
||
|
-- | A port for an individual app to listen on.
|
||
|
type Port = Int
|
||
|
|
||
|
-- | An entry indicating how to proxy a given hostname, as a local port,
|
||
|
-- a filepath, a redirect, or a generic HTTP proxy.
|
||
|
data PortEntry = PEPort Port | PEStatic FilePath | PERedirect Text | PEReverseProxy ReverseProxy.RPEntry
|
||
|
deriving (Show)
|
||
|
|
||
|
type LabelTree = Map.Map Text LabelEntry
|
||
|
|
||
|
-- | A data structure for storing a hierarchical set of domain labels
|
||
|
-- from TLD down, supporting wildcards.
|
||
|
--
|
||
|
-- Data structure is mutually recursive with 'LabelEntry', and each level
|
||
|
-- of the tree supports a static assignment for a hostname such as:
|
||
|
--
|
||
|
-- > example.com
|
||
|
--
|
||
|
-- Or a wildcard assignment for a hostname such as:
|
||
|
--
|
||
|
-- > *.example.com
|
||
|
--
|
||
|
-- Or a wildcard assignment with a set of teptions, for example:
|
||
|
--
|
||
|
-- > *.example.com
|
||
|
-- > admin.example.com
|
||
|
--
|
||
|
-- And lastly, empty labels are supported so that, of course, an assignment
|
||
|
-- for example.com does not necessarily have any subdomains available. As an example
|
||
|
-- suppose we have the following assigned domains:
|
||
|
--
|
||
|
-- > example.com
|
||
|
-- > foo.example.com
|
||
|
-- > *.bar.example.com
|
||
|
-- > *.qux.example.com
|
||
|
-- > baz.qux.example.com
|
||
|
--
|
||
|
-- This will resolve to the following value, with some loose pseudocode notation.
|
||
|
--
|
||
|
-- > Static (map)
|
||
|
-- > 'com' -> Unassigned Static (map)
|
||
|
-- > 'example' -> Assigned (PortEntry ..) (map)
|
||
|
-- > 'foo' -> Assigned (PortEntry ..) EmptyLabelMap
|
||
|
-- > 'bar' -> Unassigned (Wildcard (Assigned (PortEntry ..) EmptyLabelMap)
|
||
|
-- > 'qux' -> Unassigned (WildcardExcept (Assigned (PortEntry ..) (map)))
|
||
|
-- > 'baz' -> Assigned (PortEntry ..) EmptyLabelMap
|
||
|
--
|
||
|
-- Note that the hostname "bar.example.com" is unassigned, only the wildcard was set.
|
||
|
--
|
||
|
data LabelMap = EmptyLabelMap
|
||
|
| Static LabelTree
|
||
|
| Wildcard LabelEntry
|
||
|
| WildcardExcept LabelEntry LabelTree
|
||
|
deriving (Show)
|
||
|
|
||
|
-- | Indicates whether a given label in the
|
||
|
data LabelEntry = Assigned PortEntry LabelMap
|
||
|
| Unassigned LabelMap
|
||
|
deriving (Show)
|
||
|
|
||
|
lemap :: (LabelMap -> LabelMap) -> LabelEntry -> LabelEntry
|
||
|
lemap f (Assigned e m) = Assigned e (f m)
|
||
|
lemap f (Unassigned m) = Unassigned (f m)
|
||
|
|
||
|
labelEntryMap :: LabelEntry -> LabelMap
|
||
|
labelEntryMap (Assigned _ m) = m
|
||
|
labelEntryMap (Unassigned m) = m
|
||
|
|
||
|
insert :: Text -> PortEntry -> LabelMap -> LabelMap
|
||
|
insert h e m = trace
|
||
|
( "Inserting hostname " ++ (show h) ++ "\n"
|
||
|
++" with entry " ++ (show e) ++ "\n"
|
||
|
++" into tree " ++ (show m) ++ "\n"
|
||
|
++" with result " ++ (show result)
|
||
|
)
|
||
|
result
|
||
|
where result = insertTree (reverse . Text.splitOn "." $ h) e m
|
||
|
-- insert = insertTree . reverse . Text.splitOn "."
|
||
|
|
||
|
insertTree :: [Text] -> PortEntry -> LabelMap -> LabelMap
|
||
|
insertTree [] _ _ = error "Cannot assign empty label in hostname."
|
||
|
|
||
|
insertTree ["*"] e EmptyLabelMap = Wildcard (Assigned e EmptyLabelMap)
|
||
|
insertTree [l] e EmptyLabelMap = Static (Map.insert l (Assigned e EmptyLabelMap) Map.empty)
|
||
|
|
||
|
insertTree ["*"] e (Static t) = WildcardExcept (Assigned e EmptyLabelMap) t
|
||
|
insertTree [l] e (Static t) =
|
||
|
case Map.lookup l t of
|
||
|
Nothing -> Static (Map.insert l (Assigned e EmptyLabelMap) t)
|
||
|
Just le -> Static (Map.insert l (Assigned e (labelEntryMap le)) t)
|
||
|
|
||
|
insertTree ["*"] e (Wildcard w) = Wildcard (Assigned e (labelEntryMap w))
|
||
|
insertTree [l] e (Wildcard w) = WildcardExcept w (Map.insert l (Assigned e EmptyLabelMap) Map.empty)
|
||
|
|
||
|
insertTree ["*"] e (WildcardExcept w t) = WildcardExcept (Assigned e (labelEntryMap w)) t
|
||
|
insertTree [l] e (WildcardExcept w t) =
|
||
|
case Map.lookup l t of
|
||
|
Nothing -> WildcardExcept w (Map.insert l (Assigned e EmptyLabelMap) t)
|
||
|
Just le -> WildcardExcept w (Map.insert l (Assigned e (labelEntryMap le)) t)
|
||
|
|
||
|
insertTree ("*":ls) e EmptyLabelMap = Wildcard (Unassigned (insertTree ls e EmptyLabelMap))
|
||
|
insertTree (l:ls) e EmptyLabelMap = Static (Map.insert l (Unassigned $ insertTree ls e EmptyLabelMap) Map.empty)
|
||
|
|
||
|
insertTree ("*":ls) e (Static t) = WildcardExcept (Unassigned (insertTree ls e EmptyLabelMap)) t
|
||
|
insertTree (l:ls) e (Static t) =
|
||
|
case Map.lookup l t of
|
||
|
Nothing -> Static (Map.insert l (Unassigned (insertTree ls e EmptyLabelMap)) t)
|
||
|
Just le -> Static (Map.insert l (lemap (insertTree ls e) le) t)
|
||
|
|
||
|
insertTree ("*":ls) e (Wildcard w) = Wildcard (lemap (insertTree ls e) w)
|
||
|
insertTree (l:ls) e (Wildcard w) = WildcardExcept w (Map.insert l (Assigned e (insertTree ls e EmptyLabelMap)) Map.empty)
|
||
|
|
||
|
insertTree ("*":ls) e (WildcardExcept w t) = WildcardExcept (lemap (insertTree ls e) w) t
|
||
|
insertTree (l:ls) e (WildcardExcept w t) =
|
||
|
case Map.lookup l t of
|
||
|
Nothing -> WildcardExcept w (Map.insert l (Unassigned (insertTree ls e EmptyLabelMap)) t)
|
||
|
Just le -> WildcardExcept w (Map.insert l (lemap (insertTree ls e) le) t)
|
||
|
|
||
|
delete :: Text -> LabelMap -> LabelMap
|
||
|
delete h m = trace
|
||
|
( "Deleting hostname " ++ (show h) ++ "\n"
|
||
|
++" into tree " ++ (show m) ++ "\n"
|
||
|
++" with result " ++ (show result)
|
||
|
)
|
||
|
|
||
|
result
|
||
|
where result = deleteTree (reverse . Text.splitOn "." $ h) m
|
||
|
-- delete = deleteTree . reverse . Text.splitOn "."
|
||
|
|
||
|
deleteTree :: [Text] -> LabelMap -> LabelMap
|
||
|
deleteTree [] _ = error "Cannot assign empty label in hostname."
|
||
|
|
||
|
deleteTree _ EmptyLabelMap = EmptyLabelMap
|
||
|
|
||
|
deleteTree ["*"] (Static t) = Static t
|
||
|
deleteTree [l] (Static t) = Static (Map.delete l t)
|
||
|
|
||
|
deleteTree ["*"] (Wildcard w) = Wildcard (Unassigned (labelEntryMap w))
|
||
|
deleteTree [_] (Wildcard w) = Wildcard w
|
||
|
|
||
|
deleteTree ["*"] (WildcardExcept w t) = WildcardExcept (Unassigned (labelEntryMap w)) t
|
||
|
deleteTree [l] (WildcardExcept w t) = WildcardExcept w (Map.delete l t)
|
||
|
|
||
|
deleteTree ("*":_) (Static t) = Static t
|
||
|
deleteTree (l:ls) (Static t) =
|
||
|
case Map.lookup l t of
|
||
|
Nothing -> Static t
|
||
|
Just le -> Static (Map.insert l (lemap (deleteTree ls) le) t)
|
||
|
|
||
|
deleteTree ("*":ls) (Wildcard w) = Wildcard (lemap (deleteTree ls) w)
|
||
|
deleteTree (_:_) (Wildcard w) = Wildcard w
|
||
|
|
||
|
deleteTree ("*":ls) (WildcardExcept w t) = WildcardExcept (lemap (deleteTree ls) w) t
|
||
|
deleteTree (l:ls) (WildcardExcept w t) =
|
||
|
case Map.lookup l t of
|
||
|
Nothing -> WildcardExcept w t
|
||
|
Just le -> WildcardExcept w (Map.insert l (lemap (deleteTree ls) le) t)
|
||
|
|
||
|
lookup :: Text -> LabelMap -> Maybe PortEntry
|
||
|
lookup h m = trace
|
||
|
( "Looking up hostname " ++ (show h) ++ "\n"
|
||
|
++" in tree " ++ (show m) ++ "\n"
|
||
|
++" and found " ++ (show result)
|
||
|
)
|
||
|
result
|
||
|
where result = (lookupTree (reverse . Text.splitOn "." $ h) m)
|
||
|
-- lookup = lookupTree . reverse . Text.splitOn "."
|
||
|
|
||
|
lookupTree :: [Text] -> LabelMap -> Maybe PortEntry
|
||
|
lookupTree [] _ = Nothing
|
||
|
|
||
|
lookupTree _ EmptyLabelMap = Nothing
|
||
|
|
||
|
lookupTree [l] (Static t) = labelToMaybePortEntry $ Map.lookup l t
|
||
|
lookupTree [_] (Wildcard w) = labelToMaybePortEntry . Just $ w
|
||
|
lookupTree [l] (WildcardExcept w t) =
|
||
|
case labelToMaybePortEntry $ Map.lookup l t of
|
||
|
Just e -> Just e
|
||
|
Nothing -> labelToMaybePortEntry . Just $ w
|
||
|
|
||
|
lookupTree (l:ls) (Static t) =
|
||
|
case Map.lookup l t of
|
||
|
Just le -> lookupTree ls $ labelEntryMap le
|
||
|
Nothing -> Nothing
|
||
|
lookupTree (_:ls) (Wildcard w) = lookupTree ls $ labelEntryMap w
|
||
|
lookupTree (l:ls) (WildcardExcept w t) =
|
||
|
case Map.lookup l t of
|
||
|
Just le -> lookupTree ls $ labelEntryMap le
|
||
|
Nothing -> lookupTree ls $ labelEntryMap w
|
||
|
|
||
|
labelToMaybePortEntry :: Maybe LabelEntry -> Maybe PortEntry
|
||
|
labelToMaybePortEntry (Just (Assigned e _)) = Just e
|
||
|
labelToMaybePortEntry (Just (Unassigned _)) = Nothing
|
||
|
labelToMaybePortEntry Nothing = Nothing
|
||
|
|
||
|
empty :: LabelMap
|
||
|
empty = EmptyLabelMap
|