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 $ mapM_ addAnswer $ concat results
78 validateQuery :: Message -> ResponseCode
79 validateQuery = validateHeader . msgHeader
81 validateHeader :: Header -> ResponseCode
83 | hdMessageType hdr /= Query = NotImplemented
84 | hdOpcode hdr /= StandardQuery = NotImplemented
88 packMessage :: Maybe Int -> Message -> BS.ByteString
89 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
91 truncateMsg :: Message -> LBS.ByteString
93 = let packet = encode msg
94 needTrunc = fromMaybe False $
96 return $ fromIntegral (LBS.length packet) > lim
99 truncateMsg $ trunc' msg
103 trunc' :: Message -> Message
105 | notNull $ msgAdditionals msg
107 msgAdditionals = truncList $ msgAdditionals msg
109 | notNull $ msgAuthorities msg
111 msgHeader = setTruncFlag $ msgHeader msg
112 , msgAuthorities = truncList $ msgAuthorities msg
114 | notNull $ msgAnswers msg
116 msgHeader = setTruncFlag $ msgHeader msg
117 , msgAnswers = truncList $ msgAnswers msg
119 | notNull $ msgQuestions msg
121 msgHeader = setTruncFlag $ msgHeader msg
122 , msgQuestions = truncList $ msgQuestions msg
125 = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
127 setTruncFlag :: Header -> Header
128 setTruncFlag hdr = hdr { hdIsTruncated = True }
130 notNull :: [a] -> Bool
133 truncList :: [a] -> [a]
134 truncList xs = take (length xs - 1) xs
136 unpackMessage :: BS.ByteString -> Message
137 unpackMessage = decode . LBS.fromChunks . return
139 mkErrorReply :: ResponseCode -> Message -> Message
141 = let header = msgHeader msg
144 hdMessageType = Response
145 , hdIsAuthoritativeAnswer = False
146 , hdIsTruncated = False
147 , hdIsRecursionAvailable = False
148 , hdResponseCode = err