Response builder

[haskell-dns.git] / Network / DNS / Named / ResponseBuilder.hs

diff --git a/Network/DNS/Named/ResponseBuilder.hs b/Network/DNS/Named/ResponseBuilder.hs
new file mode 100644 (file)
index 0000000..487a678
--- /dev/null
+++ b/Network/DNS/Named/ResponseBuilder.hs
@@ -0,0 +1,81 @@
+module Network.DNS.Named.ResponseBuilder
+    ( Builder
+
+    , runBuilder
+
+    , unauthorise
+    , addAnswer
+    , addAuthority
+    , addAdditional
+    )
+    where
+
+import Control.Monad
+import Network.DNS.Message
+
+
+newtype Builder a = B { unB :: Message -> (a, Message) }
+
+instance Monad Builder where
+    return a = B $ \ s -> (a, s)
+    m >>= k  = B $ \ s -> let (a, s') = unB m s
+                          in
+                            unB (k a) s'
+    fail err = B $ error err
+
+
+runBuilder :: Message -> Builder () -> Message
+runBuilder query builder
+    = let initialReply = query {
+                           msgAnswers     = []
+                         , msgAuthorities = []
+                         , msgAdditionals = []
+                         }
+          modHeader'   = modifyHeader $
+                         \ h -> h {
+                                  hdMessageType           = Response
+                                , hdIsAuthoritativeAnswer = True
+                                , hdIsTruncated           = False
+                                , hdIsRecursionAvailable  = False
+                                , hdResponseCode          = NoError
+                                }
+          (_, result)  = unB (modHeader' >> builder) initialReply
+      in
+        result
+
+get :: (Message -> a) -> Builder a
+get f = B $ \ s -> (f s, s)
+
+modify :: (Message -> Message) -> Builder ()
+modify f = B $ \ s -> ((), f s)
+
+modifyHeader :: (Header -> Header) -> Builder ()
+modifyHeader f
+    = modify $ \ s -> s { msgHeader = f (msgHeader s) }
+
+addAnswer :: SomeRR -> Builder ()
+addAnswer rr
+    = do anss <- get msgAnswers
+         unless (any (== rr) anss)
+             $ modify $ \ s ->
+                 s { msgAnswers = msgAnswers s ++ [rr] }
+
+addAuthority :: SomeRR -> Builder ()
+addAuthority rr
+    = do anss <- get msgAnswers
+         aths <- get msgAuthorities
+         unless (any (== rr) anss || any (== rr) aths)
+             $ modify $ \ s ->
+                 s { msgAuthorities = msgAuthorities s ++ [rr] }
+
+addAdditional :: SomeRR -> Builder ()
+addAdditional rr
+    = do anss <- get msgAnswers
+         aths <- get msgAuthorities
+         adds <- get msgAdditionals
+         unless (any (== rr) anss || any (== rr) aths || any (== rr) adds)
+             $ modify $ \ s ->
+                 s { msgAdditionals = msgAdditionals s ++ [rr] }
+
+unauthorise :: Builder ()
+unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })