1 module Network.DNS.Named.Responder
16 import Control.Monad.Trans
18 import Network.DNS.Message
19 import Network.DNS.Named.Sanity
22 data (QueryType qt, QueryClass qc) => ResponderState qt qc
24 rsQuestion :: !(Question qt qc)
25 , rsAnswers :: ![SomeRR]
28 newtype (QueryType qt, QueryClass qc) => Responder qt qc a
30 unR :: ResponderState qt qc -> IO (a, ResponderState qt qc)
34 instance (QueryType qt, QueryClass qc) => Monad (Responder qt qc) where
35 return a = Responder $ \ s -> return (a, s)
36 m >>= k = Responder $ \ s -> do (a, s') <- unR m s
38 fail err = Responder $ \ _ -> fail err
40 instance (QueryType qt, QueryClass qc) => MonadIO (Responder qt qc) where
41 liftIO m = Responder $ \ s -> do a <- m
45 runResponder :: (QueryType qt, QueryClass qc) =>
50 = do let s = ResponderState {
57 runResponder' :: forall qt qc.
58 (QueryType qt, QueryClass qc) =>
62 runResponder' q (SomeResponder r)
63 = case cast r :: Maybe (Responder qt qc ()) of
69 getQuestion :: (QueryType qt, QueryClass qc) => Responder qt qc (Question qt qc)
70 getQuestion = Responder $ \ s ->
71 return (rsQuestion s, s)
73 getQueryName :: (QueryType qt, QueryClass qc) => Responder qt qc DomainName
74 getQueryName = liftM qName getQuestion
76 respond :: ( SaneAnswerType qt at, SaneAnswerClass qc ac
77 , QueryType qt, RecordType at dt
78 , QueryClass qc, RecordClass ac
80 ResourceRecord at ac dt
85 rsAnswers = rsAnswers s ++ [wrapRecord rr]
90 = forall qt qc. (Typeable qt, Typeable qc) => SomeResponder (Responder qt qc ())
92 wrapResponder :: (QueryType qt, QueryClass qc) =>
96 = SomeResponder (m >> return ())