Started implementing Named part.

diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs
new file mode 100644 (file)
index 0000000..9e1b4cd
--- /dev/null
+++ b/ExampleDNSServer.hs
@@ -0,0 +1,15 @@
+import           Network.DNS.Message
+import           Network.DNS.Named
+import           Network.DNS.Named.Config
+import           Network.Socket
+
+main :: IO ()
+main = runNamed cnf zoneFor
+    where
+      cnf :: Config
+      cnf = Config {
+              cnfServerAddress = SockAddrInet 9090 iNADDR_ANY
+            }
+
+      zoneFor :: DomainName -> Maybe Zone
+      zoneFor = const Nothing -- FIXME
\ No newline at end of file

diff --git a/Makefile b/Makefile
index c12ffabc181494581f81824a4e00102211104de8..d072fa34f266e08c7d79b37384a18aba11b0560b 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -4,12 +4,12 @@ GHC = ghc
 build: dist/setup-config Setup
        ./Setup build
 
-#run: build
-#      @echo ".:.:. Let's go .:.:."
-#      $(MAKE) -C examples run
+run: build
+       @echo ".:.:. Let's go .:.:."
+       ./dist/build/ExampleDNSServer/ExampleDNSServer
 
 dist/setup-config: $(CABAL_FILE) Setup
-       ./Setup configure --disable-optimization -fbuild-test-suite
+       ./Setup configure --disable-optimization -fbuild-test-suite -fbuild-examples
 
 Setup: Setup.lhs
        $(GHC) --make Setup

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'

diff --git a/Network/DNS/Named/Config.hs b/Network/DNS/Named/Config.hs
new file mode 100644 (file)
index 0000000..ba9ad72
--- /dev/null
+++ b/Network/DNS/Named/Config.hs
@@ -0,0 +1,19 @@
+module Network.DNS.Named.Config
+    ( Config(..)
+    , defaultConfig
+    )
+    where
+
+import           Network.Socket
+
+
+data Config
+    = Config {
+        cnfServerAddress :: !SockAddr
+      }
+    deriving Show
+
+defaultConfig :: Config
+defaultConfig = Config {
+                  cnfServerAddress = SockAddrInet 42 iNADDR_ANY
+                }

diff --git a/Network/DNS/Server.hs b/Network/DNS/Server.hs
deleted file mode 100644 (file)
index 10c9ca5..0000000
--- a/Network/DNS/Server.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Network.DNS.Server
-    (
-    )
-    where

diff --git a/dns.cabal b/dns.cabal
index 6792870be99817a16839e16e19449f6d16a9aca9..4378fd291ad49437e4875b7798eecda145e8a1f5 100644 (file)
--- a/dns.cabal
+++ b/dns.cabal
@@ -10,20 +10,27 @@ Stability:           Experimental
 Cabal-Version:       >= 1.2
 Build-Type:          Simple
 Extra-Source-Files:
+    ExampleDNSServer.hs
     DNSUnitTest.hs
 
+Flag build-examples
+    Description: Build example executables.
+    Default:     False
+
 Flag build-test-suite
     Description: Build the test suite.
     Default:     False
 
 Library
     Build-Depends:
-        base, binary, binary-strict, bytestring, containers, network
+        base, binary, binary-strict, bytestring, containers, network,
+        network-bytestring, unix
 
     Exposed-Modules:
         Network.DNS.Message
+        Network.DNS.Named
+        Network.DNS.Named.Config
         Network.DNS.Packer
-        Network.DNS.Server
         Network.DNS.Unpacker
 
     Extensions:
@@ -57,3 +64,22 @@ Executable DNSUnitTest
 
     GHC-Options:
         -Wall
+
+Executable ExampleDNSServer
+    if flag(build-examples)
+        Buildable: True
+    else
+        Buildable: False
+
+    Main-Is:
+        ExampleDNSServer.hs
+
+    Extensions:
+        DeriveDataTypeable, ExistentialQuantification,
+        FlexibleInstances, FunctionalDependencies,
+        MultiParamTypeClasses, ScopedTypeVariables,
+        TypeSynonymInstances, UndecidableInstances,
+        IncoherentInstances
+
+    GHC-Options:
+        -Wall
\ No newline at end of file