Started implementing Named part.

[haskell-dns.git] / Network / DNS / Named.hs

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
new file mode 100644 (file)
index 0000000..13297e8
--- /dev/null
+++ b/Network/DNS/Named.hs
@@ -0,0 +1,107 @@
+module Network.DNS.Named
+    ( ZoneFinder(..)
+    , Zone(..)
+
+    , runNamed
+
+    , defaultRootZone
+    )
+    where
+
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad
+import           Data.Binary
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Maybe
+import           Network.Socket
+import qualified Network.Socket.ByteString as NB
+import           Network.DNS.Message
+import           Network.DNS.Named.Config
+import           System.Posix.Signals
+
+
+class ZoneFinder a where
+    findZone :: a -> DomainName -> IO Zone
+
+instance ZoneFinder (DomainName -> Zone) where
+    findZone = (return .)
+
+instance ZoneFinder (DomainName -> IO Zone) where
+    findZone = id
+
+instance ZoneFinder (DomainName -> Maybe Zone) where
+    findZone = ((return . fromMaybe defaultRootZone) .)
+
+instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
+    findZone = (fmap (fromMaybe defaultRootZone) .)
+
+
+data Zone
+    = Zone {
+        zoneName :: !DomainName
+      }
+
+defaultRootZone :: Zone
+defaultRootZone = error "FIXME: defaultRootZone is not implemented yet"
+
+
+runNamed :: ZoneFinder zf => Config -> zf -> IO ()
+runNamed cnf zf
+    = withSocketsDo $
+      do installHandler sigPIPE Ignore Nothing
+         _tcpListenerTID <- forkIO $ tcpListen
+         udpListen
+    where
+      udpListen :: IO ()
+      udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
+                     so <- socket AF_INET Datagram defaultProtocol
+                     print cnf
+                     bindSocket so $ cnfServerAddress cnf
+                     udpLoop so
+
+      udpLoop :: Socket -> IO ()
+      udpLoop so
+          = do (packet, cameFrom) <- NB.recvFrom so 512
+               _handlerTID <- forkIO $ udpHandler so packet cameFrom
+               udpLoop so
+
+      tcpListen :: IO ()
+      tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
+
+      udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
+      udpHandler so packet cameFrom
+          = do msg   <- evaluate $ unpackMessage packet
+               msg'  <- handleMessage msg
+                        `onException`
+                        NB.sendTo so (packMessage $ makeServerFailure msg) cameFrom
+               _sent <- NB.sendTo so (packMessage $ msg'                 ) cameFrom
+               return ()
+
+      handleMessage :: Message -> IO Message
+      handleMessage msg
+          = fail (show msg) -- FIXME
+
+
+packMessage :: Message -> BS.ByteString
+packMessage = BS.concat . LBS.toChunks . encode
+
+unpackMessage :: BS.ByteString -> Message
+unpackMessage = decode . LBS.fromChunks . return
+
+
+makeServerFailure :: Message -> Message
+makeServerFailure msg
+    = let header = msgHeader msg
+          msg'   = msg {
+                     msgHeader = header {
+                                   hdMessageType           = Response
+                                 , hdIsAuthoritativeAnswer = False
+                                 , hdIsTruncated           = False
+                                 , hdIsRecursionAvailable  = False
+                                 , hdResponseCode          = ServerFailure
+                                 }
+                   }
+      in
+        msg'