Implemented AXFR protocol.

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

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 1eaf27af89975b0d4df987c8aed4c3180607235a..8b50060634547d1284dcaf80eb2b18dd50bfcc20 100644 (file)
--- 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