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.Zone
  19 import           System.Posix.Signals
  20
  21
  22 runNamed :: ZoneFinder zf => Config -> zf -> IO ()
  23 runNamed cnf zf
  24     = withSocketsDo $
  25       do installHandler sigPIPE Ignore Nothing
  26          _tcpListenerTID <- forkIO $ tcpListen
  27          udpListen
  28     where
  29       udpListen :: IO ()
  30       udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
  31                      so <- socket AF_INET Datagram defaultProtocol
  32                      print cnf
  33                      bindSocket so $ cnfServerAddress cnf
  34                      udpLoop so
  35
  36       udpLoop :: Socket -> IO ()
  37       udpLoop so
  38           = do (packet, cameFrom) <- NB.recvFrom so 512
  39                _handlerTID <- forkIO $ udpHandler so packet cameFrom
  40                udpLoop so
  41
  42       tcpListen :: IO ()
  43       tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
  44
  45       udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
  46       udpHandler so packet cameFrom
  47           = do msg   <- evaluate $ unpackMessage packet
  48                msg'  <- handleMessage msg
  49                         `onException`
  50                         do let servfail = mkErrorReply ServerFailure msg
  51                            NB.sendTo so (packMessage (Just 512) servfail) cameFrom
  52                _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom
  53                return ()
  54
  55       handleMessage :: Message -> IO Message
  56       handleMessage msg
  57           = case validateQuery msg of
  58               NoError
  59                   -> fail "FIXME: not impl" -- msgQuestions msg
  60               err -> return $ mkErrorReply err msg
  61
  62       handleQuestion :: SomeQ -> IO [SomeRR]
  63       handleQuestion (SomeQ q)
  64           = do zone       <- findZone zf (qName q)
  65                results    <- mapM (runResponder' q) (zoneResponders zone)
  66                return $ concat results
  67
  68
  69 validateQuery :: Message -> ResponseCode
  70 validateQuery = validateHeader . msgHeader
  71     where
  72       validateHeader :: Header -> ResponseCode
  73       validateHeader hdr
  74           | hdMessageType hdr /= Query         = NotImplemented
  75           | hdOpcode      hdr /= StandardQuery = NotImplemented
  76           | otherwise                          = NoError
  77
  78
  79 packMessage :: Maybe Int -> Message -> BS.ByteString
  80 packMessage limM = BS.concat . LBS.toChunks . truncateMsg
  81     where
  82       truncateMsg :: Message -> LBS.ByteString
  83       truncateMsg msg
  84           = let packet    = encode msg
  85                 needTrunc = fromMaybe False $
  86                             do lim <- limM
  87                                return $ fromIntegral (LBS.length packet) > lim
  88             in
  89               if needTrunc then
  90                   truncateMsg $ trunc' msg
  91               else
  92                   packet
  93
  94       trunc' :: Message -> Message
  95       trunc' msg
  96           | notNull $ msgAdditionals msg
  97               = msg {
  98                   msgAdditionals = truncList $ msgAdditionals msg
  99                 }
 100           | notNull $ msgAuthorities msg
 101               = msg {
 102                   msgHeader      = setTruncFlag $ msgHeader msg
 103                 , msgAuthorities = truncList $ msgAuthorities msg
 104                 }
 105           | notNull $ msgAnswers msg
 106               = msg {
 107                   msgHeader      = setTruncFlag $ msgHeader msg
 108                 , msgAnswers     = truncList $ msgAnswers msg
 109                 }
 110           | notNull $ msgQuestions msg
 111               = msg {
 112                   msgHeader      = setTruncFlag $ msgHeader msg
 113                 , msgQuestions   = truncList $ msgQuestions msg
 114                 }
 115           | otherwise
 116               = error ("packMessage: You are already skinny and need no diet: " ++ show msg)
 117
 118       setTruncFlag :: Header -> Header
 119       setTruncFlag hdr = hdr { hdIsTruncated = True }
 120
 121       notNull :: [a] -> Bool
 122       notNull = not . null
 123
 124       truncList :: [a] -> [a]
 125       truncList xs = take (length xs - 1) xs
 126
 127 unpackMessage :: BS.ByteString -> Message
 128 unpackMessage = decode . LBS.fromChunks . return
 129
 130 mkErrorReply :: ResponseCode -> Message -> Message
 131 mkErrorReply err msg
 132     = let header = msgHeader msg
 133           msg'   = msg {
 134                      msgHeader = header {
 135                                    hdMessageType           = Response
 136                                  , hdIsAuthoritativeAnswer = False
 137                                  , hdIsTruncated           = False
 138                                  , hdIsRecursionAvailable  = False
 139                                  , hdResponseCode          = err
 140                                  }
 141                    }
 142       in
 143         msg'