{-# 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
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
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
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 _ (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LabelMap a
m forall a. [a] -> [a] -> [a]
++ String
")"
    show (Unassigned LabelMap a
m) = String
"Unassigned (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LabelMap a
m 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 forall a. Eq a => a -> a -> Bool
== Char
'.' = forall a. Int -> [a] -> [a]
drop Int
1 [ByteString]
labels
  | Bool
otherwise        = [ByteString]
labels
  where labels :: [ByteString]
labels = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
BS.split Char
'.' forall a b. (a -> b) -> a -> b
$ ByteString
h

lemap :: (LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap :: forall a.
(LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a
lemap LabelMap a -> LabelMap a
f (Assigned a
e LabelMap a
m) = 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) = forall a. LabelMap a -> LabelEntry a
Unassigned (LabelMap a -> LabelMap a
f LabelMap a
m)

labelEntryMap :: LabelEntry a -> LabelMap a
labelEntryMap :: forall a. 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 :: forall a. LabelEntry a -> Maybe a
getPortEntry (Assigned a
e LabelMap a
_) = forall a. a -> Maybe a
Just a
e
getPortEntry (Unassigned LabelMap a
_) = forall a. Maybe a
Nothing

insert :: ByteString -> a -> LabelMap a -> LabelMap a
insert :: forall a. ByteString -> a -> LabelMap a -> LabelMap a
insert ByteString
h a
e LabelMap a
m = 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 :: forall a. [ByteString] -> a -> LabelMap a -> LabelMap a
insertTree []    a
_ LabelMap a
_ = forall a. HasCallStack => String -> a
error String
"Cannot assign empty label in hostname."

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

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

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

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

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

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

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

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

cleanup :: LabelMap a -> LabelMap a
cleanup :: forall a. LabelMap a -> LabelMap a
cleanup LabelMap a
EmptyLabelMap = forall a. LabelMap a
EmptyLabelMap
cleanup m :: LabelMap a
m@(Static LabelTree a
t) =
    case forall k a. Map k a -> Bool
Map.null (forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter forall {a}. LabelEntry a -> Bool
p LabelTree a
t) of
        Bool
True  -> 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 -> 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, forall k a. Map k a -> Bool
Map.null LabelTree a
t) of
        (Unassigned LabelMap a
EmptyLabelMap, Bool
True)  -> forall a. LabelMap a
EmptyLabelMap
        (Unassigned LabelMap a
EmptyLabelMap, Bool
False) -> forall a. LabelTree a -> LabelMap a
Static LabelTree a
t
        (LabelEntry a
_,                        Bool
True)  -> forall a. LabelEntry a -> LabelMap a
Wildcard LabelEntry a
w
        (LabelEntry a
_,                        Bool
False) -> LabelMap a
m

delete :: ByteString -> LabelMap a -> LabelMap a
delete :: forall a. ByteString -> LabelMap a -> LabelMap a
delete ByteString
h LabelMap a
m = 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 :: forall a. [ByteString] -> LabelMap a -> LabelMap a
deleteTree [] LabelMap a
_ = forall a. HasCallStack => String -> a
error String
"Cannot assign empty label in hostname."

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

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

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

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

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

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

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

lookup :: ByteString -> LabelMap a -> Maybe a
lookup :: forall a. ByteString -> LabelMap a -> Maybe a
lookup ByteString
h LabelMap a
m = 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 :: forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [] LabelMap a
_ = forall a. Maybe a
Nothing

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

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

lookupTree (ByteString
l:[ByteString]
ls) (Static LabelTree a
t) =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le -> forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le
        Maybe (LabelEntry a)
Nothing -> forall a. Maybe a
Nothing
lookupTree (ByteString
_:[ByteString]
ls) (Wildcard LabelEntry a
w) = forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w
lookupTree (ByteString
l:[ByteString]
ls) (WildcardExcept LabelEntry a
w LabelTree a
t) =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le ->
            case forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le of
                Just  a
e -> forall a. a -> Maybe a
Just a
e
                Maybe a
Nothing -> forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w
        Maybe (LabelEntry a)
Nothing -> forall a. [ByteString] -> LabelMap a -> Maybe a
lookupTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ 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 :: forall a. ByteString -> LabelMap a -> Bool
labelAssigned ByteString
h LabelMap a
m = 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 :: forall a. [ByteString] -> LabelMap a -> Bool
memberTree [] LabelMap a
_ = Bool
False

memberTree [ByteString
"*"] (Static LabelTree a
_)   = Bool
False
memberTree [ByteString
l]   (Static LabelTree a
t)   = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
_) = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a. LabelEntry a -> Maybe a
getPortEntry LabelEntry a
w
memberTree [ByteString
l]   (WildcardExcept LabelEntry a
_ LabelTree a
t) = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le -> forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
le
        Maybe (LabelEntry a)
Nothing -> Bool
False

memberTree (ByteString
"*":[ByteString]
ls) (Wildcard LabelEntry a
w) = forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ 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
_) = forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ forall a. LabelEntry a -> LabelMap a
labelEntryMap LabelEntry a
w
memberTree (ByteString
l:[ByteString]
ls)   (WildcardExcept LabelEntry a
_ LabelTree a
t) =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall s. FoldCase s => s -> CI s
CI.mk ByteString
l) LabelTree a
t of
        Just LabelEntry a
le -> forall a. [ByteString] -> LabelMap a -> Bool
memberTree [ByteString]
ls forall a b. (a -> b) -> a -> b
$ 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 :: forall a. LabelMap a
empty = forall a. LabelMap a
EmptyLabelMap