From d19ee92905c9bf32fb53c9cc0841537c7b92901c Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 26 May 2009 17:21:19 +0900 Subject: [PATCH] Implemented AXFR protocol. --- ExampleDNSServer.hs | 4 +- Network/DNS/Named.hs | 56 ++++++++++++++++++++++++++-- Network/DNS/Named/Config.hs | 4 +- Network/DNS/Named/ResponseBuilder.hs | 6 +++ 4 files changed, 63 insertions(+), 7 deletions(-) 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 -- 2.40.0