Network/DNS/Named/ResponseBuilder.hs

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