module Network.DNS.Named.Responder
    ( Responder
    , SomeResponder

    , runResponder
    , runResponder'
    , wrapResponder

    , getQuestion
    , getQueryName
    , respond
    )
    where

import Control.Monad
import Control.Monad.Trans
import Data.Typeable
import Network.DNS.Message
import Network.DNS.Named.Sanity


data (QueryType qt, QueryClass qc) => ResponderState qt qc
    = ResponderState {
        rsQuestion :: !(Question qt qc)
      , rsAnswers  :: ![SomeRR]
      }

newtype (QueryType qt, QueryClass qc) => Responder qt qc a
    = Responder {
        unR :: ResponderState qt qc -> IO (a, ResponderState qt qc)
      }
    deriving Typeable

instance (QueryType qt, QueryClass qc) => Monad (Responder qt qc) where
    return a = Responder $ \ s -> return (a, s)
    m >>= k  = Responder $ \ s -> do (a, s') <- unR m s
                                     unR (k a) s'
    fail err = Responder $ \ _ -> fail err

instance (QueryType qt, QueryClass qc) => MonadIO (Responder qt qc) where
    liftIO m = Responder $ \ s -> do a <- m
                                     return (a, s)


runResponder :: (QueryType qt, QueryClass qc) =>
                Question qt qc
             -> Responder qt qc ()
             -> IO [SomeRR]
runResponder q m
    = do let s = ResponderState {
                   rsQuestion = q
                 , rsAnswers  = []
                 }
         (_, s') <- unR m s
         return $ rsAnswers s'

runResponder' :: forall qt qc.
                 (QueryType qt, QueryClass qc) =>
                 Question qt qc
              -> SomeResponder
              -> IO [SomeRR]
runResponder' q (SomeResponder r)
    = case cast r :: Maybe (Responder qt qc ()) of
        Nothing
            -> return []
        Just m
            -> runResponder q m

getQuestion :: (QueryType qt, QueryClass qc) => Responder qt qc (Question qt qc)
getQuestion = Responder $ \ s ->
              return (rsQuestion s, s)

getQueryName :: (QueryType qt, QueryClass qc) => Responder qt qc DomainName
getQueryName = liftM qName getQuestion

respond :: ( SaneAnswerType qt at, SaneAnswerClass qc ac
           , QueryType qt, RecordType at dt
           , QueryClass qc, RecordClass ac
           ) =>
           ResourceRecord at ac dt
        -> Responder qt qc ()
respond rr
    = Responder $ \ s ->
      do let s' = s {
                    rsAnswers = rsAnswers s ++ [wrapRecord rr]
                  }
         return ((), s')

data SomeResponder
    = forall qt qc. (Typeable qt, Typeable qc) => SomeResponder (Responder qt qc ())

wrapResponder :: (QueryType qt, QueryClass qc) =>
                 Responder qt qc a
              -> SomeResponder
wrapResponder m
    = SomeResponder (m >> return ())