Many changes...

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

diff --git a/Network/DNS/Named/Responder.hs b/Network/DNS/Named/Responder.hs
new file mode 100644 (file)
index 0000000..5148f2b
--- /dev/null
+++ b/Network/DNS/Named/Responder.hs
@@ -0,0 +1,96 @@
+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 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 (RecordType qt dt, RecordClass 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
+    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 :: (RecordType qt dt, RecordClass 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 = liftM qName getQuestion
+
+respond :: ( SaneAnswerType qt at, SaneAnswerClass qc ac
+           , QueryType qt, RecordType at dt
+           , RecordClass 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 :: (RecordType qt dt, RecordClass qc) =>
+                 Responder qt qc a
+              -> SomeResponder
+wrapResponder m
+    = SomeResponder (m >> return ())
\ No newline at end of file