X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FDNS%2FNamed.hs;h=3ce2a9ad7d1018a86c78bb304e4d4d28d28e6c41;hb=e4ee321871e4ffed54d1378db5080389d76032c1;hp=1eaf27af89975b0d4df987c8aed4c3180607235a;hpb=957d3f466cea2fa642f67f477ec4ad9a0d535a9b;p=haskell-dns.git diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs index 1eaf27a..3ce2a9a 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,21 +20,31 @@ 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 () -runNamed cnf findZone +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 findZone _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 findZone _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,86 +118,45 @@ runNamed cnf findZone handleQuestion :: SomeQ -> IO (Builder ()) handleQuestion (SomeQ q) - = do zoneM <- findZone (qName q) + = do zoneM <- findZone zf (qName q) case zoneM of Nothing -> return $ do unauthorise setResponseCode Refused Just zone - -> handleQuestionForZone (SomeQ q) zone + -> handleQuestionForZone q zone - handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ()) - handleQuestionForZone (SomeQ q) zone + handleQuestionForZone :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ()) + handleQuestionForZone q zone | Just (qType q) == cast AXFR - = handleAXFR (SomeQ q) zone + = handleAXFR 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 () - + = do answers <- getRecords zone q + authority <- getRecords zone (Question (zoneName zone) NS IN) + additionals <- liftM concat $ mapM (getAdditionals zone) (answers ++ authority) + isAuth <- isAuthoritativeZone zone + return $ do mapM_ addAnswer answers + mapM_ addAuthority authority mapM_ addAdditional additionals + unless isAuth unauthorise - case zoneNSRecord zone of - Just rr -> addAuthority rr - Nothing -> unauthorise - - getAdditionals :: Zone -> SomeRR -> IO [SomeRR] + getAdditionals :: Zone z => z -> SomeRR -> IO [SomeRR] getAdditionals zone (SomeRR rr) = case cast (rrData rr) :: Maybe DomainName of Nothing -> return [] Just name - -> do allRecords <- zoneResponder zone name - - let filtered = filterRecords (SomeQ q') allRecords - q' = Question { - qName = name - , qType = A - , qClass = IN - } - return filtered - - filterRecords :: SomeQ -> [SomeRR] -> [SomeRR] - filterRecords (SomeQ q) - | Just (qType q) == cast ANY && - Just (qClass q) == cast ANY = id - | Just (qType q) == cast ANY = filter matchClass - | Just (qClass q) == cast ANY = filter matchType - | otherwise = filter matchBoth - where - matchClass (SomeRR rr) - = Just (qClass q) == cast (rrClass rr) - - matchType (SomeRR rr) - = Just (qType q) == cast (rrType rr) || - Just CNAME == cast (rrType rr) - - matchBoth rr - = matchType rr && matchClass rr - - handleAXFR :: SomeQ -> Zone -> IO (Builder ()) - handleAXFR (SomeQ _q) _zone - = fail "FIXME: not implemented yet" + -> do rrA <- getRecords zone (Question name A IN) + rrAAAA <- getRecords zone (Question name AAAA IN) + return (rrA ++ rrAAAA) + + handleAXFR :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ()) + handleAXFR q zone + | cnfAllowTransfer cnf + = do rs <- getRecords zone q + return $ mapM_ addAnswerNonuniquely rs + | otherwise + = return $ return () validateQuery :: Message -> ResponseCode