Network/DNS/Named/ResponseBuilder.hs

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