DomainMap: totally untested yet

diff --git a/Network/DNS/DomainMap.hs b/Network/DNS/DomainMap.hs
new file mode 100644 (file)
index 0000000..193f2e0
--- /dev/null
+++ b/Network/DNS/DomainMap.hs
@@ -0,0 +1,160 @@
+module Network.DNS.DomainMap
+    ( DomainMap
+
+    , empty
+    , null
+    , singleton
+    , size
+
+    , fromList
+    , toList
+    , toListBy
+
+    , nearest
+    , lookup
+
+    , insert
+    , delete
+    )
+    where
+
+import qualified Data.List as L hiding (null)
+import           Data.Maybe
+import qualified Data.Trie as T
+import           Data.Trie (Trie)
+import           Network.DNS.Message
+import           Prelude hiding (null, lookup)
+
+
+newtype DomainMap a = DM (Node a)
+
+data Node a = Node (Maybe a) (Trie (Node a))
+
+
+empty :: DomainMap a
+empty = DM emptyNode
+
+
+emptyNode :: Node a
+emptyNode = Node Nothing T.empty
+
+
+null :: DomainMap a -> Bool
+null (DM n) = nodeNull n
+
+
+nodeNull :: Node a -> Bool
+nodeNull (Node (Just _) _) = False
+nodeNull (Node Nothing  t) = all nodeNull $ T.toListBy (\ _ a -> a) t
+
+
+singleton :: DomainName -> a -> DomainMap a
+singleton key value
+    = insert key value empty
+
+
+size :: forall a. DomainMap a -> Int
+size (DM n) = nodeSize n
+
+
+nodeSize :: Node a -> Int
+nodeSize (Node m t)
+    = let x  = if isJust m then
+                   1
+               else
+                   0
+          xs = map nodeSize $ T.toListBy (\ _ a -> a) t
+      in
+        L.foldl' (+) x xs
+
+
+fromList :: forall a. [(DomainName, a)] -> DomainMap a
+fromList []            = empty
+fromList ((k, v) : xs) = insert k v $ fromList xs
+
+
+toList :: forall a. DomainMap a -> [(DomainName, a)]
+toList (DM root) = toList' rootName root
+    where
+      toList' :: DomainName -> Node a -> [(DomainName, a)]
+      toList' soFar (Node m t)
+          = let x  = case m of
+                       Just v  -> [(soFar, v)]
+                       Nothing -> []
+                xs = concat $ map toList'' $ T.toList t
+            in
+              x ++ xs
+          where
+            toList'' :: (DomainLabel, Node a) -> [(DomainName, a)]
+            toList'' (l, n) = toList' (consLabel l soFar) n
+
+
+toListBy :: forall a b. DomainMap a -> (DomainName -> a -> b) -> [b]
+toListBy dm f = map (uncurry f) $ toList dm
+
+
+nearest :: forall a. DomainName -> DomainMap a -> Maybe a
+nearest key (DM root) = nearest' key' root
+    where
+      key' :: [DomainLabel]
+      key' = reverse $ nameToLabels key
+
+      nearest' :: [DomainLabel] -> Node a -> Maybe a
+      nearest' []     _          = error ("Illegal key: " ++ show key)
+      nearest' (_:[]) (Node m _) = m
+      nearest' (x:xs) (Node m t) = let nearer = do subNode' <- T.lookup x t
+                                                   nearest' xs subNode'
+                                   in
+                                     if isJust nearer then
+                                         nearer
+                                     else
+                                         m
+
+
+lookup :: forall a. DomainName -> DomainMap a -> Maybe a
+lookup key (DM root) = lookup' key' root
+    where
+      key' :: [DomainLabel]
+      key' = reverse $ nameToLabels key
+
+      lookup' :: [DomainLabel] -> Node a -> Maybe a
+      lookup' []     _          = error ("Illegal key: " ++ show key)
+      lookup' (_:[]) (Node m _) = m
+      lookup' (x:xs) (Node _ t) = do subNode' <- T.lookup x t
+                                     lookup' xs subNode'
+
+
+insert :: forall a. DomainName -> a -> DomainMap a -> DomainMap a
+insert key value (DM root) = DM $ insert' key' root
+    where
+      key' :: [DomainLabel]
+      key' = reverse $ nameToLabels key
+
+      insert' :: [DomainLabel] -> Node a -> Node a
+      insert' []     _          = error ("Illegal key: " ++ show key)
+      insert' (_:[]) (Node _ t) = Node (Just value) t
+      insert' (x:xs) (Node m t) = let subNode' = case T.lookup x t of
+                                                   Just subNode -> insert' xs subNode
+                                                   Nothing      -> insert' xs emptyNode
+                                      trie'    = T.insert x subNode' t
+                                  in
+                                    Node m trie'
+
+delete :: forall a. DomainName -> DomainMap a -> DomainMap a
+delete key (DM root) = DM $ delete' key' root
+    where
+      key' :: [DomainLabel]
+      key' = reverse $ nameToLabels key
+
+      delete' :: [DomainLabel] -> Node a -> Node a
+      delete' []     _          = error ("Illegal key: " ++ show key)
+      delete' (_:[]) (Node _ t) = Node Nothing t
+      delete' (x:xs) (Node m t) = let subNode' = case T.lookup x t of
+                                                   Just subNode -> delete' xs subNode
+                                                   Nothing      -> emptyNode
+                                      trie'    = if nodeNull subNode' then
+                                                     T.delete x t
+                                                 else
+                                                     T.insert x subNode' t
+                                  in
+                                    Node m trie'

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index 9f2b144968c7f394e84068dae3a8cccd84b9b259..9713dd2a707ed66d8776458733401346d7eb2e72 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -51,6 +51,11 @@ module Network.DNS.Message
 
     , mkDomainName
     , mkDN
+    , rootName
+    , isRootName
+    , consLabel
+    , unconsLabel
+    , nameToLabels
     , isZoneOf
 
     , wrapQuestion
@@ -228,6 +233,9 @@ unconsLabel :: DomainName -> (DomainLabel, DomainName)
 unconsLabel (DN (x:xs)) = (x, DN xs)
 unconsLabel x           = error ("Illegal use of unconsLabel: " ++ show x)
 
+nameToLabels :: DomainName -> [DomainLabel]
+nameToLabels (DN xs) = xs
+
 isZoneOf :: DomainName -> DomainName -> Bool
 isZoneOf (DN a) (DN b) = a `isSuffixOf` b
 

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 8b50060634547d1284dcaf80eb2b18dd50bfcc20..4a9eaed2fa26eda15576a94673deead4c5d42a82 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -69,7 +69,7 @@ runNamed cnf findZone
       tcpHandler :: Handle -> IO ()
       tcpHandler h
           = do lenB   <- LBS.hGet h 2
-               if LBS.null lenB then
+               if LBS.length lenB < 2 then
                    -- Got EOF
                    hClose h
                  else

diff --git a/dns.cabal b/dns.cabal
index d6c194a8f66c78cec040e1108dccdc289805465c..cbe24359e8e26237be07b8284e8fe01cfc8f1cc6 100644 (file)
--- a/dns.cabal
+++ b/dns.cabal
@@ -23,10 +23,11 @@ Flag build-test-suite
 
 Library
     Build-Depends:
-        base, binary, binary-strict, bytestring, containers, mtl,
-        network, network-bytestring, unix
+        base, binary, binary-strict, bytestring, bytestring-trie,
+        containers, mtl, network, network-bytestring, unix
 
     Exposed-Modules:
+        Network.DNS.DomainMap
         Network.DNS.Message
         Network.DNS.Named
         Network.DNS.Named.Config