X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FDNS%2FNamed.hs;h=7abdcd083461ba6720975c2645cba0f403271949;hb=f3ad40fd6916408dde9b9e6237b41828d90c1e34;hp=dbe8e71c2865f135ac93d41d2439e3f4bf16d0e5;hpb=d24a461f09bd10e3fe148e3b6b86c8e861b09a43;p=haskell-dns.git diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs index dbe8e71..7abdcd0 100644 --- a/Network/DNS/Named.hs +++ b/Network/DNS/Named.hs @@ -7,32 +7,44 @@ 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 import Data.Maybe 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.ResponseBuilder import Network.DNS.Named.Zone import System.Posix.Signals +import System.IO runNamed :: ZoneFinder zf => Config -> zf -> IO () runNamed cnf zf = withSocketsDo $ do installHandler sigPIPE Ignore Nothing - _tcpListenerTID <- forkIO $ tcpListen - udpListen + + let hint = defaultHints { + addrFlags = [AI_PASSIVE, AI_V4MAPPED] + , addrFamily = AF_INET6 + , addrSocketType = NoSocketType + , addrProtocol = defaultProtocol + } + (ai:_) <- getAddrInfo (Just hint) Nothing (Just $ cnfServerPort cnf) + + _tcpListenerTID <- forkIO $ tcpListen ai + udpListen ai where - 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 + udpListen :: AddrInfo -> IO () + udpListen ai + = do so <- socket (addrFamily ai) Datagram defaultProtocol + setSocketOption so ReuseAddr 1 + bindSocket so (addrAddress ai) + udpLoop so udpLoop :: Socket -> IO () udpLoop so @@ -40,8 +52,21 @@ runNamed cnf zf _handlerTID <- forkIO $ udpHandler so packet cameFrom udpLoop so - tcpListen :: IO () - tcpListen = putStrLn "FIXME: tcpListen is not implemented yet." + tcpListen :: AddrInfo -> IO () + tcpListen ai + = do so <- socket (addrFamily ai) Stream defaultProtocol + setSocketOption so ReuseAddr 1 + bindSocket so (addrAddress ai) + 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 +78,31 @@ runNamed cnf zf _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom return () + tcpHandler :: Handle -> IO () + tcpHandler h + = do lenB <- LBS.hGet h 2 + if LBS.length lenB < 2 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 @@ -68,13 +118,111 @@ runNamed cnf zf handleQuestion :: SomeQ -> IO (Builder ()) handleQuestion (SomeQ q) - = do zone <- findZone zf (qName q) - -- FIXME: this is merely a bogus implementation. - -- It considers no additional or authoritative sections. - results <- mapM (runResponder' q) (zoneResponders zone) - return $ do mapM_ addAnswer $ concat results - unless (zoneIsAuthoritative zone) $ - unauthorise + = do zoneM <- findZone zf (qName q) + case zoneM of + Nothing + -> return $ do unauthorise + setResponseCode Refused + Just zone + -> handleQuestionForZone (SomeQ q) zone + + handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ()) + handleQuestionForZone (SomeQ q) zone + | Just (qType q) == cast AXFR + = handleAXFR (SomeQ q) zone + | otherwise + = do allRecords <- zoneResponder zone (qName q) + let filtered = filterRecords (SomeQ q) allRecords + + additionals <- do xss <- mapM (getAdditionals zone) filtered + ys <- case zoneNSRecord zone of + Just rr -> getAdditionals zone rr + Nothing -> return [] + return (concat xss ++ ys) + + return $ do mapM_ addAnswer filtered + + when (qName q == zoneName zone) $ + do when (Just (qType q) == cast SOA || + Just (qType q) == cast ANY ) + $ case zoneSOARecord zone of + Just rr -> addAnswer rr + Nothing -> return () + + when (Just (qType q) == cast NS || + Just (qType q) == cast ANY ) + $ case zoneNSRecord zone of + Just rr -> addAnswer rr + Nothing -> return () + + mapM_ addAdditional additionals + + case zoneNSRecord zone of + Just rr -> addAuthority rr + Nothing -> unauthorise + + getAdditionals :: Zone -> SomeRR -> IO [SomeRR] + getAdditionals zone (SomeRR rr) + = case cast (rrData rr) :: Maybe DomainName of + Nothing + -> return [] + Just name + -> do allRecords <- zoneResponder zone name + + let rA = filterRecords (SomeQ qA) allRecords + rB = filterRecords (SomeQ qB) allRecords + qA = Question { + qName = name + , qType = A + , qClass = IN + } + qB = Question { + qName = name + , qType = AAAA + , qClass = IN + } + return (rA ++ rB) + + filterRecords :: SomeQ -> [SomeRR] -> [SomeRR] + filterRecords (SomeQ q) = filter predicate + where + predicate rr + = predForType rr && predForClass rr + + predForType (SomeRR rr) + | typeOf (qType q) == typeOf ANY + = True + + | typeOf (qType q) == typeOf MAILB + = typeOf (rrType rr) == typeOf MR || + typeOf (rrType rr) == typeOf MB || + typeOf (rrType rr) == typeOf MG || + typeOf (rrType rr) == typeOf MINFO + + | otherwise + = typeOf (rrType rr) == typeOf (qType q) || + typeOf (rrType rr) == typeOf CNAME + + predForClass (SomeRR rr) + | typeOf (qClass q) == typeOf ANY + = True + + | otherwise + = typeOf (rrClass rr) == typeOf (qClass q) + + handleAXFR :: SomeQ -> Zone -> IO (Builder ()) + 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 @@ -140,15 +288,5 @@ unpackMessage = decode . LBS.fromChunks . return mkErrorReply :: ResponseCode -> Message -> Message mkErrorReply err msg - = let header = msgHeader msg - msg' = msg { - msgHeader = header { - hdMessageType = Response - , hdIsAuthoritativeAnswer = False - , hdIsTruncated = False - , hdIsRecursionAvailable = False - , hdResponseCode = err - } - } - in - msg' + = runBuilder msg $ do unauthorise + setResponseCode err