{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Keter.LabelMap
    ( -- * Types
      LabelMap
      -- * Helper functions
    , insert
    , delete
    , lookup
    , labelAssigned
    , empty
    ) where

import Prelude hiding (lookup)
import Data.Maybe (isJust)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive (CI)

type LabelTree a = Map (CI ByteString) (LabelEntry a)

-- | 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 a (map)
-- >         'foo'  -> Assigned a EmptyLabelMap
-- >         'bar'  -> Unassigned (Wildcard (Assigned a EmptyLabelMap)
-- >         'qux'  -> Unassigned (WildcardExcept (Assigned a (map)))
-- >           'baz' -> Assigned a EmptyLabelMap
--
-- Note that the hostname "bar.example.com" is unassigned, only the wildcard was set.
--
data LabelMap a = EmptyLabelMap
                | Static         !(LabelTree a)
                | Wildcard       !(LabelEntry a)
                | WildcardExcept !(LabelEntry a) !(LabelTree a)
    deriving (Int -> LabelMap a -> ShowS
[LabelMap a] -> ShowS
LabelMap a -> String
(Int -> LabelMap a -> ShowS)
-> (LabelMap a -> String)
-> ([LabelMap a] -> ShowS)
-> Show (LabelMap a)
forall a. Int -> LabelMap a -> ShowS
forall a. [LabelMap a] -> ShowS
forall a. LabelMap a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LabelMap a] -> ShowS
$cshowList :: forall a. [LabelMap a] -> ShowS
show :: LabelMap a -> String
$cshow :: forall a. LabelMap a -> String
showsPrec :: Int -> LabelMap a -> ShowS
$cshowsPrec :: forall a. Int -> LabelMap a -> ShowS
Show, LabelMap a -> LabelMap a -> Bool
(LabelMap a -> LabelMap a -> Bool)
-> (LabelMap a -> LabelMap a -> Bool) -> Eq (LabelMap a)
forall a. Eq a => LabelMap a -> LabelMap a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LabelMap a -> LabelMap a -> Bool
$c/= :: forall a. Eq a => LabelMap a -> LabelMap a -> Bool
== :: LabelMap a -> LabelMap a -> Bool
$c== :: forall a. Eq a => LabelMap a -> LabelMap a -> Bool
Eq)

-- | Indicates whether a given label in the
data LabelEntry a = Assigned   !a !(LabelMap a)
                  | Unassigned    !(LabelMap a)
                  deriving LabelEntry a -> LabelEntry a -> Bool
(LabelEntry a -> LabelEntry a -> Bool)
-> (LabelEntry a -> LabelEntry a -> Bool) -> Eq (LabelEntry a)
forall a. Eq a => LabelEntry a -> LabelEntry a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LabelEntry a -> LabelEntry a -> Bool
$c/= :: forall a. Eq a => LabelEntry a -> LabelEntry a -> Bool
== :: LabelEntry a -> LabelEntry a -> Bool
$c== :: forall a. Eq a => LabelEntry a -> LabelEntry a -> Bool
Eq

instance Show (LabelEntry a) where
    show :: LabelEntry a -> String
show (Assigned a
_ LabelMap a
m) = String
"Assigned _ (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ LabelMap a -> String
forall a. Show a => a -> String
show LabelMap a
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    show (Unassigned LabelMap a
m) = String
"Unassigned (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ LabelMap a -> String
forall a. Show a => a -> String
show LabelMap a
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

hostToLabels :: ByteString -> [ByteString]
hostToLabels :: ByteString -> [ByteString]
hostToLabels ByteString
h
  | ByteString -> Bool
BS.null ByteString
h        = []
  | ByteString -> Char
BS.last ByteString
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop Int
1 [ByteString]
labels
  | Bool
otherwise        = [ByteString]
labels
  where labels :: [ByteString]
labels = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
BS.split Char
'.' (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString
h

lemap :: (LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap :: (LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap LabelMap a -> LabelMap a
f (Assigned a
e LabelMap a
m) = a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e (LabelMap a -> LabelMap a
f LabelMap a
m)
lemap LabelMap a -> LabelMap a
f (Unassigned LabelMap a
m) = LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned (LabelMap a -> LabelMap a
f LabelMap a
m)

labelEntryMap :: LabelEntry a -> LabelMap a
labelEntryMap :: LabelEntry a -> LabelMap a
labelEntryMap (Assigned a
_ LabelMap a
m) = LabelMap a
m
labelEntryMap (Unassigned LabelMap a
m) = LabelMap a
m

getPortEntry :: LabelEntry a -> Maybe a
getPortEntry :: LabelEntry a -> Maybe a
getPortEntry (Assigned a
e LabelMap a
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
e
getPortEntry (Unassigned LabelMap a
_) = Maybe a
forall a. Maybe a
Nothing

insert :: ByteString -> a -> LabelMap a -> LabelMap a
insert :: ByteString -> a -> LabelMap a -> LabelMap a
insert ByteString
h a
e LabelMap a
m = [ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree (ByteString -> [ByteString]
hostToLabels ByteString
h) a
e LabelMap a
m
--insert h e m = trace
--       ( "Inserting hostname " ++ (show h) ++ "\n"
--       ++"  into tree        " ++ (show m) ++ "\n"
--       ++"  with result      " ++ (show result)
--       )
--       result
--    where result = insertTree (hostToLabels h) e m

insertTree :: [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree :: [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree []    a
_ LabelMap a
_ = String -> LabelMap a
forall a. HasCallStack => String -> a
error String
"Cannot assign empty label in hostname."

insertTree [ByteString
"*"] a
e LabelMap a
EmptyLabelMap = LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap)
insertTree [ByteString
l]   a
e LabelMap a
EmptyLabelMap = LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap) LabelTree a
forall k a. Map k a
Map.empty)

insertTree [ByteString
"*"] a
e (Static LabelTree a
t) = LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap) LabelTree a
t
insertTree [ByteString
l']   a
e (Static LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI ByteString
l LabelTree a
t of
        Maybe (LabelEntry a)
Nothing  -> LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap) LabelTree a
t)
        Just LabelEntry a
le  -> LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e (LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le)) LabelTree a
t)
  where
    l :: CI ByteString
l = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l'

insertTree [ByteString
"*"] a
e (Wildcard LabelEntry a
w) = LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e (LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w))
insertTree [ByteString
l]   a
e (Wildcard LabelEntry a
w) = LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap) LabelTree a
forall k a. Map k a
Map.empty)

insertTree [ByteString
"*"] a
e (WildcardExcept LabelEntry a
w LabelTree a
t) = LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e (LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w)) LabelTree a
t
insertTree [ByteString
l']   a
e (WildcardExcept LabelEntry a
w LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI ByteString
l LabelTree a
t of
        Maybe (LabelEntry a)
Nothing -> LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap) LabelTree a
t)
        Just LabelEntry a
le -> LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e (LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le)) LabelTree a
t)
  where
    l :: CI ByteString
l = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l'

insertTree (ByteString
"*":[ByteString]
ls) a
e LabelMap a
EmptyLabelMap = LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap))
insertTree (ByteString
l:[ByteString]
ls)   a
e LabelMap a
EmptyLabelMap = LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned (LabelMap a -> LabelEntry a) -> LabelMap a -> LabelEntry a
forall a b. (a -> b) -> a -> b
$ [ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap) LabelTree a
forall k a. Map k a
Map.empty)

insertTree (ByteString
"*":[ByteString]
ls) a
e (Static LabelTree a
t) = LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap)) LabelTree a
t
insertTree (ByteString
l':[ByteString]
ls)   a
e (Static LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI ByteString
l LabelTree a
t of
        Maybe (LabelEntry a)
Nothing -> LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap)) LabelTree a
t)
        Just LabelEntry a
le -> LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e) LabelEntry a
le) LabelTree a
t)
  where
    l :: CI ByteString
l = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l'

insertTree (ByteString
"*":[ByteString]
ls) a
e (Wildcard LabelEntry a
w) = LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e) LabelEntry a
w)
insertTree (ByteString
l:[ByteString]
ls)   a
e (Wildcard LabelEntry a
w) = LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) (a -> LabelMap a -> LabelEntry a
forall a. a -> LabelMap a -> LabelEntry a
Assigned a
e ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap)) LabelTree a
forall k a. Map k a
Map.empty)

insertTree (ByteString
"*":[ByteString]
ls) a
e (WildcardExcept LabelEntry a
w LabelTree a
t) = LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e) LabelEntry a
w) LabelTree a
t
insertTree (ByteString
l:[ByteString]
ls)   a
e (WildcardExcept LabelEntry a
w LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI ByteString
l' LabelTree a
t of
        Maybe (LabelEntry a)
Nothing -> LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l' (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e LabelMap a
forall a. LabelMap a
EmptyLabelMap)) LabelTree a
t)
        Just LabelEntry a
le -> LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l' ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> a -> LabelMap a -> LabelMap a
forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree [ByteString]
ls a
e) LabelEntry a
le) LabelTree a
t)
  where
    l' :: CI ByteString
l' = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l

cleanup :: LabelMap a -> LabelMap a
cleanup :: LabelMap a -> LabelMap a
cleanup LabelMap a
EmptyLabelMap = LabelMap a
forall a. LabelMap a
EmptyLabelMap
cleanup m :: LabelMap a
m@(Static LabelTree a
t) =
    case LabelTree a -> Bool
forall k a. Map k a -> Bool
Map.null ((LabelEntry a -> Bool) -> LabelTree a -> LabelTree a
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter LabelEntry a -> Bool
forall a. LabelEntry a -> Bool
p LabelTree a
t) of
        Bool
True  -> LabelMap a
forall a. LabelMap a
EmptyLabelMap
        Bool
False -> LabelMap a
m
    where
        p :: LabelEntry a -> Bool
p (Unassigned LabelMap a
EmptyLabelMap) = Bool
False
        p LabelEntry a
_ = Bool
True

cleanup m :: LabelMap a
m@(Wildcard LabelEntry a
w) =
    case LabelEntry a
w of
        Unassigned LabelMap a
EmptyLabelMap -> LabelMap a
forall a. LabelMap a
EmptyLabelMap
        LabelEntry a
_ -> LabelMap a
m

cleanup m :: LabelMap a
m@(WildcardExcept LabelEntry a
w LabelTree a
t) =
    case (LabelEntry a
w, LabelTree a -> Bool
forall k a. Map k a -> Bool
Map.null LabelTree a
t) of
        (Unassigned LabelMap a
EmptyLabelMap, Bool
True)  -> LabelMap a
forall a. LabelMap a
EmptyLabelMap
        (Unassigned LabelMap a
EmptyLabelMap, Bool
False) -> LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static LabelTree a
t
        (LabelEntry a
_,                        Bool
True)  -> LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard LabelEntry a
w
        (LabelEntry a
_,                        Bool
False) -> LabelMap a
m

delete :: ByteString -> LabelMap a -> LabelMap a
delete :: ByteString -> LabelMap a -> LabelMap a
delete ByteString
h LabelMap a
m = [ByteString] -> LabelMap a -> LabelMap a
forall a. [ByteString] -> LabelMap a -> LabelMap a
deleteTree (ByteString -> [ByteString]
hostToLabels ByteString
h) LabelMap a
m
--delete h m = trace
--       ( "Deleting hostname  " ++ (show h) ++ "\n"
--       ++"  into tree        " ++ (show m) ++ "\n"
--       ++"  with result      " ++ (show result)
--       )
--       result
--    where result = deleteTree (hostToLabels h) m

deleteTree :: [ByteString] -> LabelMap a -> LabelMap a
deleteTree :: [ByteString] -> LabelMap a -> LabelMap a
deleteTree [] LabelMap a
_ = String -> LabelMap a
forall a. HasCallStack => String -> a
error String
"Cannot assign empty label in hostname."

deleteTree [ByteString]
_ LabelMap a
EmptyLabelMap = LabelMap a
forall a. LabelMap a
EmptyLabelMap

deleteTree [ByteString
"*"] (Static LabelTree a
t) = LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static LabelTree a
t
deleteTree [ByteString
l]   (Static LabelTree a
t) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$ LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static LabelTree a
m
   where
    m :: LabelTree a
m = case CI ByteString
l' CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` LabelTree a
t of
      Just (Assigned a
_ LabelMap a
EmptyLabelMap) -> CI ByteString -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete CI ByteString
l' LabelTree a
t
      Just (Assigned a
_ LabelMap a
b) -> CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l' (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned LabelMap a
b) (CI ByteString -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete CI ByteString
l' LabelTree a
t)
      Maybe (LabelEntry a)
_ -> LabelTree a
t
    l' :: CI ByteString
l' = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l

deleteTree [ByteString
"*"] (Wildcard LabelEntry a
w) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned (LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w))
deleteTree [ByteString
_] (Wildcard LabelEntry a
w) = LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard LabelEntry a
w

deleteTree [ByteString
"*"] (WildcardExcept LabelEntry a
w LabelTree a
t) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept (LabelMap a -> LabelEntry a
forall a. LabelMap a -> LabelEntry a
Unassigned (LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w)) LabelTree a
t
deleteTree [ByteString
l] (WildcardExcept LabelEntry a
w LabelTree a
t) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t)

deleteTree (ByteString
"*":[ByteString]
_) (Static LabelTree a
t) = LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static LabelTree a
t
deleteTree (ByteString
l:[ByteString]
ls)  (Static LabelTree a
t) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI ByteString
l' LabelTree a
t of
        Maybe (LabelEntry a)
Nothing -> LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static LabelTree a
t
        Just LabelEntry a
le -> LabelTree a -> LabelMap a
forall a. LabelTree a -> LabelMap a
Static (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l' ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> LabelMap a -> LabelMap a
forall a. [ByteString] -> LabelMap a -> LabelMap a
deleteTree [ByteString]
ls) LabelEntry a
le) LabelTree a
t)
  where
    l' :: CI ByteString
l' = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l

deleteTree (ByteString
"*":[ByteString]
ls) (Wildcard LabelEntry a
w) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> LabelMap a -> LabelMap a
forall a. [ByteString] -> LabelMap a -> LabelMap a
deleteTree [ByteString]
ls) LabelEntry a
w)
deleteTree (ByteString
_:[ByteString]
_)    (Wildcard LabelEntry a
w) = LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
Wildcard LabelEntry a
w

deleteTree (ByteString
"*":[ByteString]
ls) (WildcardExcept LabelEntry a
w LabelTree a
t) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> LabelMap a -> LabelMap a
forall a. [ByteString] -> LabelMap a -> LabelMap a
deleteTree [ByteString]
ls) LabelEntry a
w) LabelTree a
t
deleteTree (ByteString
l:[ByteString]
ls) (WildcardExcept LabelEntry a
w LabelTree a
t) = LabelMap a -> LabelMap a
forall a. LabelMap a -> LabelMap a
cleanup (LabelMap a -> LabelMap a) -> LabelMap a -> LabelMap a
forall a b. (a -> b) -> a -> b
$
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI ByteString
l' LabelTree a
t of
        Maybe (LabelEntry a)
Nothing            -> LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w LabelTree a
t
        Just LabelEntry a
le            -> LabelEntry a -> LabelTree a -> LabelMap a
forall a. LabelEntry a -> LabelTree a -> LabelMap a
WildcardExcept LabelEntry a
w (CI ByteString -> LabelEntry a -> LabelTree a -> LabelTree a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CI ByteString
l' ((LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap ([ByteString] -> LabelMap a -> LabelMap a
forall a. [ByteString] -> LabelMap a -> LabelMap a
deleteTree [ByteString]
ls) LabelEntry a
le) LabelTree a
t)
  where
    l' :: CI ByteString
l' = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l

lookup :: ByteString -> LabelMap a -> Maybe a
lookup :: ByteString -> LabelMap a -> Maybe a
lookup ByteString
h LabelMap a
m = [ByteString] -> LabelMap a -> Maybe a
forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree (ByteString -> [ByteString]
hostToLabels ByteString
h) LabelMap a
m
--lookup h m = trace
--       ( "Looking up hostname  " ++ (show h) ++ "\n"
--       ++"  in tree            " ++ (show m) ++ "\n"
--       ++"  and found entry?   " ++ (show $ isJust result)
--       )
--       result
--    where result = (lookupTree (hostToLabels h) m)

lookupTree :: [ByteString] -> LabelMap a -> Maybe a
lookupTree :: [ByteString] -> LabelMap a -> Maybe a
lookupTree [] LabelMap a
_ = Maybe a
forall a. Maybe a
Nothing

lookupTree [ByteString]
_ LabelMap a
EmptyLabelMap = Maybe a
forall a. Maybe a
Nothing

lookupTree [ByteString
l] (Static LabelTree a
t)   = CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t Maybe (LabelEntry a) -> (LabelEntry a -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LabelEntry a -> Maybe a
forall a. LabelEntry a -> Maybe a
getPortEntry
lookupTree [ByteString
_] (Wildcard LabelEntry a
w) = LabelEntry a -> Maybe a
forall a. LabelEntry a -> Maybe a
getPortEntry (LabelEntry a -> Maybe a) -> LabelEntry a -> Maybe a
forall a b. (a -> b) -> a -> b
$ LabelEntry a
w
lookupTree [ByteString
l] (WildcardExcept LabelEntry a
w LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t Maybe (LabelEntry a) -> (LabelEntry a -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LabelEntry a -> Maybe a
forall a. LabelEntry a -> Maybe a
getPortEntry of
        Just a
e  -> a -> Maybe a
forall a. a -> Maybe a
Just a
e
        Maybe a
Nothing -> LabelEntry a -> Maybe a
forall a. LabelEntry a -> Maybe a
getPortEntry LabelEntry a
w

lookupTree (ByteString
l:[ByteString]
ls) (Static LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le -> [ByteString] -> LabelMap a -> Maybe a
forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls (LabelMap a -> Maybe a) -> LabelMap a -> Maybe a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le
        Maybe (LabelEntry a)
Nothing -> Maybe a
forall a. Maybe a
Nothing
lookupTree (ByteString
_:[ByteString]
ls) (Wildcard LabelEntry a
w) = [ByteString] -> LabelMap a -> Maybe a
forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls (LabelMap a -> Maybe a) -> LabelMap a -> Maybe a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w
lookupTree (ByteString
l:[ByteString]
ls) (WildcardExcept LabelEntry a
w LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le ->
            case [ByteString] -> LabelMap a -> Maybe a
forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls (LabelMap a -> Maybe a) -> LabelMap a -> Maybe a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le of
                Just  a
e -> a -> Maybe a
forall a. a -> Maybe a
Just a
e
                Maybe a
Nothing -> [ByteString] -> LabelMap a -> Maybe a
forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls (LabelMap a -> Maybe a) -> LabelMap a -> Maybe a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w
        Maybe (LabelEntry a)
Nothing -> [ByteString] -> LabelMap a -> Maybe a
forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls (LabelMap a -> Maybe a) -> LabelMap a -> Maybe a
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w

-- This function is similar to lookup but it determines strictly
-- whether or not a record to be inserted would override an existing
-- entry exactly. i.e.: When inserting *.example.com, this function
-- will return true for precisely *.example.com, but not foo.example.com.
--
-- This is so that different keter applications may establish ownership
-- over different subdomains, including exceptions to a wildcard.
--
-- This function *does not* test whether or not a given input would
-- resolve to an existing host. In the above example, given only an
-- inserted *.example.com, foo.example.com would route to the wildcard.
-- Even so, labelAssigned will return false, foo.example.com has not
-- been explicitly assigned.
labelAssigned :: ByteString -> LabelMap a -> Bool
labelAssigned :: ByteString -> LabelMap a -> Bool
labelAssigned ByteString
h LabelMap a
m = [ByteString] -> LabelMap a -> Bool
forall a. [ByteString] -> LabelMap a -> Bool
memberTree (ByteString -> [ByteString]
hostToLabels ByteString
h) LabelMap a
m
--labelAssigned h m = trace
--       ( "Checking label assignment for " ++ (show h) ++ "\n"
--       ++"  in tree            " ++ (show m) ++ "\n"
--       ++"  and found?         " ++ (show result)
--       )
--       result
--    where result = memberTree (hostToLabels h) m

memberTree :: [ByteString] -> LabelMap a -> Bool
memberTree :: [ByteString] -> LabelMap a -> Bool
memberTree [] LabelMap a
_ = Bool
False

memberTree [ByteString
"*"] (Static LabelTree a
_)   = Bool
False
memberTree [ByteString
l]   (Static LabelTree a
t)   = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t Maybe (LabelEntry a) -> (LabelEntry a -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LabelEntry a -> Maybe a
forall a. LabelEntry a -> Maybe a
getPortEntry

memberTree [ByteString
"*"] (Wildcard LabelEntry a
_) = Bool
True
memberTree [ByteString
_]   (Wildcard LabelEntry a
_) = Bool
False

memberTree [ByteString
"*"] (WildcardExcept LabelEntry a
w LabelTree a
_) = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> Maybe a
forall a. LabelEntry a -> Maybe a
getPortEntry LabelEntry a
w
memberTree [ByteString
l]   (WildcardExcept LabelEntry a
_ LabelTree a
t) = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t Maybe (LabelEntry a) -> (LabelEntry a -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LabelEntry a -> Maybe a
forall a. LabelEntry a -> Maybe a
getPortEntry

memberTree (ByteString
"*":[ByteString]
_) (Static LabelTree a
_) = Bool
False
memberTree (ByteString
l:[ByteString]
ls)  (Static LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le -> [ByteString] -> LabelMap a -> Bool
forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls (LabelMap a -> Bool) -> LabelMap a -> Bool
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le
        Maybe (LabelEntry a)
Nothing -> Bool
False

memberTree (ByteString
"*":[ByteString]
ls) (Wildcard LabelEntry a
w) = [ByteString] -> LabelMap a -> Bool
forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls (LabelMap a -> Bool) -> LabelMap a -> Bool
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w
memberTree (ByteString
_:[ByteString]
_)    (Wildcard LabelEntry a
_) = Bool
False

memberTree (ByteString
"*":[ByteString]
ls) (WildcardExcept LabelEntry a
w LabelTree a
_) = [ByteString] -> LabelMap a -> Bool
forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls (LabelMap a -> Bool) -> LabelMap a -> Bool
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w
memberTree (ByteString
l:[ByteString]
ls)   (WildcardExcept LabelEntry a
_ LabelTree a
t) =
    case CI ByteString -> LabelTree a -> Maybe (LabelEntry a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le -> [ByteString] -> LabelMap a -> Bool
forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls (LabelMap a -> Bool) -> LabelMap a -> Bool
forall a b. (a -> b) -> a -> b
$ LabelEntry a -> LabelMap a
forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le
        Maybe (LabelEntry a)
Nothing -> Bool
False

memberTree [ByteString]
_ LabelMap a
EmptyLabelMap = Bool
False

empty :: LabelMap a
empty :: LabelMap a
empty = LabelMap a
forall a. LabelMap a
EmptyLabelMap