From: PHO Date: Sat, 23 May 2009 08:46:15 +0000 (+0900) Subject: Started implementing Named part. X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=5d250da422c01c7aab948ebdda5ef618f18e0f39;p=haskell-dns.git Started implementing Named part. --- diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs new file mode 100644 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 c12ffab..d072fa3 100644 --- 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 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 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 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 6792870..4378fd2 100644 --- 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