Network/DNS/Named.hs

   1 module Network.DNS.Named
   2     ( ZoneFinder(..)
   3     , Zone(..)
   4
   5     , runNamed
   6
   7     , defaultRootZone
   8     )
   9     where
  10
  11 import           Control.Concurrent
  12 import           Control.Exception
  13 import           Control.Monad
  14 import           Data.Binary
  15 import qualified Data.ByteString as BS
  16 import qualified Data.ByteString.Lazy as LBS
  17 import           Data.Maybe
  18 import           Network.Socket
  19 import qualified Network.Socket.ByteString as NB
  20 import           Network.DNS.Message
  21 import           Network.DNS.Named.Config
  22 import           System.Posix.Signals
  23
  24
  25 class ZoneFinder a where
  26     findZone :: a -> DomainName -> IO Zone
  27
  28 instance ZoneFinder (DomainName -> Zone) where
  29     findZone = (return .)
  30
  31 instance ZoneFinder (DomainName -> IO Zone) where
  32     findZone = id
  33
  34 instance ZoneFinder (DomainName -> Maybe Zone) where
  35     findZone = ((return . fromMaybe defaultRootZone) .)
  36
  37 instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
  38     findZone = (fmap (fromMaybe defaultRootZone) .)
  39
  40
  41 data Zone
  42     = Zone {
  43         zoneName :: !DomainName
  44       }
  45
  46 defaultRootZone :: Zone
  47 defaultRootZone = error "FIXME: defaultRootZone is not implemented yet"
  48
  49
  50 runNamed :: ZoneFinder zf => Config -> zf -> IO ()
  51 runNamed cnf zf
  52     = withSocketsDo $
  53       do installHandler sigPIPE Ignore Nothing
  54          _tcpListenerTID <- forkIO $ tcpListen
  55          udpListen
  56     where
  57       udpListen :: IO ()
  58       udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
  59                      so <- socket AF_INET Datagram defaultProtocol
  60                      print cnf
  61                      bindSocket so $ cnfServerAddress cnf
  62                      udpLoop so
  63
  64       udpLoop :: Socket -> IO ()
  65       udpLoop so
  66           = do (packet, cameFrom) <- NB.recvFrom so 512
  67                _handlerTID <- forkIO $ udpHandler so packet cameFrom
  68                udpLoop so
  69
  70       tcpListen :: IO ()
  71       tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
  72
  73       udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
  74       udpHandler so packet cameFrom
  75           = do msg   <- evaluate $ unpackMessage packet
  76                msg'  <- handleMessage msg
  77                         `onException`
  78                         NB.sendTo so (packMessage $ makeServerFailure msg) cameFrom
  79                _sent <- NB.sendTo so (packMessage $ msg'                 ) cameFrom
  80                return ()
  81
  82       handleMessage :: Message -> IO Message
  83       handleMessage msg
  84           = fail (show msg) -- FIXME
  85
  86
  87 packMessage :: Message -> BS.ByteString
  88 packMessage = BS.concat . LBS.toChunks . encode
  89
  90 unpackMessage :: BS.ByteString -> Message
  91 unpackMessage = decode . LBS.fromChunks . return
  92
  93
  94 makeServerFailure :: Message -> Message
  95 makeServerFailure msg
  96     = let header = msgHeader msg
  97           msg'   = msg {
  98                      msgHeader = header {
  99                                    hdMessageType           = Response
 100                                  , hdIsAuthoritativeAnswer = False
 101                                  , hdIsTruncated           = False
 102                                  , hdIsRecursionAvailable  = False
 103                                  , hdResponseCode          = ServerFailure
 104                                  }
 105                    }
 106       in
 107         msg'