1 module Network.DNS.Named.ResponseBuilder
15 import Network.DNS.Message
18 newtype Builder a = B { unB :: Message -> (a, Message) }
20 instance Monad Builder where
21 return a = B $ \ s -> (a, s)
22 m >>= k = B $ \ s -> let (a, s') = unB m s
25 fail err = B $ error err
28 runBuilder :: Message -> Builder () -> Message
29 runBuilder query builder
30 = let initialReply = query {
35 modHeader' = modifyHeader $
37 hdMessageType = Response
38 , hdIsAuthoritativeAnswer = True
39 , hdIsTruncated = False
40 , hdIsRecursionAvailable = False
41 , hdResponseCode = NoError
43 setNameError = do aa <- get (hdIsRecursionAvailable . msgHeader)
44 rc <- get (hdResponseCode . msgHeader)
45 anss <- get msgAnswers
47 when (aa && rc == NoError && null anss)
48 $ setResponseCode NameError
50 (_, result) = unB (modHeader' >> builder >> setNameError) initialReply
54 get :: (Message -> a) -> Builder a
55 get f = B $ \ s -> (f s, s)
57 modify :: (Message -> Message) -> Builder ()
58 modify f = B $ \ s -> ((), f s)
60 modifyHeader :: (Header -> Header) -> Builder ()
62 = modify $ \ s -> s { msgHeader = f (msgHeader s) }
64 addAnswer :: SomeRR -> Builder ()
66 = do anss <- get msgAnswers
67 unless (any (== rr) anss)
69 s { msgAnswers = msgAnswers s ++ [rr] }
71 addAuthority :: SomeRR -> Builder ()
73 = do anss <- get msgAnswers
74 aths <- get msgAuthorities
75 unless (any (== rr) anss || any (== rr) aths)
77 s { msgAuthorities = msgAuthorities s ++ [rr] }
79 addAdditional :: SomeRR -> Builder ()
81 = do anss <- get msgAnswers
82 aths <- get msgAuthorities
83 adds <- get msgAdditionals
84 unless (any (== rr) anss || any (== rr) aths || any (== rr) adds)
86 s { msgAdditionals = msgAdditionals s ++ [rr] }
88 unauthorise :: Builder ()
89 unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })
91 setResponseCode :: ResponseCode -> Builder ()
93 = modifyHeader (\ h -> h { hdResponseCode = code })