Farewell to the Sanity.hs

diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs
index b366e14e1a9dc5d5b07b2ee57ced84ead301e358..8c9919535dfd901cd67a81062ef7e9830debc836 100644 (file)
--- a/ExampleDNSServer.hs
+++ b/ExampleDNSServer.hs
@@ -1,44 +1,74 @@
 import           Network.DNS.Message
 import           Network.DNS.Named
 import           Network.DNS.Named.Config
 import           Network.DNS.Message
 import           Network.DNS.Named
 import           Network.DNS.Named.Config

-import           Network.DNS.Named.Responder

 import           Network.DNS.Named.Zone
 import           Network.Socket
 import           System.IO.Unsafe
 
 main :: IO ()
 import           Network.DNS.Named.Zone
 import           Network.Socket
 import           System.IO.Unsafe
 
 main :: IO ()

-main = runNamed cnf zoneFor
+main = runNamed cnf (return . findZone)

     where
       cnf :: Config
       cnf = Config {
               cnfServerAddress = SockAddrInet 9090 iNADDR_ANY
             }
 
     where
       cnf :: Config
       cnf = Config {
               cnfServerAddress = SockAddrInet 9090 iNADDR_ANY
             }
 

-      zoneFor :: DomainName -> Maybe Zone
-      zoneFor name
+      findZone :: DomainName -> Maybe Zone
+      findZone name

           | name `isInZone` zone = Just zone
           | otherwise            = Nothing
 
       zone :: Zone
       zone = Zone {
           | name `isInZone` zone = Just zone
           | otherwise            = Nothing
 
       zone :: Zone
       zone = Zone {

-               zoneName            = mkDN "cielonegro.org."
-             , zoneResponders      = [ wrapResponder responderA
-                                     ]
-             , zoneIsAuthoritative = True
+               zoneName = mkDN "cielonegro.org."
+             , zoneSOA  = Just SOAFields {
+                            soaMasterNameServer   = mkDN "ns.cielonegro.org."
+                          , soaResponsibleMailbox = mkDN "root.ns.cielonegro.org."
+                          , soaSerialNumber       = 2008022148
+                          , soaRefreshInterval    = 3600
+                          , soaRetryInterval      = 900
+                          , soaExpirationLimit    = 3600000
+                          , soaMinimumTTL         = 3600
+                          }
+             , zoneRecordNames = return [ mkDN "cielonegro.org."
+                                        , mkDN "ns.cielonegro.org."
+                                        , mkDN "www.cielonegro.org."
+                                        , mkDN "git.cielonegro.org."
+                                        ]
+             , zoneResponder   = return . responder

              }
 
              }
 

-      responderA :: Responder A IN ()
-      responderA = do name <- getQueryName
-                      if name == mkDN "ns.cielonegro.org." then
-                          respond ResourceRecord {
-                                        rrName  = name
-                                      , rrType  = A
-                                      , rrClass = IN
-                                      , rrTTL   = 9600
-                                      , rrData  = inetAddr "127.0.0.1"
-                                      }
-                        else
-                          fail "FIXME: we want to throw NameError but we can't for now"
+      responder :: DomainName -> [SomeRR]
+      responder name
+          | name == mkDN "ns.cielonegro.org."
+              = [ wrapRecord ResourceRecord {
+                                   rrName  = name
+                                 , rrType  = A
+                                 , rrClass = IN
+                                 , rrTTL   = 9600
+                                 , rrData  = inetAddr "127.0.0.1"
+                                 }
+                ]
+          | name == mkDN "www.cielonegro.org."
+              = [ wrapRecord ResourceRecord {
+                                   rrName  = name
+                                 , rrType  = A
+                                 , rrClass = IN
+                                 , rrTTL   = 9600
+                                 , rrData  = inetAddr "127.0.0.2"
+                                 }
+                ]
+          | name == mkDN "git.cielonegro.org."
+              = [ wrapRecord ResourceRecord {
+                                   rrName  = name
+                                 , rrType  = CNAME
+                                 , rrClass = IN
+                                 , rrTTL   = 9600
+                                 , rrData  = mkDN "www.cielonegro.org."
+                                 }
+                ]
+          | otherwise
+              = [] -- This means NXDOMAIN.

 
 
 inetAddr :: String -> HostAddress
 
 
 inetAddr :: String -> HostAddress

diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index dbe8e71c2865f135ac93d41d2439e3f4bf16d0e5..1eaf27af89975b0d4df987c8aed4c3180607235a 100644 (file)
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -9,19 +9,19 @@ import           Control.Monad
 import           Data.Binary
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import           Data.Binary
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS

+import           Data.Dynamic

 import           Data.Maybe
 import           Network.Socket
 import qualified Network.Socket.ByteString as NB
 import           Network.DNS.Message
 import           Network.DNS.Named.Config
 import           Data.Maybe
 import           Network.Socket
 import qualified Network.Socket.ByteString as NB
 import           Network.DNS.Message
 import           Network.DNS.Named.Config

-import           Network.DNS.Named.Responder

 import           Network.DNS.Named.ResponseBuilder
 import           Network.DNS.Named.Zone
 import           System.Posix.Signals
 
 
 import           Network.DNS.Named.ResponseBuilder
 import           Network.DNS.Named.Zone
 import           System.Posix.Signals
 
 

-runNamed :: ZoneFinder zf => Config -> zf -> IO ()
-runNamed cnf zf
+runNamed :: Config -> (DomainName -> IO (Maybe Zone)) -> IO ()
+runNamed cnf findZone

     = withSocketsDo $
       do installHandler sigPIPE Ignore Nothing
          _tcpListenerTID <- forkIO $ tcpListen
     = withSocketsDo $
       do installHandler sigPIPE Ignore Nothing
          _tcpListenerTID <- forkIO $ tcpListen


@@ -68,13 +68,86 @@ runNamed cnf zf
 
       handleQuestion :: SomeQ -> IO (Builder ())
       handleQuestion (SomeQ q)
 
       handleQuestion :: SomeQ -> IO (Builder ())
       handleQuestion (SomeQ q)

-          = do zone    <- findZone zf (qName q)
-               -- FIXME: this is merely a bogus implementation.
-               -- It considers no additional or authoritative sections.
-               results <- mapM (runResponder' q) (zoneResponders zone)
-               return $ do mapM_ addAnswer $ concat results
-                           unless (zoneIsAuthoritative zone) $
-                                  unauthorise
+          = do zoneM <- findZone (qName q)
+               case zoneM of
+                 Nothing
+                     -> return $ do unauthorise
+                                    setResponseCode Refused
+                 Just zone
+                     -> handleQuestionForZone (SomeQ q) zone
+
+      handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ())
+      handleQuestionForZone (SomeQ q) zone
+          | Just (qType q) == cast AXFR
+              = handleAXFR (SomeQ q) zone
+          | otherwise
+              = do allRecords <- zoneResponder zone (qName q)
+                   let filtered = filterRecords (SomeQ q) allRecords
+
+                   additionals <- do xss <- mapM (getAdditionals zone) filtered
+                                     ys  <- case zoneNSRecord zone of
+                                              Just rr -> getAdditionals zone rr
+                                              Nothing -> return []
+                                     return (concat xss ++ ys)
+
+                   return $ do mapM_ addAnswer filtered
+
+                               when (qName q == zoneName zone) $
+                                    do when (Just (qType q) == cast SOA ||
+                                             Just (qType q) == cast ANY   )
+                                                $ case zoneSOARecord zone of
+                                                    Just rr -> addAnswer rr
+                                                    Nothing -> return ()
+
+                                       when (Just (qType q) == cast NS ||
+                                             Just (qType q) == cast ANY  )
+                                                $ case zoneNSRecord zone of
+                                                    Just rr -> addAnswer rr
+                                                    Nothing -> return ()
+
+                               mapM_ addAdditional additionals
+
+                               case zoneNSRecord zone of
+                                 Just rr -> addAuthority rr
+                                 Nothing -> unauthorise
+
+      getAdditionals :: Zone -> SomeRR -> IO [SomeRR]
+      getAdditionals zone (SomeRR rr)
+          = case cast (rrData rr) :: Maybe DomainName of
+              Nothing
+                  -> return []
+              Just name
+                  -> do allRecords <- zoneResponder zone name
+
+                        let filtered = filterRecords (SomeQ q') allRecords
+                            q'       = Question {
+                                         qName  = name
+                                       , qType  = A
+                                       , qClass = IN
+                                       }
+                        return filtered
+
+      filterRecords :: SomeQ -> [SomeRR] -> [SomeRR]
+      filterRecords (SomeQ q)
+          | Just (qType  q) == cast ANY &&
+            Just (qClass q) == cast ANY    = id
+          | Just (qType  q) == cast ANY    = filter matchClass
+          | Just (qClass q) == cast ANY    = filter matchType
+          | otherwise                      = filter matchBoth
+          where
+            matchClass (SomeRR rr)
+                = Just (qClass q) == cast (rrClass rr)
+
+            matchType (SomeRR rr)
+                = Just (qType  q) == cast (rrType  rr) ||
+                  Just CNAME      == cast (rrType  rr)
+
+            matchBoth rr
+                = matchType rr && matchClass rr
+
+      handleAXFR :: SomeQ -> Zone -> IO (Builder ())
+      handleAXFR (SomeQ _q) _zone
+          = fail "FIXME: not implemented yet"

 
 
 validateQuery :: Message -> ResponseCode
 
 
 validateQuery :: Message -> ResponseCode


@@ -140,15 +213,5 @@ unpackMessage = decode . LBS.fromChunks . return
 
 mkErrorReply :: ResponseCode -> Message -> Message
 mkErrorReply err msg
 
 mkErrorReply :: ResponseCode -> Message -> Message
 mkErrorReply err msg

-    = let header = msgHeader msg
-          msg'   = msg {
-                     msgHeader = header {
-                                   hdMessageType           = Response
-                                 , hdIsAuthoritativeAnswer = False
-                                 , hdIsTruncated           = False
-                                 , hdIsRecursionAvailable  = False
-                                 , hdResponseCode          = err
-                                 }
-                   }
-      in
-        msg'
+    = runBuilder msg $ do unauthorise
+                          setResponseCode err

diff --git a/Network/DNS/Named/Responder.hs b/Network/DNS/Named/Responder.hs
deleted file mode 100644 (file)
index b94b7ca..0000000
--- a/Network/DNS/Named/Responder.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-module Network.DNS.Named.Responder
-    ( Responder
-    , SomeResponder
-
-    , runResponder
-    , runResponder'
-    , wrapResponder
-
-    , getQuestion
-    , getQueryName
-    , respond
-    )
-    where
-
-import Control.Monad
-import Control.Monad.Trans
-import Data.Typeable
-import Network.DNS.Message
-import Network.DNS.Named.Sanity
-
-
-data (QueryType qt, QueryClass qc) => ResponderState qt qc
-    = ResponderState {
-        rsQuestion :: !(Question qt qc)
-      , rsAnswers  :: ![SomeRR]
-      }
-
-newtype (QueryType qt, QueryClass qc) => Responder qt qc a
-    = Responder {
-        unR :: ResponderState qt qc -> IO (a, ResponderState qt qc)
-      }
-    deriving Typeable
-
-instance (QueryType qt, QueryClass qc) => Monad (Responder qt qc) where
-    return a = Responder $ \ s -> return (a, s)
-    m >>= k  = Responder $ \ s -> do (a, s') <- unR m s
-                                     unR (k a) s'
-    fail err = Responder $ \ _ -> fail err
-
-instance (QueryType qt, QueryClass qc) => MonadIO (Responder qt qc) where
-    liftIO m = Responder $ \ s -> do a <- m
-                                     return (a, s)
-
-
-runResponder :: (QueryType qt, QueryClass qc) =>
-                Question qt qc
-             -> Responder qt qc ()
-             -> IO [SomeRR]
-runResponder q m
-    = do let s = ResponderState {
-                   rsQuestion = q
-                 , rsAnswers  = []
-                 }
-         (_, s') <- unR m s
-         return $ rsAnswers s'
-
-runResponder' :: forall qt qc.
-                 (QueryType qt, QueryClass qc) =>
-                 Question qt qc
-              -> SomeResponder
-              -> IO [SomeRR]
-runResponder' q (SomeResponder r)
-    = case cast r :: Maybe (Responder qt qc ()) of
-        Nothing
-            -> return []
-        Just m
-            -> runResponder q m
-
-getQuestion :: (QueryType qt, QueryClass qc) => Responder qt qc (Question qt qc)
-getQuestion = Responder $ \ s ->
-              return (rsQuestion s, s)
-
-getQueryName :: (QueryType qt, QueryClass qc) => Responder qt qc DomainName
-getQueryName = liftM qName getQuestion
-
-respond :: ( SaneAnswerType qt at, SaneAnswerClass qc ac
-           , QueryType qt, RecordType at dt
-           , QueryClass qc, RecordClass ac
-           ) =>
-           ResourceRecord at ac dt
-        -> Responder qt qc ()
-respond rr
-    = Responder $ \ s ->
-      do let s' = s {
-                    rsAnswers = rsAnswers s ++ [wrapRecord rr]
-                  }
-         return ((), s')
-
-data SomeResponder
-    = forall qt qc. (Typeable qt, Typeable qc) => SomeResponder (Responder qt qc ())
-
-wrapResponder :: (QueryType qt, QueryClass qc) =>
-                 Responder qt qc a
-              -> SomeResponder
-wrapResponder m
-    = SomeResponder (m >> return ())
\ No newline at end of file

diff --git a/Network/DNS/Named/ResponseBuilder.hs b/Network/DNS/Named/ResponseBuilder.hs
index 487a6786bd7240c9c933e8e1dcc309366f4b9781..4f08c401f2d6ea1b0627eae1eedadab5b013e7c1 100644 (file)
--- a/Network/DNS/Named/ResponseBuilder.hs
+++ b/Network/DNS/Named/ResponseBuilder.hs
@@ -4,6 +4,7 @@ module Network.DNS.Named.ResponseBuilder
     , runBuilder
 
     , unauthorise
     , runBuilder
 
     , unauthorise

+    , setResponseCode

     , addAnswer
     , addAuthority
     , addAdditional
     , addAnswer
     , addAuthority
     , addAdditional


@@ -39,7 +40,14 @@ runBuilder query builder
                                 , hdIsRecursionAvailable  = False
                                 , hdResponseCode          = NoError
                                 }
                                 , hdIsRecursionAvailable  = False
                                 , hdResponseCode          = NoError
                                 }

-          (_, result)  = unB (modHeader' >> builder) initialReply
+          setNameError = do aa   <- get (hdIsRecursionAvailable . msgHeader)
+                            rc   <- get (hdResponseCode . msgHeader)
+                            anss <- get msgAnswers
+
+                            when (aa && rc == NoError && null anss)
+                                $ setResponseCode NameError
+
+          (_, result)  = unB (modHeader' >> builder >> setNameError) initialReply

       in
         result
 
       in
         result
 


@@ -79,3 +87,7 @@ addAdditional rr
 
 unauthorise :: Builder ()
 unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })
 
 unauthorise :: Builder ()
 unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })

+
+setResponseCode :: ResponseCode -> Builder ()
+setResponseCode code
+    = modifyHeader (\ h -> h { hdResponseCode = code })

diff --git a/Network/DNS/Named/Sanity.hs b/Network/DNS/Named/Sanity.hs
deleted file mode 100644 (file)
index 8d5c793..0000000
--- a/Network/DNS/Named/Sanity.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Network.DNS.Named.Sanity
-    ( SaneAnswerType
-    , SaneAnswerClass
-    )
-    where
-
-import Network.DNS.Message
-
-
-class SaneAnswerType q ans
-instance (RecordType q dt) => SaneAnswerType q q
-instance (RecordType q dt) => SaneAnswerType q CNAME
-instance (RecordType ans dt) => SaneAnswerType ANY ans
-instance (RecordType ans dt) => SaneAnswerType AXFR ans
-instance SaneAnswerType MAILB MR
-instance SaneAnswerType MAILB MB
-instance SaneAnswerType MAILB MG
-instance SaneAnswerType MAILB MINFO
-
-
-class SaneAnswerClass q ans
-instance RecordClass q => SaneAnswerClass q q
-instance RecordClass ans => SaneAnswerClass ANY ans

diff --git a/Network/DNS/Named/Zone.hs b/Network/DNS/Named/Zone.hs
index 6cde400e8f5ce6fdbe49e6575d03468e456f0776..c02ff4b78ec7a4b47f8a048a84e7ac655c26806e 100644 (file)
--- a/Network/DNS/Named/Zone.hs
+++ b/Network/DNS/Named/Zone.hs
@@ -1,49 +1,47 @@
 module Network.DNS.Named.Zone
     ( Zone(..)
 module Network.DNS.Named.Zone
     ( Zone(..)

-    , ZoneFinder(..)
-

     , isInZone
 
     , isInZone
 

-    , defaultRootZone
+    , zoneSOARecord
+    , zoneNSRecord

     )
     where
 
 import Data.Maybe
 import Network.DNS.Message
     )
     where
 
 import Data.Maybe
 import Network.DNS.Message

-import Network.DNS.Named.Responder

 
 
 data Zone
     = Zone {
 
 
 data Zone
     = Zone {

-        zoneName            :: !DomainName
-      , zoneResponders      :: ![SomeResponder]
-      , zoneIsAuthoritative :: !Bool
+        zoneName        :: !DomainName
+      , zoneSOA         :: !(Maybe SOAFields)
+      , zoneRecordNames :: !(IO [DomainName])
+      , zoneResponder   :: !(DomainName -> IO [SomeRR])

       }
 
       }
 

-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) .)
-
-

 isInZone :: DomainName -> Zone -> Bool
 isInZone name zone = zoneName zone `isZoneOf` name
 
 isInZone :: DomainName -> Zone -> Bool
 isInZone name zone = zoneName zone `isZoneOf` name
 

-
-defaultRootZone :: Zone
-defaultRootZone
-    = Zone {
-        zoneName            = mkDomainName "."
-      , zoneResponders      = [] -- FIXME
-      , zoneIsAuthoritative = False
-      }
+zoneSOARecord :: Zone -> Maybe SomeRR
+zoneSOARecord zone
+    = do soa <- zoneSOA zone
+         return $ wrapRecord
+                $ ResourceRecord {
+                        rrName  = zoneName zone
+                      , rrType  = SOA
+                      , rrClass = IN
+                      , rrTTL   = soaMinimumTTL soa
+                      , rrData  = soa
+                      }
+
+zoneNSRecord :: Zone -> Maybe SomeRR
+zoneNSRecord zone
+    = do soa <- zoneSOA zone
+         return $ wrapRecord
+                $ ResourceRecord {
+                        rrName  = zoneName zone
+                      , rrType  = NS
+                      , rrClass = IN
+                      , rrTTL   = soaMinimumTTL soa
+                      , rrData  = soaMasterNameServer soa
+                      }

diff --git a/dns.cabal b/dns.cabal
index 7fc84fcde8036f558abf58edaede4886aa566782..d6c194a8f66c78cec040e1108dccdc289805465c 100644 (file)
--- a/dns.cabal
+++ b/dns.cabal
@@ -30,9 +30,7 @@ Library
         Network.DNS.Message
         Network.DNS.Named
         Network.DNS.Named.Config
         Network.DNS.Message
         Network.DNS.Named
         Network.DNS.Named.Config

-        Network.DNS.Named.Responder

         Network.DNS.Named.ResponseBuilder
         Network.DNS.Named.ResponseBuilder

-        Network.DNS.Named.Sanity

         Network.DNS.Named.Zone
         Network.DNS.Packer
         Network.DNS.Unpacker
         Network.DNS.Named.Zone
         Network.DNS.Packer
         Network.DNS.Unpacker