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 $ mapM_ addAnswer $ concat results
  76
  77
  78 validateQuery :: Message -> ResponseCode
  79 validateQuery = validateHeader . msgHeader
  80     where
  81       validateHeader :: Header -> ResponseCode
  82       validateHeader hdr
  83           | hdMessageType hdr /= Query         = NotImplemented
  84           | hdOpcode      hdr /= StandardQuery = NotImplemented
  85           | otherwise                          = NoError
  86
  87
  88 packMessage :: Maybe Int -> Message -> BS.ByteString
  89 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
  90     where
  91       truncateMsg :: Message -> LBS.ByteString
  92       truncateMsg msg
  93           = let packet    = encode msg
  94                 needTrunc = fromMaybe False $
  95                             do lim <- limM
  96                                return $ fromIntegral (LBS.length packet) > lim
  97             in
  98               if needTrunc then
  99                   truncateMsg $ trunc' msg
 100               else
 101                   packet
 102
 103       trunc' :: Message -> Message
 104       trunc' msg
 105           | notNull $ msgAdditionals msg
 106               = msg {
 107                   msgAdditionals = truncList $ msgAdditionals msg
 108                 }
 109           | notNull $ msgAuthorities msg
 110               = msg {
 111                   msgHeader      = setTruncFlag $ msgHeader msg
 112                 , msgAuthorities = truncList $ msgAuthorities msg
 113                 }
 114           | notNull $ msgAnswers msg
 115               = msg {
 116                   msgHeader      = setTruncFlag $ msgHeader msg
 117                 , msgAnswers     = truncList $ msgAnswers msg
 118                 }
 119           | notNull $ msgQuestions msg
 120               = msg {
 121                   msgHeader      = setTruncFlag $ msgHeader msg
 122                 , msgQuestions   = truncList $ msgQuestions msg
 123                 }
 124           | otherwise
 125               = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
 126
 127       setTruncFlag :: Header -> Header
 128       setTruncFlag hdr = hdr { hdIsTruncated = True }
 129
 130       notNull :: [a] -> Bool
 131       notNull = not . null
 132
 133       truncList :: [a] -> [a]
 134       truncList xs = take (length xs - 1) xs
 135
 136 unpackMessage :: BS.ByteString -> Message
 137 unpackMessage = decode . LBS.fromChunks . return
 138
 139 mkErrorReply :: ResponseCode -> Message -> Message
 140 mkErrorReply err msg
 141     = let header = msgHeader msg
 142           msg'   = msg {
 143                      msgHeader = header {
 144                                    hdMessageType           = Response
 145                                  , hdIsAuthoritativeAnswer = False
 146                                  , hdIsTruncated           = False
 147                                  , hdIsRecursionAvailable  = False
 148                                  , hdResponseCode          = err
 149                                  }
 150                    }
 151       in
 152         msg'