From: PHO <pho@cielonegro.org>
Date: Tue, 26 May 2009 08:21:19 +0000 (+0900)
Subject: Implemented AXFR protocol.
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=d19ee92905c9bf32fb53c9cc0841537c7b92901c;p=haskell-dns.git

Implemented AXFR protocol.
---

diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs
index 8c99195..9fb8ee6 100644
--- a/ExampleDNSServer.hs
+++ b/ExampleDNSServer.hs
@@ -11,6 +11,7 @@ main = runNamed cnf (return . findZone)
       cnf :: Config
       cnf = Config {
               cnfServerAddress = SockAddrInet 9090 iNADDR_ANY
+            , cnfAllowTransfer = True
             }
 
       findZone :: DomainName -> Maybe Zone
@@ -30,8 +31,7 @@ main = runNamed cnf (return . findZone)
                           , soaExpirationLimit    = 3600000
                           , soaMinimumTTL         = 3600
                           }
-             , zoneRecordNames = return [ mkDN "cielonegro.org."
-                                        , mkDN "ns.cielonegro.org."
+             , zoneRecordNames = return [ mkDN "ns.cielonegro.org."
                                         , mkDN "www.cielonegro.org."
                                         , mkDN "git.cielonegro.org."
                                         ]
diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 1eaf27a..8b50060 100644
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -7,6 +7,8 @@ import           Control.Concurrent
 import           Control.Exception
 import           Control.Monad
 import           Data.Binary
+import           Data.Binary.Get
+import           Data.Binary.Put
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import           Data.Dynamic
@@ -18,6 +20,7 @@ import           Network.DNS.Named.Config
 import           Network.DNS.Named.ResponseBuilder
 import           Network.DNS.Named.Zone
 import           System.Posix.Signals
+import           System.IO
 
 
 runNamed :: Config -> (DomainName -> IO (Maybe Zone)) -> IO ()
@@ -30,7 +33,6 @@ runNamed cnf findZone
       udpListen :: IO ()
       udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
                      so <- socket AF_INET Datagram defaultProtocol
-                     print cnf
                      bindSocket so $ cnfServerAddress cnf
                      udpLoop so
 
@@ -41,7 +43,18 @@ runNamed cnf findZone
                udpLoop so
 
       tcpListen :: IO ()
-      tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
+      tcpListen = do so <- socket AF_INET Stream defaultProtocol
+                     bindSocket so $ cnfServerAddress cnf
+                     listen so 255
+                     tcpLoop so
+
+      tcpLoop :: Socket -> IO ()
+      tcpLoop so
+          = do (so', _)    <- accept so
+               h           <- socketToHandle so' ReadWriteMode
+               hSetBuffering h $ BlockBuffering Nothing
+               _handlerTID <- forkIO $ tcpHandler h
+               tcpLoop so
 
       udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
       udpHandler so packet cameFrom
@@ -53,6 +66,31 @@ runNamed cnf findZone
                _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom
                return ()
 
+      tcpHandler :: Handle -> IO ()
+      tcpHandler h
+          = do lenB   <- LBS.hGet h 2
+               if LBS.null lenB then
+                   -- Got EOF
+                   hClose h
+                 else
+                   do let len = runGet getWord16be lenB
+                      packet <- BS.hGet h $ fromIntegral len
+                      msg    <- evaluate $ unpackMessage packet
+                      msg'   <- handleMessage msg
+                                `onException`
+                                do let servfail = mkErrorReply ServerFailure msg
+                                       packet'  = packMessage Nothing servfail
+                                       len'     = fromIntegral $ BS.length packet'
+                                   LBS.hPut h $ runPut $ putWord16be len'
+                                   BS.hPut h packet'
+                                   hClose h
+                      let packet' = packMessage Nothing msg'
+                          len'    = fromIntegral $ BS.length packet'
+                      LBS.hPut h $ runPut $ putWord16be len'
+                      BS.hPut h packet'
+                      hFlush h
+                      tcpHandler h
+
       handleMessage :: Message -> IO Message
       handleMessage msg
           = case validateQuery msg of
@@ -146,8 +184,18 @@ runNamed cnf findZone
                 = matchType rr && matchClass rr
 
       handleAXFR :: SomeQ -> Zone -> IO (Builder ())
-      handleAXFR (SomeQ _q) _zone
-          = fail "FIXME: not implemented yet"
+      handleAXFR (SomeQ q) zone
+          | qName q == zoneName zone &&
+            isJust (zoneSOA zone)    &&
+            cnfAllowTransfer cnf
+              = do names      <- zoneRecordNames zone
+                   allRecords <- liftM concat $ mapM (zoneResponder zone) names
+                   return $ do addAnswer $ fromJust $ zoneSOARecord zone
+                               addAnswer $ fromJust $ zoneNSRecord  zone
+                               mapM_ addAnswer allRecords
+                               addAnswerNonuniquely $ fromJust $ zoneSOARecord zone
+          | otherwise
+              = return $ return ()
 
 
 validateQuery :: Message -> ResponseCode
diff --git a/Network/DNS/Named/Config.hs b/Network/DNS/Named/Config.hs
index ba9ad72..4985897 100644
--- a/Network/DNS/Named/Config.hs
+++ b/Network/DNS/Named/Config.hs
@@ -10,10 +10,12 @@ import           Network.Socket
 data Config
     = Config {
         cnfServerAddress :: !SockAddr
+      , cnfAllowTransfer :: !Bool
       }
     deriving Show
 
 defaultConfig :: Config
 defaultConfig = Config {
-                  cnfServerAddress = SockAddrInet 42 iNADDR_ANY
+                  cnfServerAddress = SockAddrInet 53 iNADDR_ANY
+                , cnfAllowTransfer = False
                 }
diff --git a/Network/DNS/Named/ResponseBuilder.hs b/Network/DNS/Named/ResponseBuilder.hs
index 4f08c40..5201ce3 100644
--- a/Network/DNS/Named/ResponseBuilder.hs
+++ b/Network/DNS/Named/ResponseBuilder.hs
@@ -6,6 +6,7 @@ module Network.DNS.Named.ResponseBuilder
     , unauthorise
     , setResponseCode
     , addAnswer
+    , addAnswerNonuniquely
     , addAuthority
     , addAdditional
     )
@@ -68,6 +69,11 @@ addAnswer rr
              $ modify $ \ s ->
                  s { msgAnswers = msgAnswers s ++ [rr] }
 
+addAnswerNonuniquely :: SomeRR -> Builder ()
+addAnswerNonuniquely rr
+    = modify $ \ s ->
+      s { msgAnswers = msgAnswers s ++ [rr] }
+
 addAuthority :: SomeRR -> Builder ()
 addAuthority rr
     = do anss <- get msgAnswers