1 module Network.DNS.Named.ResponseBuilder
14 import Network.DNS.Message
17 newtype Builder a = B { unB :: Message -> (a, Message) }
19 instance Monad Builder where
20 return a = B $ \ s -> (a, s)
21 m >>= k = B $ \ s -> let (a, s') = unB m s
24 fail err = B $ error err
27 runBuilder :: Message -> Builder () -> Message
28 runBuilder query builder
29 = let initialReply = query {
34 modHeader' = modifyHeader $
36 hdMessageType = Response
37 , hdIsAuthoritativeAnswer = True
38 , hdIsTruncated = False
39 , hdIsRecursionAvailable = False
40 , hdResponseCode = NoError
42 (_, result) = unB (modHeader' >> builder) initialReply
46 get :: (Message -> a) -> Builder a
47 get f = B $ \ s -> (f s, s)
49 modify :: (Message -> Message) -> Builder ()
50 modify f = B $ \ s -> ((), f s)
52 modifyHeader :: (Header -> Header) -> Builder ()
54 = modify $ \ s -> s { msgHeader = f (msgHeader s) }
56 addAnswer :: SomeRR -> Builder ()
58 = do anss <- get msgAnswers
59 unless (any (== rr) anss)
61 s { msgAnswers = msgAnswers s ++ [rr] }
63 addAuthority :: SomeRR -> Builder ()
65 = do anss <- get msgAnswers
66 aths <- get msgAuthorities
67 unless (any (== rr) anss || any (== rr) aths)
69 s { msgAuthorities = msgAuthorities s ++ [rr] }
71 addAdditional :: SomeRR -> Builder ()
73 = do anss <- get msgAnswers
74 aths <- get msgAuthorities
75 adds <- get msgAdditionals
76 unless (any (== rr) anss || any (== rr) aths || any (== rr) adds)
78 s { msgAdditionals = msgAdditionals s ++ [rr] }
80 unauthorise :: Builder ()
81 unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })