Network/DNS/Named/Responder.hs

   1 module Network.DNS.Named.Responder
   2     ( Responder
   3     , SomeResponder
   4
   5     , runResponder
   6     , runResponder'
   7     , wrapResponder
   8
   9     , getQuestion
  10     , getQueryName
  11     , respond
  12     )
  13     where
  14
  15 import Control.Monad
  16 import Control.Monad.Trans
  17 import Data.Typeable
  18 import Network.DNS.Message
  19 import Network.DNS.Named.Sanity
  20
  21
  22 data ResponderState qt qc
  23     = ResponderState {
  24         rsQuestion :: !(Question qt qc)
  25       , rsAnswers  :: ![SomeRR]
  26       }
  27
  28 newtype (QueryType qt, QueryClass qc) => Responder qt qc a
  29     = Responder {
  30         unR :: ResponderState qt qc -> IO (a, ResponderState qt qc)
  31       }
  32     deriving Typeable
  33
  34 instance (RecordType qt dt, RecordClass 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
  37                                      unR (k a) s'
  38     fail err = Responder $ \ _ -> fail err
  39
  40 instance (RecordType qt dt, RecordClass qc) => MonadIO (Responder qt qc) where
  41     liftIO m = Responder $ \ s -> do a <- m
  42                                      return (a, s)
  43
  44
  45 runResponder :: (QueryType qt, QueryClass qc) =>
  46                 Question qt qc
  47              -> Responder qt qc ()
  48              -> IO [SomeRR]
  49 runResponder q m
  50     = do let s = ResponderState {
  51                    rsQuestion = q
  52                  , rsAnswers  = []
  53                  }
  54          (_, s') <- unR m s
  55          return $ rsAnswers s'
  56
  57 runResponder' :: forall qt qc.
  58                  (QueryType qt, QueryClass qc) =>
  59                  Question qt qc
  60               -> SomeResponder
  61               -> IO [SomeRR]
  62 runResponder' q (SomeResponder r)
  63     = case cast r :: Maybe (Responder qt qc ()) of
  64         Nothing
  65             -> return []
  66         Just m
  67             -> runResponder q m
  68
  69 getQuestion :: (RecordType qt dt, RecordClass qc) => Responder qt qc (Question qt qc)
  70 getQuestion = Responder $ \ s ->
  71               return (rsQuestion s, s)
  72
  73 getQueryName :: (RecordType qt dt, RecordClass qc) => Responder qt qc DomainName
  74 getQueryName = liftM qName getQuestion
  75
  76 respond :: ( SaneAnswerType qt at, SaneAnswerClass qc ac
  77            , QueryType qt, RecordType at dt
  78            , RecordClass qc, RecordClass ac
  79            ) =>
  80            ResourceRecord at ac dt
  81         -> Responder qt qc ()
  82 respond rr
  83     = Responder $ \ s ->
  84       do let s' = s {
  85                     rsAnswers = rsAnswers s ++ [wrapRecord rr]
  86                   }
  87          return ((), s')
  88
  89 data SomeResponder
  90     = forall qt qc. (Typeable qt, Typeable qc) => SomeResponder (Responder qt qc ())
  91
  92 wrapResponder :: (RecordType qt dt, RecordClass qc) =>
  93                  Responder qt qc a
  94               -> SomeResponder
  95 wrapResponder m
  96     = SomeResponder (m >> return ())