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
15 import qualified Network.Socket.ByteString as NB
16 import Network.DNS.Message
17 import Network.DNS.Named.Config
18 import Network.DNS.Named.ResponseBuilder
19 import Network.DNS.Named.Zone
20 import System.Posix.Signals
23 runNamed :: Config -> (DomainName -> IO (Maybe Zone)) -> IO ()
26 do installHandler sigPIPE Ignore Nothing
27 _tcpListenerTID <- forkIO $ tcpListen
31 udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
32 so <- socket AF_INET Datagram defaultProtocol
34 bindSocket so $ cnfServerAddress cnf
37 udpLoop :: Socket -> IO ()
39 = do (packet, cameFrom) <- NB.recvFrom so 512
40 _handlerTID <- forkIO $ udpHandler so packet cameFrom
44 tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
46 udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
47 udpHandler so packet cameFrom
48 = do msg <- evaluate $ unpackMessage packet
49 msg' <- handleMessage msg
51 do let servfail = mkErrorReply ServerFailure msg
52 NB.sendTo so (packMessage (Just 512) servfail) cameFrom
53 _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom
56 handleMessage :: Message -> IO Message
58 = case validateQuery msg of
60 -> do builders <- mapM handleQuestion $ msgQuestions msg
62 let builder = foldl (>>) (return ()) builders
63 msg' = runBuilder msg builder
67 err -> return $ mkErrorReply err msg
69 handleQuestion :: SomeQ -> IO (Builder ())
70 handleQuestion (SomeQ q)
71 = do zoneM <- findZone (qName q)
74 -> return $ do unauthorise
75 setResponseCode Refused
77 -> handleQuestionForZone (SomeQ q) zone
79 handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ())
80 handleQuestionForZone (SomeQ q) zone
81 | Just (qType q) == cast AXFR
82 = handleAXFR (SomeQ q) zone
84 = do allRecords <- zoneResponder zone (qName q)
85 let filtered = filterRecords (SomeQ q) allRecords
87 additionals <- do xss <- mapM (getAdditionals zone) filtered
88 ys <- case zoneNSRecord zone of
89 Just rr -> getAdditionals zone rr
91 return (concat xss ++ ys)
93 return $ do mapM_ addAnswer filtered
95 when (qName q == zoneName zone) $
96 do when (Just (qType q) == cast SOA ||
97 Just (qType q) == cast ANY )
98 $ case zoneSOARecord zone of
99 Just rr -> addAnswer rr
102 when (Just (qType q) == cast NS ||
103 Just (qType q) == cast ANY )
104 $ case zoneNSRecord zone of
105 Just rr -> addAnswer rr
108 mapM_ addAdditional additionals
110 case zoneNSRecord zone of
111 Just rr -> addAuthority rr
112 Nothing -> unauthorise
114 getAdditionals :: Zone -> SomeRR -> IO [SomeRR]
115 getAdditionals zone (SomeRR rr)
116 = case cast (rrData rr) :: Maybe DomainName of
120 -> do allRecords <- zoneResponder zone name
122 let filtered = filterRecords (SomeQ q') allRecords
130 filterRecords :: SomeQ -> [SomeRR] -> [SomeRR]
131 filterRecords (SomeQ q)
132 | Just (qType q) == cast ANY &&
133 Just (qClass q) == cast ANY = id
134 | Just (qType q) == cast ANY = filter matchClass
135 | Just (qClass q) == cast ANY = filter matchType
136 | otherwise = filter matchBoth
138 matchClass (SomeRR rr)
139 = Just (qClass q) == cast (rrClass rr)
141 matchType (SomeRR rr)
142 = Just (qType q) == cast (rrType rr) ||
143 Just CNAME == cast (rrType rr)
146 = matchType rr && matchClass rr
148 handleAXFR :: SomeQ -> Zone -> IO (Builder ())
149 handleAXFR (SomeQ _q) _zone
150 = fail "FIXME: not implemented yet"
153 validateQuery :: Message -> ResponseCode
154 validateQuery = validateHeader . msgHeader
156 validateHeader :: Header -> ResponseCode
158 | hdMessageType hdr /= Query = NotImplemented
159 | hdOpcode hdr /= StandardQuery = NotImplemented
160 | otherwise = NoError
163 packMessage :: Maybe Int -> Message -> BS.ByteString
164 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
166 truncateMsg :: Message -> LBS.ByteString
168 = let packet = encode msg
169 needTrunc = fromMaybe False $
171 return $ fromIntegral (LBS.length packet) > lim
174 truncateMsg $ trunc' msg
178 trunc' :: Message -> Message
180 | notNull $ msgAdditionals msg
182 msgAdditionals = truncList $ msgAdditionals msg
184 | notNull $ msgAuthorities msg
186 msgHeader = setTruncFlag $ msgHeader msg
187 , msgAuthorities = truncList $ msgAuthorities msg
189 | notNull $ msgAnswers msg
191 msgHeader = setTruncFlag $ msgHeader msg
192 , msgAnswers = truncList $ msgAnswers msg
194 | notNull $ msgQuestions msg
196 msgHeader = setTruncFlag $ msgHeader msg
197 , msgQuestions = truncList $ msgQuestions msg
200 = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
202 setTruncFlag :: Header -> Header
203 setTruncFlag hdr = hdr { hdIsTruncated = True }
205 notNull :: [a] -> Bool
208 truncList :: [a] -> [a]
209 truncList xs = take (length xs - 1) xs
211 unpackMessage :: BS.ByteString -> Message
212 unpackMessage = decode . LBS.fromChunks . return
214 mkErrorReply :: ResponseCode -> Message -> Message
216 = runBuilder msg $ do unauthorise