1 module Network.DNS.Named
6 import Control.Concurrent
7 import Control.Exception
10 import qualified Data.ByteString as BS
11 import qualified Data.ByteString.Lazy as LBS
14 import qualified Network.Socket.ByteString as NB
15 import Network.DNS.Message
16 import Network.DNS.Named.Config
17 import Network.DNS.Named.Responder
18 import Network.DNS.Named.Zone
19 import System.Posix.Signals
22 runNamed :: ZoneFinder zf => Config -> zf -> IO ()
25 do installHandler sigPIPE Ignore Nothing
26 _tcpListenerTID <- forkIO $ tcpListen
30 udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
31 so <- socket AF_INET Datagram defaultProtocol
33 bindSocket so $ cnfServerAddress cnf
36 udpLoop :: Socket -> IO ()
38 = do (packet, cameFrom) <- NB.recvFrom so 512
39 _handlerTID <- forkIO $ udpHandler so packet cameFrom
43 tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
45 udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
46 udpHandler so packet cameFrom
47 = do msg <- evaluate $ unpackMessage packet
48 msg' <- handleMessage msg
50 do let servfail = mkErrorReply ServerFailure msg
51 NB.sendTo so (packMessage (Just 512) servfail) cameFrom
52 _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom
55 handleMessage :: Message -> IO Message
57 = case validateQuery msg of
59 -> fail "FIXME: not impl" -- msgQuestions msg
60 err -> return $ mkErrorReply err msg
62 handleQuestion :: SomeQ -> IO [SomeRR]
63 handleQuestion (SomeQ q)
64 = do zone <- findZone zf (qName q)
65 results <- mapM (runResponder' q) (zoneResponders zone)
66 return $ concat results
69 validateQuery :: Message -> ResponseCode
70 validateQuery = validateHeader . msgHeader
72 validateHeader :: Header -> ResponseCode
74 | hdMessageType hdr /= Query = NotImplemented
75 | hdOpcode hdr /= StandardQuery = NotImplemented
79 packMessage :: Maybe Int -> Message -> BS.ByteString
80 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
82 truncateMsg :: Message -> LBS.ByteString
84 = let packet = encode msg
85 needTrunc = fromMaybe False $
87 return $ fromIntegral (LBS.length packet) > lim
90 truncateMsg $ trunc' msg
94 trunc' :: Message -> Message
96 | notNull $ msgAdditionals msg
98 msgAdditionals = truncList $ msgAdditionals msg
100 | notNull $ msgAuthorities msg
102 msgHeader = setTruncFlag $ msgHeader msg
103 , msgAuthorities = truncList $ msgAuthorities msg
105 | notNull $ msgAnswers msg
107 msgHeader = setTruncFlag $ msgHeader msg
108 , msgAnswers = truncList $ msgAnswers msg
110 | notNull $ msgQuestions msg
112 msgHeader = setTruncFlag $ msgHeader msg
113 , msgQuestions = truncList $ msgQuestions msg
116 = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
118 setTruncFlag :: Header -> Header
119 setTruncFlag hdr = hdr { hdIsTruncated = True }
121 notNull :: [a] -> Bool
124 truncList :: [a] -> [a]
125 truncList xs = take (length xs - 1) xs
127 unpackMessage :: BS.ByteString -> Message
128 unpackMessage = decode . LBS.fromChunks . return
130 mkErrorReply :: ResponseCode -> Message -> Message
132 = let header = msgHeader msg
135 hdMessageType = Response
136 , hdIsAuthoritativeAnswer = False
137 , hdIsTruncated = False
138 , hdIsRecursionAvailable = False
139 , hdResponseCode = err