Many changes...

[haskell-dns.git] / Network / DNS / Named.hs

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 13297e8ae2fbbb2bf31051255ebe23ecd8bb5d8b..137bdd52f2994af1f4ab4e350d10f88a820da186 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -1,10 +1,5 @@
 module Network.DNS.Named
-    ( ZoneFinder(..)
-    , Zone(..)
-
-    , runNamed
-
-    , defaultRootZone
+    ( runNamed
     )
     where
 
@@ -19,34 +14,11 @@ import           Network.Socket
 import qualified Network.Socket.ByteString as NB
 import           Network.DNS.Message
 import           Network.DNS.Named.Config
+import           Network.DNS.Named.Responder
+import           Network.DNS.Named.Zone
 import           System.Posix.Signals
 
 
-class ZoneFinder a where
-    findZone :: a -> DomainName -> IO Zone
-
-instance ZoneFinder (DomainName -> Zone) where
-    findZone = (return .)
-
-instance ZoneFinder (DomainName -> IO Zone) where
-    findZone = id
-
-instance ZoneFinder (DomainName -> Maybe Zone) where
-    findZone = ((return . fromMaybe defaultRootZone) .)
-
-instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
-    findZone = (fmap (fromMaybe defaultRootZone) .)
-
-
-data Zone
-    = Zone {
-        zoneName :: !DomainName
-      }
-
-defaultRootZone :: Zone
-defaultRootZone = error "FIXME: defaultRootZone is not implemented yet"
-
-
 runNamed :: ZoneFinder zf => Config -> zf -> IO ()
 runNamed cnf zf
     = withSocketsDo $
@@ -75,24 +47,88 @@ runNamed cnf zf
           = do msg   <- evaluate $ unpackMessage packet
                msg'  <- handleMessage msg
                         `onException`
-                        NB.sendTo so (packMessage $ makeServerFailure msg) cameFrom
-               _sent <- NB.sendTo so (packMessage $ msg'                 ) cameFrom
+                        do let servfail = mkErrorReply ServerFailure msg
+                           NB.sendTo so (packMessage (Just 512) servfail) cameFrom
+               _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom
                return ()
 
       handleMessage :: Message -> IO Message
       handleMessage msg
-          = fail (show msg) -- FIXME
+          = case validateQuery msg of
+              NoError
+                  -> fail "FIXME: not impl" -- msgQuestions msg
+              err -> return $ mkErrorReply err msg
+
+      handleQuestion :: SomeQ -> IO [SomeRR]
+      handleQuestion (SomeQ q)
+          = do zone       <- findZone zf (qName q)
+               results    <- mapM (runResponder' q) (zoneResponders zone)
+               return $ concat results
+
+
+validateQuery :: Message -> ResponseCode
+validateQuery = validateHeader . msgHeader
+    where
+      validateHeader :: Header -> ResponseCode
+      validateHeader hdr
+          | hdMessageType hdr /= Query         = NotImplemented
+          | hdOpcode      hdr /= StandardQuery = NotImplemented
+          | otherwise                          = NoError
 
 
-packMessage :: Message -> BS.ByteString
-packMessage = BS.concat . LBS.toChunks . encode
+packMessage :: Maybe Int -> Message -> BS.ByteString
+packMessage limM = BS.concat . LBS.toChunks . truncateMsg
+    where
+      truncateMsg :: Message -> LBS.ByteString
+      truncateMsg msg
+          = let packet    = encode msg
+                needTrunc = fromMaybe False $
+                            do lim <- limM
+                               return $ fromIntegral (LBS.length packet) > lim
+            in
+              if needTrunc then
+                  truncateMsg $ trunc' msg
+              else
+                  packet
+
+      trunc' :: Message -> Message
+      trunc' msg
+          | notNull $ msgAdditionals msg
+              = msg {
+                  msgAdditionals = truncList $ msgAdditionals msg
+                }
+          | notNull $ msgAuthorities msg
+              = msg {
+                  msgHeader      = setTruncFlag $ msgHeader msg
+                , msgAuthorities = truncList $ msgAuthorities msg
+                }
+          | notNull $ msgAnswers msg
+              = msg {
+                  msgHeader      = setTruncFlag $ msgHeader msg
+                , msgAnswers     = truncList $ msgAnswers msg
+                }
+          | notNull $ msgQuestions msg
+              = msg {
+                  msgHeader      = setTruncFlag $ msgHeader msg
+                , msgQuestions   = truncList $ msgQuestions msg
+                }
+          | otherwise
+              = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
+
+      setTruncFlag :: Header -> Header
+      setTruncFlag hdr = hdr { hdIsTruncated = True }
+
+      notNull :: [a] -> Bool
+      notNull = not . null
+
+      truncList :: [a] -> [a]
+      truncList xs = take (length xs - 1) xs
 
 unpackMessage :: BS.ByteString -> Message
 unpackMessage = decode . LBS.fromChunks . return
 
-
-makeServerFailure :: Message -> Message
-makeServerFailure msg
+mkErrorReply :: ResponseCode -> Message -> Message
+mkErrorReply err msg
     = let header = msgHeader msg
           msg'   = msg {
                      msgHeader = header {
@@ -100,7 +136,7 @@ makeServerFailure msg
                                  , hdIsAuthoritativeAnswer = False
                                  , hdIsTruncated           = False
                                  , hdIsRecursionAvailable  = False
-                                 , hdResponseCode          = ServerFailure
+                                 , hdResponseCode          = err
                                  }
                    }
       in