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
- 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
_handlerTID <- forkIO $ udpHandler so packet cameFrom
udpLoop so
- tcpListen :: IO ()
- tcpListen = do so <- socket AF_INET Stream defaultProtocol
- bindSocket so $ cnfServerAddress cnf
- listen so 255
- tcpLoop so
+ 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
tcpHandler :: Handle -> IO ()
tcpHandler h
= do lenB <- LBS.hGet h 2
- if LBS.null lenB then
+ if LBS.length lenB < 2 then
-- Got EOF
hClose h
else
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
- | 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
+ -> 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 ()
projects / haskell-dns.git / blobdiff