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 })