Farewell to the Sanity.hs

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

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