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
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)
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
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)
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
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
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)
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++"'.")
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"
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