From d24a461f09bd10e3fe148e3b6b86c8e861b09a43 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Mon, 25 May 2009 17:08:04 +0900
Subject: [PATCH] The server started somewhat working...

---
 ExampleDNSServer.hs            | 32 +++++++++++++++++++++++++++++++-
 Network/DNS/Message.hs         | 10 ++++++++++
 Network/DNS/Named.hs           |  4 +++-
 Network/DNS/Named/Responder.hs | 14 +++++++-------
 Network/DNS/Named/Zone.hs      | 16 ++++++++++++----
 5 files changed, 63 insertions(+), 13 deletions(-)

diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs
index e1aaa22..f590caa 100644
--- a/ExampleDNSServer.hs
+++ b/ExampleDNSServer.hs
@@ -1,8 +1,10 @@
 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 ()
 main = runNamed cnf zoneFor
@@ -13,4 +15,32 @@ main = runNamed cnf zoneFor
             }
 
       zoneFor :: DomainName -> Maybe Zone
-      zoneFor = const Nothing -- FIXME
\ No newline at end of file
+      zoneFor name
+          | name `isInZone` zone = Just zone
+          | otherwise            = Nothing
+
+      zone :: Zone
+      zone = Zone {
+               zoneName       = mkDN "cielonegro.org."
+             , zoneResponders = [ wrapResponder' $
+                                  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"
+                                ]
+             , zoneIsAuthoritative = True
+             }
+
+      wrapResponder' :: Responder A IN () -> SomeResponder
+      wrapResponder' = wrapResponder
+
+
+inetAddr :: String -> HostAddress
+inetAddr = unsafePerformIO . inet_addr
diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index fe595b4..9f2b144 100644
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -50,6 +50,9 @@ module Network.DNS.Message
     , HS(..)
 
     , mkDomainName
+    , mkDN
+    , isZoneOf
+
     , wrapQuestion
     , wrapRecord
     )
@@ -70,6 +73,7 @@ import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)
 import qualified Data.IntSet as IS
 import           Data.IntSet (IntSet)
+import           Data.List
 import qualified Data.Map as M
 import           Data.Map (Map)
 import           Data.Word
@@ -224,6 +228,9 @@ unconsLabel :: DomainName -> (DomainLabel, DomainName)
 unconsLabel (DN (x:xs)) = (x, DN xs)
 unconsLabel x           = error ("Illegal use of unconsLabel: " ++ show x)
 
+isZoneOf :: DomainName -> DomainName -> Bool
+isZoneOf (DN a) (DN b) = a `isSuffixOf` b
+
 mkDomainName :: String -> DomainName
 mkDomainName = DN . mkLabels [] . notEmpty
     where
@@ -237,6 +244,9 @@ mkDomainName = DN . mkLabels [] . notEmpty
                                 -> mkLabels (C8.pack l : soFar) rest
                             _   -> error ("Illegal domain name: " ++ xs)
 
+mkDN :: String -> DomainName
+mkDN = mkDomainName
+
 
 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
     rcToInt :: rc -> Int
diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs
index 57d9ea4..dbe8e71 100644
--- a/Network/DNS/Named.hs
+++ b/Network/DNS/Named.hs
@@ -72,7 +72,9 @@ runNamed cnf zf
                -- FIXME: this is merely a bogus implementation.
                -- It considers no additional or authoritative sections.
                results <- mapM (runResponder' q) (zoneResponders zone)
-               return $ mapM_ addAnswer $ concat results
+               return $ do mapM_ addAnswer $ concat results
+                           unless (zoneIsAuthoritative zone) $
+                                  unauthorise
 
 
 validateQuery :: Message -> ResponseCode
diff --git a/Network/DNS/Named/Responder.hs b/Network/DNS/Named/Responder.hs
index 5148f2b..b94b7ca 100644
--- a/Network/DNS/Named/Responder.hs
+++ b/Network/DNS/Named/Responder.hs
@@ -19,7 +19,7 @@ import Network.DNS.Message
 import Network.DNS.Named.Sanity
 
 
-data ResponderState qt qc
+data (QueryType qt, QueryClass qc) => ResponderState qt qc
     = ResponderState {
         rsQuestion :: !(Question qt qc)
       , rsAnswers  :: ![SomeRR]
@@ -31,13 +31,13 @@ newtype (QueryType qt, QueryClass qc) => Responder qt qc a
       }
     deriving Typeable
 
-instance (RecordType qt dt, RecordClass qc) => Monad (Responder qt qc) where
+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 (RecordType qt dt, RecordClass qc) => MonadIO (Responder qt qc) where
+instance (QueryType qt, QueryClass qc) => MonadIO (Responder qt qc) where
     liftIO m = Responder $ \ s -> do a <- m
                                      return (a, s)
 
@@ -66,16 +66,16 @@ runResponder' q (SomeResponder r)
         Just m
             -> runResponder q m
 
-getQuestion :: (RecordType qt dt, RecordClass qc) => Responder qt qc (Question qt qc)
+getQuestion :: (QueryType qt, QueryClass qc) => Responder qt qc (Question qt qc)
 getQuestion = Responder $ \ s ->
               return (rsQuestion s, s)
 
-getQueryName :: (RecordType qt dt, RecordClass qc) => Responder qt qc DomainName
+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
-           , RecordClass qc, RecordClass ac
+           , QueryClass qc, RecordClass ac
            ) =>
            ResourceRecord at ac dt
         -> Responder qt qc ()
@@ -89,7 +89,7 @@ respond rr
 data SomeResponder
     = forall qt qc. (Typeable qt, Typeable qc) => SomeResponder (Responder qt qc ())
 
-wrapResponder :: (RecordType qt dt, RecordClass qc) =>
+wrapResponder :: (QueryType qt, QueryClass qc) =>
                  Responder qt qc a
               -> SomeResponder
 wrapResponder m
diff --git a/Network/DNS/Named/Zone.hs b/Network/DNS/Named/Zone.hs
index 8311376..6cde400 100644
--- a/Network/DNS/Named/Zone.hs
+++ b/Network/DNS/Named/Zone.hs
@@ -2,6 +2,8 @@ module Network.DNS.Named.Zone
     ( Zone(..)
     , ZoneFinder(..)
 
+    , isInZone
+
     , defaultRootZone
     )
     where
@@ -13,8 +15,9 @@ import Network.DNS.Named.Responder
 
 data Zone
     = Zone {
-        zoneName       :: !DomainName
-      , zoneResponders :: ![SomeResponder]
+        zoneName            :: !DomainName
+      , zoneResponders      :: ![SomeResponder]
+      , zoneIsAuthoritative :: !Bool
       }
 
 class ZoneFinder a where
@@ -33,9 +36,14 @@ instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
     findZone = (fmap (fromMaybe defaultRootZone) .)
 
 
+isInZone :: DomainName -> Zone -> Bool
+isInZone name zone = zoneName zone `isZoneOf` name
+
+
 defaultRootZone :: Zone
 defaultRootZone
     = Zone {
-        zoneName       = mkDomainName "."
-      , zoneResponders = [] -- FIXME
+        zoneName            = mkDomainName "."
+      , zoneResponders      = [] -- FIXME
+      , zoneIsAuthoritative = False
       }
-- 
2.40.0