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.ResponseBuilder
19 import Network.DNS.Named.Zone
20 import System.Posix.Signals
23 runNamed :: ZoneFinder zf => Config -> zf -> 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 zone <- findZone zf (qName q)
72 -- FIXME: this is merely a bogus implementation.
73 -- It considers no additional or authoritative sections.
74 results <- mapM (runResponder' q) (zoneResponders zone)
75 return $ do mapM_ addAnswer $ concat results
76 unless (zoneIsAuthoritative zone) $
80 validateQuery :: Message -> ResponseCode
81 validateQuery = validateHeader . msgHeader
83 validateHeader :: Header -> ResponseCode
85 | hdMessageType hdr /= Query = NotImplemented
86 | hdOpcode hdr /= StandardQuery = NotImplemented
90 packMessage :: Maybe Int -> Message -> BS.ByteString
91 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
93 truncateMsg :: Message -> LBS.ByteString
95 = let packet = encode msg
96 needTrunc = fromMaybe False $
98 return $ fromIntegral (LBS.length packet) > lim
101 truncateMsg $ trunc' msg
105 trunc' :: Message -> Message
107 | notNull $ msgAdditionals msg
109 msgAdditionals = truncList $ msgAdditionals msg
111 | notNull $ msgAuthorities msg
113 msgHeader = setTruncFlag $ msgHeader msg
114 , msgAuthorities = truncList $ msgAuthorities msg
116 | notNull $ msgAnswers msg
118 msgHeader = setTruncFlag $ msgHeader msg
119 , msgAnswers = truncList $ msgAnswers msg
121 | notNull $ msgQuestions msg
123 msgHeader = setTruncFlag $ msgHeader msg
124 , msgQuestions = truncList $ msgQuestions msg
127 = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
129 setTruncFlag :: Header -> Header
130 setTruncFlag hdr = hdr { hdIsTruncated = True }
132 notNull :: [a] -> Bool
135 truncList :: [a] -> [a]
136 truncList xs = take (length xs - 1) xs
138 unpackMessage :: BS.ByteString -> Message
139 unpackMessage = decode . LBS.fromChunks . return
141 mkErrorReply :: ResponseCode -> Message -> Message
143 = let header = msgHeader msg
146 hdMessageType = Response
147 , hdIsAuthoritativeAnswer = False
148 , hdIsTruncated = False
149 , hdIsRecursionAvailable = False
150 , hdResponseCode = err