Network/DNS/Named.hs

   1 module Network.DNS.Named
   2     ( runNamed
   3     )
   4     where
   5
   6 import           Control.Concurrent
   7 import           Control.Exception
   8 import           Control.Monad
   9 import           Data.Binary
  10 import qualified Data.ByteString as BS
  11 import qualified Data.ByteString.Lazy as LBS
  12 import           Data.Maybe
  13 import           Network.Socket
  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
  21
  22
  23 runNamed :: ZoneFinder zf => Config -> zf -> IO ()
  24 runNamed cnf zf
  25     = withSocketsDo $
  26       do installHandler sigPIPE Ignore Nothing
  27          _tcpListenerTID <- forkIO $ tcpListen
  28          udpListen
  29     where
  30       udpListen :: IO ()
  31       udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
  32                      so <- socket AF_INET Datagram defaultProtocol
  33                      print cnf
  34                      bindSocket so $ cnfServerAddress cnf
  35                      udpLoop so
  36
  37       udpLoop :: Socket -> IO ()
  38       udpLoop so
  39           = do (packet, cameFrom) <- NB.recvFrom so 512
  40                _handlerTID <- forkIO $ udpHandler so packet cameFrom
  41                udpLoop so
  42
  43       tcpListen :: IO ()
  44       tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
  45
  46       udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
  47       udpHandler so packet cameFrom
  48           = do msg   <- evaluate $ unpackMessage packet
  49                msg'  <- handleMessage msg
  50                         `onException`
  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
  54                return ()
  55
  56       handleMessage :: Message -> IO Message
  57       handleMessage msg
  58           = case validateQuery msg of
  59               NoError
  60                   -> do builders <- mapM handleQuestion $ msgQuestions msg
  61
  62                         let builder = foldl (>>) (return ()) builders
  63                             msg'    = runBuilder msg builder
  64
  65                         return msg'
  66
  67               err -> return $ mkErrorReply err msg
  68
  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) $
  77                                   unauthorise
  78
  79
  80 validateQuery :: Message -> ResponseCode
  81 validateQuery = validateHeader . msgHeader
  82     where
  83       validateHeader :: Header -> ResponseCode
  84       validateHeader hdr
  85           | hdMessageType hdr /= Query         = NotImplemented
  86           | hdOpcode      hdr /= StandardQuery = NotImplemented
  87           | otherwise                          = NoError
  88
  89
  90 packMessage :: Maybe Int -> Message -> BS.ByteString
  91 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
  92     where
  93       truncateMsg :: Message -> LBS.ByteString
  94       truncateMsg msg
  95           = let packet    = encode msg
  96                 needTrunc = fromMaybe False $
  97                             do lim <- limM
  98                                return $ fromIntegral (LBS.length packet) > lim
  99             in
 100               if needTrunc then
 101                   truncateMsg $ trunc' msg
 102               else
 103                   packet
 104
 105       trunc' :: Message -> Message
 106       trunc' msg
 107           | notNull $ msgAdditionals msg
 108               = msg {
 109                   msgAdditionals = truncList $ msgAdditionals msg
 110                 }
 111           | notNull $ msgAuthorities msg
 112               = msg {
 113                   msgHeader      = setTruncFlag $ msgHeader msg
 114                 , msgAuthorities = truncList $ msgAuthorities msg
 115                 }
 116           | notNull $ msgAnswers msg
 117               = msg {
 118                   msgHeader      = setTruncFlag $ msgHeader msg
 119                 , msgAnswers     = truncList $ msgAnswers msg
 120                 }
 121           | notNull $ msgQuestions msg
 122               = msg {
 123                   msgHeader      = setTruncFlag $ msgHeader msg
 124                 , msgQuestions   = truncList $ msgQuestions msg
 125                 }
 126           | otherwise
 127               = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
 128
 129       setTruncFlag :: Header -> Header
 130       setTruncFlag hdr = hdr { hdIsTruncated = True }
 131
 132       notNull :: [a] -> Bool
 133       notNull = not . null
 134
 135       truncList :: [a] -> [a]
 136       truncList xs = take (length xs - 1) xs
 137
 138 unpackMessage :: BS.ByteString -> Message
 139 unpackMessage = decode . LBS.fromChunks . return
 140
 141 mkErrorReply :: ResponseCode -> Message -> Message
 142 mkErrorReply err msg
 143     = let header = msgHeader msg
 144           msg'   = msg {
 145                      msgHeader = header {
 146                                    hdMessageType           = Response
 147                                  , hdIsAuthoritativeAnswer = False
 148                                  , hdIsTruncated           = False
 149                                  , hdIsRecursionAvailable  = False
 150                                  , hdResponseCode          = err
 151                                  }
 152                    }
 153       in
 154         msg'