{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.HttpSpec
    (ReqSpec, ResSpec, HttpSpec, WebErr(..)
    ,HasReqSpec(..), HasResSpec(..), TextEncoding
    ,rsHeader, rsHeaderFixed, rsParam, rsMeth, rsStatus
    ,rsXmlString, rsXml, rsPath, rsWithBody, rsBody, rsContentType
    ,rsPathSegment, rsXmlEncoding, rsTextEncoding, rsEncodingFixed
    ,genReqOut, genResOut, parseReqIn, parseResIn
    )
where
----------------------------------------
-- STDLIB
----------------------------------------
import Control.Monad (liftM,when,unless)
import Control.Monad.Reader (ask,asks,local)
import Control.Monad.Error (MonadError(..), Error(..))
import Data.Maybe (fromMaybe)
import Data.List (isPrefixOf)

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import qualified Network.HTTP as Http
import qualified Network.URI as Uri
import qualified Network.CGI as Cgi

import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLChar

import Data.Encoding (Encoding, DynEncoding
                     ,encodeLazyByteString, decodeLazyByteStringExplicit
                     ,encodingFromStringExplicit)

import Text.XML.HXT.Arrow (PU)

import Data.BidiSpec

----------------------------------------
-- LOCAL
----------------------------------------
import Data.HttpSpec.MiscHelper (eitherToM)
import Data.HttpSpec.EncodingHelper (encodingName)
import Data.HttpSpec.HttpTypes
    (HttpHeaderName,HttpHeaderValue,HttpHeader,HttpMethod,HttpBody
    ,HttpUrl, HttpParamName, HttpParamValue
    ,HttpData(..),ReqIn(..),ReqOut(..),ResIn(..),ResOut(..)
    ,IsHttp(..), IsReq(..), IsRes(..)
    ,urlParams, urlMatchPrefix, urlSplit)
import Data.HttpSpec.XmlHelper
    (XmlEncoding, pickleStr, pickleWithEnc, unpickle, unpickleStr
    ,xmlEncodingFromString, xmlEncodingToString)


-- ----------------------------------------------------------------------------
--  Spec types for request and response
-- ----------------------------------------------------------------------------

class HasReqSpec a where
    reqSpec :: ReqSpec a

class HasResSpec a where
    resSpec :: ResSpec a

type TextEncoding = DynEncoding

data WebErr
    = WebErrMissingParam String
    | WebErrMissingHeader HttpHeaderName
    | WebErrInvalidHeaderValue HttpHeaderName HttpHeaderValue String
    | WebErrInvalidMethod HttpMethod String
    | WebErrInvalidStatus Int String
    | WebErrInvalidUrl { webErr_expected :: String, webErr_actual :: String }
    | WebErrMissingContentType
    | WebErrUnexpectedContentType String String
    | WebErrEmptyContent
    | WebErrNoMatch ReqIn
    | WebErrNotImplemented String
    | WebErrCustomMsg String
      deriving (Show)

instance Error WebErr where
    noMsg = WebErrCustomMsg "HttpSpec: unknown error."
    strMsg = WebErrCustomMsg

type ReqErr = WebErr
type ResErr = WebErr
type HttpErr = WebErr

type ReqSpecGen a = SpecGen ReqOut a
type ReqSpecParser a = SpecParser ReqIn ReqErr a

type ResSpecGen a = SpecGen ResOut a
type ResSpecParser a = SpecParser ResIn ResErr a
type HttpSpecParser i a = SpecParser i HttpErr a

type ReqSpec = Spec ReqErr ReqIn ReqOut
type ResSpec = Spec ResErr ResIn ResOut
type HttpSpec = Spec HttpErr

mkReqSpec :: ReqSpecParser a -> ReqSpecGen a -> ReqSpec a
mkReqSpec = mkSpec

mkResSpec :: ResSpecParser a -> ResSpecGen a -> ResSpec a
mkResSpec = mkSpec

-- ----------------------------------------------------------------------------
--  HttpSpec combinators
-- ----------------------------------------------------------------------------

spGetHeader :: IsHttp h => HttpHeaderName -> HttpSpecParser h HttpHeaderValue
spGetHeader name = asks (httpGetHeader name)
                   >>= spFromMaybe (WebErrMissingHeader name)

rsWithBody :: (IsHttp i, IsHttp o) =>
              (HttpSpec i o BSL.ByteString -> HttpSpec i o a)
           -> HttpSpec i o a
rsWithBody f = rsWith f rsBody

rsBody :: (IsHttp i, IsHttp o) => HttpSpec i o BSL.ByteString
rsBody = rsWrap (BSLChar.pack, BSLChar.unpack) $
         rsGetSet httpBody (flip httpSetBody)

rsHeader :: (IsHttp i, IsHttp o) =>
            HttpHeaderName
         -> HttpSpec i o HttpHeaderValue
rsHeader n = mkSpec (spGetHeader n) (flip $ httpSetHeader n)

rsHeaderFixed :: (IsHttp i, IsHttp o) =>
                 HttpHeader
              -> HttpSpec i o a
              -> HttpSpec i o a
rsHeaderFixed (n,v) = rsCheckSet check (httpSetHeader n v)
    where check = spGetHeader n >>= spCheck (==v) err
          err v' = WebErrInvalidHeaderValue n v' ("Expected `"++v++"'.")

rsContentType :: (IsHttp i, IsHttp o) =>
                 String
              -> HttpSpec i o a
              -> HttpSpec i o a
rsContentType v = rsCheckSet check (httpSetHeader n v)
    where check = spGetHeader n >>= spCheck checkfun err
          checkfun v' = v `isPrefixOf` v'
          err v' = WebErrInvalidHeaderValue n v' ("Expected `"++v++"'.")
          n = Http.HdrContentType

-- ----------------------------------------------------------------------------
--  ReqSpec combinators
-- ----------------------------------------------------------------------------

rsParam :: HttpParamName -> ReqSpec HttpParamValue
rsParam name = mkSpec rsParse rsGen
    where
      rsGen req val = reqAddUrlParam name val req
      rsParse = spGets (urlParams . reqIn_fullUrl)
                >>= spFromMaybe err . lookup name
      err = WebErrMissingParam name

rsMeth :: HttpMethod -> ReqSpec a -> ReqSpec a
rsMeth meth = rsCheckSet check (reqSetMethod meth)
    where check = spGets reqMethod >>= spCheck (==meth) err
          err m = WebErrInvalidMethod m ("Expected method `"++show meth++"'.")

rsPathSegment :: ReqSpec a -> ReqSpec (String, a)
rsPathSegment rs = mkSpec rsParseDef rsGenDef
    where
      rsParseDef =
          do req <- spGet
             let msg = "URL too short."
                 url = reqUrl req
             case urlSplit url of
               Just (head,tail) ->
                   do a <- local (reqSetUrl tail) (rsParse rs)
                      return (head, a)
               Nothing -> throwError $ WebErrInvalidUrl msg (show url)
      rsGenDef r (path, a) = rsGen rs (reqAppendUrlPath path r) a

rsPath :: String -> ReqSpec a -> ReqSpec a
rsPath path rs = mkSpec rsParseDef rsGenDef
    where
      rsParseDef =
          do req <- spGet
             let msg = "Expected URL prefix: `"++path++"'"
                 url = reqUrl req
             case urlMatchPrefix path url of
               Just url' -> local (reqSetUrl url') (rsParse rs)
               Nothing -> throwError $ WebErrInvalidUrl msg (show url)
      rsGenDef r = rsGen rs (reqAppendUrlPath path r)

-- ----------------------------------------------------------------------------
--  ResSpec combinators
-- ----------------------------------------------------------------------------
rsStatus :: Int -> ResSpec a -> ResSpec a
rsStatus c = rsCheckSet check (resSetStatus c Nothing)
    where check = spGets resCode >>= spCheck (==c) err
          err i = WebErrInvalidStatus i ("Expected status code `"++show c++"'.")

-- ----------------------------------------------------------------------------
--  other specific combinators
-- ----------------------------------------------------------------------------

rsXmlString :: Error e => PU a -> Spec e i o String -> Spec e i o a
rsXmlString xp rs = rsWrapMaybe msg (unpickleStr xp, pickleStr xp) rs
    where msg = "Failed to unpickle XML."

rsXml :: Error e =>
         XmlEncoding
      -> PU a
      -> Spec e i o BSL.ByteString
      -> Spec e i o a
rsXml enc xp rs = rsWrapMaybe msg (unpickle xp, pickleWithEnc enc xp) rs
    where msg = "Failed to unpickle XML."

rsEncodingFixed :: (Error e, Encoding enc) =>
              enc
           -> Spec e i o BSL.ByteString
           -> Spec e i o String
rsEncodingFixed enc = rsWrapEither' (decode, encode)
    where decode = decodeLazyByteStringExplicit enc
          encode = encodeLazyByteString enc

rsXmlEncoding :: Error e => Spec e i o String -> Spec e i o XmlEncoding
rsXmlEncoding = rsWrapEither' (decode, xmlEncodingToString)
    where msg = "rsXmlEncoding: unknown encoding"
          decode = xmlEncodingFromString

rsTextEncoding :: Error e => Spec e i o String -> Spec e i o TextEncoding
rsTextEncoding = rsWrapMaybe msg (encodingFromStringExplicit, encodingName)
    where msg = "rsTextEncoding: unknown encoding"

-- ----------------------------------------------------------------------------
--  Spec runners
-- ----------------------------------------------------------------------------

genReqOut :: Monad m => ReqSpec a -> HttpUrl -> a -> m ReqOut
genReqOut rs base = genBySpec rs (ReqOut base Http.GET (HttpData [] ""))

parseReqIn :: MonadError ReqErr m => ReqSpec a -> ReqIn -> m a
parseReqIn rs reqIn = parseBySpec rs reqIn

genResOut :: Monad m => ResSpec a -> a -> m ResOut
genResOut rs = genBySpec rs (ResOut 200 Nothing (HttpData [] ""))

parseResIn :: MonadError ReqErr m => ResSpec a -> ResIn -> m a
parseResIn rs reqIn = parseBySpec rs reqIn