Network/DNS/Named/ResponseBuilder.hs

   1 module Network.DNS.Named.ResponseBuilder
   2     ( Builder
   3
   4     , runBuilder
   5
   6     , unauthorise
   7     , addAnswer
   8     , addAuthority
   9     , addAdditional
  10     )
  11     where
  12
  13 import Control.Monad
  14 import Network.DNS.Message
  15
  16
  17 newtype Builder a = B { unB :: Message -> (a, Message) }
  18
  19 instance Monad Builder where
  20     return a = B $ \ s -> (a, s)
  21     m >>= k  = B $ \ s -> let (a, s') = unB m s
  22                           in
  23                             unB (k a) s'
  24     fail err = B $ error err
  25
  26
  27 runBuilder :: Message -> Builder () -> Message
  28 runBuilder query builder
  29     = let initialReply = query {
  30                            msgAnswers     = []
  31                          , msgAuthorities = []
  32                          , msgAdditionals = []
  33                          }
  34           modHeader'   = modifyHeader $
  35                          \ h -> h {
  36                                   hdMessageType           = Response
  37                                 , hdIsAuthoritativeAnswer = True
  38                                 , hdIsTruncated           = False
  39                                 , hdIsRecursionAvailable  = False
  40                                 , hdResponseCode          = NoError
  41                                 }
  42           (_, result)  = unB (modHeader' >> builder) initialReply
  43       in
  44         result
  45
  46 get :: (Message -> a) -> Builder a
  47 get f = B $ \ s -> (f s, s)
  48
  49 modify :: (Message -> Message) -> Builder ()
  50 modify f = B $ \ s -> ((), f s)
  51
  52 modifyHeader :: (Header -> Header) -> Builder ()
  53 modifyHeader f
  54     = modify $ \ s -> s { msgHeader = f (msgHeader s) }
  55
  56 addAnswer :: SomeRR -> Builder ()
  57 addAnswer rr
  58     = do anss <- get msgAnswers
  59          unless (any (== rr) anss)
  60              $ modify $ \ s ->
  61                  s { msgAnswers = msgAnswers s ++ [rr] }
  62
  63 addAuthority :: SomeRR -> Builder ()
  64 addAuthority rr
  65     = do anss <- get msgAnswers
  66          aths <- get msgAuthorities
  67          unless (any (== rr) anss || any (== rr) aths)
  68              $ modify $ \ s ->
  69                  s { msgAuthorities = msgAuthorities s ++ [rr] }
  70
  71 addAdditional :: SomeRR -> Builder ()
  72 addAdditional rr
  73     = do anss <- get msgAnswers
  74          aths <- get msgAuthorities
  75          adds <- get msgAdditionals
  76          unless (any (== rr) anss || any (== rr) aths || any (== rr) adds)
  77              $ modify $ \ s ->
  78                  s { msgAdditionals = msgAdditionals s ++ [rr] }
  79
  80 unauthorise :: Builder ()
  81 unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })