{-# LANGUAGE FlexibleContexts #-}

module Factis.Haskoon.HttpSpec.SpecHandler
    ( matchBySpec, matchByReqSpec, rawSendBySpec, sendBySpec, rawSendToUrl, sendToUrl
    , rhSendReq, rhParseResIn, rhGenReqOut, rhParseUrl
) where

----------------------------------------
-- STDLIB
----------------------------------------
import Control.Monad.Error (MonadError(..))

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import Data.HttpSpec (HasReqSpec(..),HasResSpec(..),ResSpec,ReqSpec,WebExc(..)
                     ,webExcSetResIn, webExcSetReqOut
                     ,parseReqIn,genResOut,parseResIn,genReqOut)
import Data.HttpSpec.HttpTypes (HttpUrl,ReqIn(..),ReqOut(..),ResIn(..),ResOut(..))

import qualified Network.URI as Uri

----------------------------------------
-- LOCAL
----------------------------------------
import Factis.Haskoon.HttpSpec.WebHandler (ReqHandler(..))

matchBySpec :: (MonadError WebExc m, HasReqSpec a, HasResSpec b) =>
               (a -> m b)
            -> ReqIn
            -> m ResOut
matchBySpec fun reqIn = parseReqIn reqSpec reqIn >>= fun >>= genResOut resSpec

matchByReqSpec :: (MonadError WebExc m, HasReqSpec a) =>
                  (a -> m ResOut)
               -> ReqIn
               -> m ResOut
matchByReqSpec fun reqIn = parseReqIn reqSpec reqIn >>= fun


rhParseResIn :: ReqHandler m => ResSpec a -> ResIn -> m a
rhParseResIn resInSpec resIn =
    catchError (parseResIn resInSpec resIn) (throwError . webExcSetResIn resIn)

rhGenReqOut :: ReqHandler m => HttpUrl -> ReqSpec a -> a -> m ReqOut
rhGenReqOut baseUrl reqOutSpec a = genReqOut reqOutSpec baseUrl a

rhSendReq :: ReqHandler m => ReqOut -> m ResIn
rhSendReq reqOut =
    catchError (sendReq reqOut) (throwError . webExcSetReqOut reqOut)

rhParseUrl :: ReqHandler m => String -> m HttpUrl
rhParseUrl baseUrlStr =
    case Uri.parseURI baseUrlStr of
      Just uri -> return uri
      Nothing -> fail msg
    where msg = ("SpecHandler: Invalid base URI: `" ++ baseUrlStr ++ "'")

sendBySpec :: (HasReqSpec a, HasResSpec b, ReqHandler m) => HttpUrl -> a -> m b
sendBySpec baseUrl a =
    do resIn <- rawSendBySpec baseUrl a
       rhParseResIn resSpec resIn

rawSendBySpec :: (HasReqSpec a, ReqHandler m) => HttpUrl -> a -> m ResIn
rawSendBySpec baseUrl a =
    do reqOut <- rhGenReqOut baseUrl reqSpec a
       rhSendReq reqOut

rawSendToUrl :: (HasReqSpec a, ReqHandler m) => String -> a -> m ResIn
rawSendToUrl baseUrlStr a =
    do baseUrl <- rhParseUrl baseUrlStr
       rawSendBySpec baseUrl a

sendToUrl :: (HasReqSpec a, HasResSpec b, ReqHandler m) => String -> a -> m b
sendToUrl baseUrlStr a =
    do resIn <- rawSendToUrl baseUrlStr a
       rhParseResIn resSpec resIn