1 module Network.DNS.Named
6 import Control.Concurrent
7 import Control.Exception
10 import Data.Binary.Get
11 import Data.Binary.Put
12 import qualified Data.ByteString as BS
13 import qualified Data.ByteString.Lazy as LBS
17 import qualified Network.Socket.ByteString as NB
18 import Network.DNS.Message
19 import Network.DNS.Named.Config
20 import Network.DNS.Named.ResponseBuilder
21 import Network.DNS.Named.Zone
22 import System.Posix.Signals
26 runNamed :: ZoneFinder zf => Config -> zf -> IO ()
29 do installHandler sigPIPE Ignore Nothing
31 let hint = defaultHints {
32 addrFlags = [AI_PASSIVE, AI_V4MAPPED]
33 , addrFamily = AF_INET6
34 , addrSocketType = NoSocketType
35 , addrProtocol = defaultProtocol
37 (ai:_) <- getAddrInfo (Just hint) Nothing (Just $ cnfServerPort cnf)
39 _tcpListenerTID <- forkIO $ tcpListen ai
42 udpListen :: AddrInfo -> IO ()
44 = do so <- socket (addrFamily ai) Datagram defaultProtocol
45 setSocketOption so ReuseAddr 1
46 bindSocket so (addrAddress ai)
49 udpLoop :: Socket -> IO ()
51 = do (packet, cameFrom) <- NB.recvFrom so 512
52 _handlerTID <- forkIO $ udpHandler so packet cameFrom
55 tcpListen :: AddrInfo -> IO ()
57 = do so <- socket (addrFamily ai) Stream defaultProtocol
58 setSocketOption so ReuseAddr 1
59 bindSocket so (addrAddress ai)
63 tcpLoop :: Socket -> IO ()
65 = do (so', _) <- accept so
66 h <- socketToHandle so' ReadWriteMode
67 hSetBuffering h $ BlockBuffering Nothing
68 _handlerTID <- forkIO $ tcpHandler h
71 udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
72 udpHandler so packet cameFrom
73 = do msg <- evaluate $ unpackMessage packet
74 msg' <- handleMessage msg
76 do let servfail = mkErrorReply ServerFailure msg
77 NB.sendTo so (packMessage (Just 512) servfail) cameFrom
78 _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom
81 tcpHandler :: Handle -> IO ()
83 = do lenB <- LBS.hGet h 2
84 if LBS.length lenB < 2 then
88 do let len = runGet getWord16be lenB
89 packet <- BS.hGet h $ fromIntegral len
90 msg <- evaluate $ unpackMessage packet
91 msg' <- handleMessage msg
93 do let servfail = mkErrorReply ServerFailure msg
94 packet' = packMessage Nothing servfail
95 len' = fromIntegral $ BS.length packet'
96 LBS.hPut h $ runPut $ putWord16be len'
99 let packet' = packMessage Nothing msg'
100 len' = fromIntegral $ BS.length packet'
101 LBS.hPut h $ runPut $ putWord16be len'
106 handleMessage :: Message -> IO Message
108 = case validateQuery msg of
110 -> do builders <- mapM handleQuestion $ msgQuestions msg
112 let builder = foldl (>>) (return ()) builders
113 msg' = runBuilder msg builder
117 err -> return $ mkErrorReply err msg
119 handleQuestion :: SomeQ -> IO (Builder ())
120 handleQuestion (SomeQ q)
121 = do zoneM <- findZone zf (qName q)
124 -> return $ do unauthorise
125 setResponseCode Refused
127 -> handleQuestionForZone q zone
129 handleQuestionForZone :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ())
130 handleQuestionForZone q zone
131 | Just (qType q) == cast AXFR
134 = do answers <- getRecords zone q
135 authority <- getRecords zone (Question (zoneName zone) NS IN)
136 additionals <- liftM concat $ mapM (getAdditionals zone) (answers ++ authority)
137 isAuth <- isAuthoritativeZone zone
138 return $ do mapM_ addAnswer answers
139 mapM_ addAuthority authority
140 mapM_ addAdditional additionals
141 unless isAuth unauthorise
143 getAdditionals :: Zone z => z -> SomeRR -> IO [SomeRR]
144 getAdditionals zone (SomeRR rr)
145 = case cast (rrData rr) :: Maybe DomainName of
149 -> do rrA <- getRecords zone (Question name A IN)
150 rrAAAA <- getRecords zone (Question name AAAA IN)
151 return (rrA ++ rrAAAA)
153 handleAXFR :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ())
155 | cnfAllowTransfer cnf
156 = do rs <- getRecords zone q
157 return $ mapM_ addAnswerNonuniquely rs
162 validateQuery :: Message -> ResponseCode
163 validateQuery = validateHeader . msgHeader
165 validateHeader :: Header -> ResponseCode
167 | hdMessageType hdr /= Query = NotImplemented
168 | hdOpcode hdr /= StandardQuery = NotImplemented
169 | otherwise = NoError
172 packMessage :: Maybe Int -> Message -> BS.ByteString
173 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
175 truncateMsg :: Message -> LBS.ByteString
177 = let packet = encode msg
178 needTrunc = fromMaybe False $
180 return $ fromIntegral (LBS.length packet) > lim
183 truncateMsg $ trunc' msg
187 trunc' :: Message -> Message
189 | notNull $ msgAdditionals msg
191 msgAdditionals = truncList $ msgAdditionals msg
193 | notNull $ msgAuthorities msg
195 msgHeader = setTruncFlag $ msgHeader msg
196 , msgAuthorities = truncList $ msgAuthorities msg
198 | notNull $ msgAnswers msg
200 msgHeader = setTruncFlag $ msgHeader msg
201 , msgAnswers = truncList $ msgAnswers msg
203 | notNull $ msgQuestions msg
205 msgHeader = setTruncFlag $ msgHeader msg
206 , msgQuestions = truncList $ msgQuestions msg
209 = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
211 setTruncFlag :: Header -> Header
212 setTruncFlag hdr = hdr { hdIsTruncated = True }
214 notNull :: [a] -> Bool
217 truncList :: [a] -> [a]
218 truncList xs = take (length xs - 1) xs
220 unpackMessage :: BS.ByteString -> Message
221 unpackMessage = decode . LBS.fromChunks . return
223 mkErrorReply :: ResponseCode -> Message -> Message
225 = runBuilder msg $ do unauthorise