diff --git a/httpspec.cabal b/httpspec.cabal --- a/httpspec.cabal +++ b/httpspec.cabal @@ -1,9 +1,9 @@ Name: httpspec -Version: 0.1 +Version: 0.3.0.1 Synopsis: Specification of HTTP request/response generators and parsers License: LGPL License-file: LICENSE -Author: David Leuschner +Author: David Leuschner, Stefan Wehr Maintainer: David Leuschner Category: Data, Web Description: @@ -55,10 +55,13 @@ Library Hs-Source-Dirs: src GHC-Options: -Wall + -fno-warn-name-shadowing + -fno-warn-orphans + -fno-warn-overlapping-patterns Build-Depends: base >= 4 && < 5, bytestring, bidispec, mtl, - tagsoup == 0.6, hxt > 8.3 && < 8.4, pretty, - Safe, cgi, network, HTTP, filepath, containers, - encoding >= 0.6 + hxt > 8.3, pretty, MissingH, + safe, cgi, network, HTTP, filepath, containers, + encoding >= 0.6, hxthelper Exposed-Modules: Data.HttpSpec,Data.HttpSpec.HttpTypes - Data.HttpSpec.Pretty, Data.HttpSpec.MiscHelper - Data.HttpSpec.XmlHelper, Data.HttpSpec.EncodingHelper + Data.HttpSpec.Pretty + Data.HttpSpec.EncodingHelper diff --git a/src/Data/HttpSpec.hs b/src/Data/HttpSpec.hs --- a/src/Data/HttpSpec.hs +++ b/src/Data/HttpSpec.hs @@ -1,21 +1,26 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.HttpSpec - (ReqSpec, ResSpec, HttpSpec, WebErr(..) + (ReqSpec, ResSpec, HttpSpec + ,WebComm(..), WebIn(..), WebOut(..), WebExc(..), WebErr(..) ,HasReqSpec(..), HasResSpec(..), TextEncoding ,rsHeader, rsHeaderFixed, rsParam, rsMeth, rsStatus - ,rsXmlString, rsXml, rsPath, rsWithBody, rsBody, rsContentType + ,rsXmlString, rsXml, rsValidXml + ,rsPath, rsPathFixed, rsWithBody, rsBody, rsContentType ,rsPathSegment, rsXmlEncoding, rsTextEncoding, rsEncodingFixed - ,genReqOut, genResOut, parseReqIn, parseResIn + ,genReqOut, genResOut, parseReqIn, parseResIn, rsXmlBody + ,webExcSetReqIn, webExcSetResIn, webExcSetReqOut, webExcSetResOut ) where + ---------------------------------------- -- STDLIB ---------------------------------------- -import Control.Monad (liftM,when,unless) -import Control.Monad.Reader (ask,asks,local) +import Prelude hiding (exp) + +import Control.Monad (liftM) +import Control.Monad.Reader (asks,local) import Control.Monad.Error (MonadError(..), Error(..)) -import Data.Maybe (fromMaybe) import Data.List (isPrefixOf) ---------------------------------------- @@ -23,10 +28,8 @@ ---------------------------------------- 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 @@ -39,18 +42,18 @@ ---------------------------------------- -- LOCAL ---------------------------------------- -import Data.HttpSpec.MiscHelper (eitherToM) import Data.HttpSpec.EncodingHelper (encodingName) import Data.HttpSpec.HttpTypes - (HttpHeaderName,HttpHeaderValue,HttpHeader,HttpMethod,HttpBody + (HttpHeaderName,HttpHeaderValue,HttpHeader,HttpMethod ,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) - +import Text.XML.HXT.Helper + (XmlValidator,XmlEncoding, pickleStr, pickleWithEnc, unpickle, unpickleStr + ,validateAndUnpickle + ,xmlEncodingFromString, xmlEncodingToString, _UTF8_) +import Data.HttpSpec.Pretty (Pretty(..)) -- ---------------------------------------------------------------------------- -- Spec types for request and response @@ -64,15 +67,39 @@ type TextEncoding = DynEncoding +data WebComm + = WebCommIn WebIn + | WebCommOut WebOut + deriving (Show) + +data WebIn + = WebIn + { webIn_req :: Maybe ReqIn + , webIn_res :: Maybe ResOut + } deriving (Show) + +data WebOut + = WebOut + { webOut_req :: Maybe ReqOut + , webOut_res :: Maybe ResIn + } deriving (Show) + + +data WebExc + = WebExc + { webExc_comm :: Maybe WebComm + , webExc_err :: WebErr + } deriving (Show) + data WebErr = WebErrMissingParam String | WebErrMissingHeader HttpHeaderName | WebErrInvalidHeaderValue HttpHeaderName HttpHeaderValue String | WebErrInvalidMethod HttpMethod String | WebErrInvalidStatus Int String - | WebErrInvalidUrl { webErr_expected :: String, webErr_actual :: String } + | WebErrInvalidUrl {- expected: -} String {- actual: -} String | WebErrMissingContentType - | WebErrUnexpectedContentType String String + | WebErrUnexpectedContentType {- expected: -} String {- actual: -} String | WebErrEmptyContent | WebErrNoMatch ReqIn | WebErrNotImplemented String @@ -83,43 +110,74 @@ noMsg = WebErrCustomMsg "HttpSpec: unknown error." strMsg = WebErrCustomMsg -type ReqErr = WebErr -type ResErr = WebErr -type HttpErr = WebErr +instance Error WebExc where + noMsg = mkErr (WebErrCustomMsg "HttpSpec: unknown error.") + strMsg s = mkErr (WebErrCustomMsg s) -type ReqSpecGen a = SpecGen ReqOut a -type ReqSpecParser a = SpecParser ReqIn ReqErr a +instance Pretty WebExc where + ppr exc = ppr (webExc_err exc) -type ResSpecGen a = SpecGen ResOut a -type ResSpecParser a = SpecParser ResIn ResErr a +instance Pretty WebErr where + pprString err = + case err of + WebErrMissingParam p -> + "Missing parameter `" ++ p ++ "'" + WebErrMissingHeader h -> + "Missing parameter `" ++ show h ++ "'" + WebErrInvalidHeaderValue n v s -> + "Invalid value " ++ show v ++ " for header `" ++ show n ++ + "': " ++ s + WebErrInvalidMethod method s -> + "Invalid HTTP method " ++ show method ++ ": " ++ s + WebErrInvalidStatus stat s -> + "Invalid HTTP status " ++ show stat ++ ": " ++ s + WebErrInvalidUrl exp act -> + "Invalid URL, expected " ++ exp ++ ", given " ++ act + WebErrMissingContentType -> + "Content type missing" + WebErrUnexpectedContentType exp act -> + "Unexpected content type, expected " ++ exp ++ ", given " ++ act + WebErrEmptyContent -> + "No content given" + WebErrNoMatch req -> + "No matching URL for " ++ show (reqIn_fullUrl req) ++ + ", method " ++ show (reqIn_method req) + WebErrNotImplemented s -> + "Functionality not yet implemented: " ++ s + WebErrCustomMsg s -> + s + +type ReqErr = WebExc +type ResErr = WebExc +type HttpErr = WebExc + 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 +-- ---------------------------------------------------------------------------- +-- helper functions +-- ---------------------------------------------------------------------------- +spGetHeader :: IsHttp h => HttpHeaderName -> HttpSpecParser h HttpHeaderValue +spGetHeader name = asks (httpGetHeader name) + >>= spFromMaybe (mkErr $ WebErrMissingHeader name) -mkResSpec :: ResSpecParser a -> ResSpecGen a -> ResSpec a -mkResSpec = mkSpec +mkErr :: WebErr -> WebExc +mkErr err = WebExc Nothing err -- ---------------------------------------------------------------------------- -- 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) +rsBody = rsGetSet httpBody (flip httpSetBody) rsHeader :: (IsHttp i, IsHttp o) => HttpHeaderName @@ -132,7 +190,7 @@ -> 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++"'.") + err v' = mkErr $ WebErrInvalidHeaderValue n v' ("Expected `"++v++"'.") rsContentType :: (IsHttp i, IsHttp o) => String @@ -141,7 +199,7 @@ 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++"'.") + err v' = mkErr $ WebErrInvalidHeaderValue n v' ("Expected `"++v++"'.") n = Http.HdrContentType -- ---------------------------------------------------------------------------- @@ -149,17 +207,17 @@ -- ---------------------------------------------------------------------------- rsParam :: HttpParamName -> ReqSpec HttpParamValue -rsParam name = mkSpec rsParse rsGen +rsParam name = mkSpec rsParseDef rsGenDef where - rsGen req val = reqAddUrlParam name val req - rsParse = spGets (urlParams . reqIn_fullUrl) + rsGenDef req val = reqAddUrlParam name val req + rsParseDef = spGets (urlParams . reqIn_fullUrl) >>= spFromMaybe err . lookup name - err = WebErrMissingParam name + err = mkErr $ 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++"'.") + err m = mkErr $ WebErrInvalidMethod m ("Expected method `"++show meth++"'.") rsPathSegment :: ReqSpec a -> ReqSpec (String, a) rsPathSegment rs = mkSpec rsParseDef rsGenDef @@ -169,14 +227,19 @@ 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) + Just (hd,tl) -> + do a <- local (reqSetUrl tl) (rsParse rs) + return (hd, a) + Nothing -> throwError $ mkErr $ 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 +rsPath :: ReqSpec String +rsPath = mkSpec rsParseDef rsGenDef + where rsParseDef = liftM (Uri.uriPath . reqUrl) spGet + rsGenDef r path = reqSetUrlPath path r + +rsPathFixed :: String -> ReqSpec a -> ReqSpec a +rsPathFixed path rs = mkSpec rsParseDef rsGenDef where rsParseDef = do req <- spGet @@ -184,7 +247,7 @@ url = reqUrl req case urlMatchPrefix path url of Just url' -> local (reqSetUrl url') (rsParse rs) - Nothing -> throwError $ WebErrInvalidUrl msg (show url) + Nothing -> throwError $ mkErr $ WebErrInvalidUrl msg (show url) rsGenDef r = rsGen rs (reqAppendUrlPath path r) -- ---------------------------------------------------------------------------- @@ -193,7 +256,7 @@ 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++"'.") + err i = mkErr $ WebErrInvalidStatus i ("Expected status code `"++show c++"'.") -- ---------------------------------------------------------------------------- -- other specific combinators @@ -211,6 +274,21 @@ rsXml enc xp rs = rsWrapMaybe msg (unpickle xp, pickleWithEnc enc xp) rs where msg = "Failed to unpickle XML." +rsValidXml :: Error e => + XmlEncoding + -> XmlValidator + -> PU a + -> Spec e i o BSL.ByteString + -> Spec e i o a +rsValidXml enc val xp rs = + flip rsWrapEither rs ( mapLeft strMsg . validateAndUnpickle val xp + , pickleWithEnc enc xp) + where mapLeft f (Left a) = Left (f a) + mapLeft _f (Right c) = Right c + +rsXmlBody :: (IsHttp i, IsHttp o) => PU a -> HttpSpec i o a +rsXmlBody xp = rsWithBody (rsXml _UTF8_ xp) + rsEncodingFixed :: (Error e, Encoding enc) => enc -> Spec e i o BSL.ByteString @@ -221,8 +299,7 @@ rsXmlEncoding :: Error e => Spec e i o String -> Spec e i o XmlEncoding rsXmlEncoding = rsWrapEither' (decode, xmlEncodingToString) - where msg = "rsXmlEncoding: unknown encoding" - decode = xmlEncodingFromString + where decode = xmlEncodingFromString rsTextEncoding :: Error e => Spec e i o String -> Spec e i o TextEncoding rsTextEncoding = rsWrapMaybe msg (encodingFromStringExplicit, encodingName) @@ -233,13 +310,49 @@ -- ---------------------------------------------------------------------------- genReqOut :: Monad m => ReqSpec a -> HttpUrl -> a -> m ReqOut -genReqOut rs base = genBySpec rs (ReqOut base Http.GET (HttpData [] "")) +genReqOut rs base = genBySpec rs (ReqOut base Http.GET (HttpData [] BSL.empty)) parseReqIn :: MonadError ReqErr m => ReqSpec a -> ReqIn -> m a -parseReqIn rs reqIn = parseBySpec rs reqIn +parseReqIn rs reqIn = catchError (parseBySpec rs reqIn) handler + where handler = throwError . webExcSetReqIn reqIn genResOut :: Monad m => ResSpec a -> a -> m ResOut -genResOut rs = genBySpec rs (ResOut 200 Nothing (HttpData [] "")) +genResOut rs = genBySpec rs (ResOut 200 Nothing (HttpData [] BSL.empty)) parseResIn :: MonadError ReqErr m => ResSpec a -> ResIn -> m a -parseResIn rs reqIn = parseBySpec rs reqIn +parseResIn rs resIn = catchError (parseBySpec rs resIn) handler + where handler = throwError . webExcSetResIn resIn + + +webExcSetReqIn :: ReqIn -> WebExc -> WebExc +webExcSetReqIn reqIn exc = + case exc of + WebExc (Just (WebCommIn win)) err -> WebExc (Just $ WebCommIn $ updWin win) err + WebExc Nothing err -> WebExc (Just $ WebCommIn $ updWin $ WebIn Nothing Nothing) err + _ -> exc + where updWin win = win { webIn_req = Just reqIn} + +webExcSetResOut :: ResOut -> WebExc -> WebExc +webExcSetResOut resOut exc = + case exc of + WebExc (Just (WebCommIn win)) err -> WebExc (Just $ WebCommIn $ updWin win) err + WebExc Nothing err -> WebExc (Just $ WebCommIn $ updWin $ WebIn Nothing Nothing) err + _ -> exc + where updWin win = win { webIn_res = Just resOut} + + +webExcSetResIn :: ResIn -> WebExc -> WebExc +webExcSetResIn resIn exc = + case exc of + WebExc (Just (WebCommOut wout)) err -> WebExc (Just $ WebCommOut $ updWout wout) err + WebExc Nothing err -> WebExc (Just $ WebCommOut $ updWout $ WebOut Nothing Nothing) err + _ -> exc + where updWout wout = wout { webOut_res = Just resIn} + +webExcSetReqOut :: ReqOut -> WebExc -> WebExc +webExcSetReqOut reqOut exc = + case exc of + WebExc (Just (WebCommOut wout)) err -> WebExc (Just $ WebCommOut $ updWout wout) err + WebExc Nothing err -> WebExc (Just $ WebCommOut $ updWout $ WebOut Nothing Nothing) err + _ -> exc + where updWout wout = wout { webOut_req = Just reqOut} diff --git a/src/Data/HttpSpec/EncodingHelper.hs b/src/Data/HttpSpec/EncodingHelper.hs --- a/src/Data/HttpSpec/EncodingHelper.hs +++ b/src/Data/HttpSpec/EncodingHelper.hs @@ -1,5 +1,9 @@ -module Data.HttpSpec.EncodingHelper (encodingName) where +module Data.HttpSpec.EncodingHelper (encodingName, xmlEncoding, encodingFromContentType) where +import Data.String.Utils (strip) +import Text.XML.HXT.Helper (xmlEncoding) +import Data.Encoding (DynEncoding, encodingFromStringExplicit) + encodingName :: Show enc => enc -> String encodingName enc = case show enc of @@ -31,3 +35,8 @@ "CP1257" -> "WINDOWS-1257" "CP1258" -> "WINDOWS-1258" _ -> "unknown" + +encodingFromContentType :: String -> Maybe DynEncoding +encodingFromContentType s = + let enc = (drop 1 . dropWhile (/='=') . strip . drop 1 . dropWhile (/= ';')) s + in encodingFromStringExplicit enc diff --git a/src/Data/HttpSpec/HttpTypes.hs b/src/Data/HttpSpec/HttpTypes.hs --- a/src/Data/HttpSpec/HttpTypes.hs +++ b/src/Data/HttpSpec/HttpTypes.hs @@ -14,15 +14,16 @@ -- STDLIB ---------------------------------------- import Data.Char (toLower) -import Data.Maybe (fromMaybe, catMaybes) -import Data.Map (Map) +import Data.Maybe (fromMaybe) import qualified Data.Map as Map -import Data.List (isPrefixOf) +import Data.List (intersperse, unfoldr, isPrefixOf) import Control.Monad (liftM) import Control.Arrow (first) -import System.FilePath (takeDirectory, ()) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLChar +import Data.Encoding (decodeLazyByteStringExplicit) ---------------------------------------- -- SITE-PACKAGES @@ -31,7 +32,7 @@ import qualified Network.URI as Uri import qualified Network.CGI as Cgi -import Text.PrettyPrint.HughesPJ (Doc, vcat, ($+$), (<+>), (<>), text, colon +import Text.PrettyPrint.HughesPJ (Doc, ($+$), (<+>), (<>), text, colon ,int, empty) import Safe (headMay) @@ -40,6 +41,7 @@ -- LOCAL ---------------------------------------- import Data.HttpSpec.Pretty (Pretty(..)) +import Data.HttpSpec.EncodingHelper (xmlEncoding, encodingFromContentType) -- ============================================================================ -- http types @@ -57,7 +59,7 @@ type HttpHeaderValue = String type HttpHeader = (HttpHeaderName, String) type HttpHeaders = [HttpHeader] -type HttpBody = String +type HttpBody = BSL.ByteString -- Request types type HttpMethod = Http.RequestMethod @@ -78,21 +80,32 @@ , reqIn_data :: HttpData } deriving (Show) +reqIn_body :: ReqIn -> HttpBody reqIn_body = http_body . reqIn_data + +reqIn_headers :: ReqIn -> HttpHeaders reqIn_headers = http_headers . reqIn_data data ReqOut = ReqOut { reqOut_url :: HttpUrl , reqOut_method :: HttpMethod , reqOut_data :: HttpData } deriving (Show) + +reqOut_body :: ReqOut -> HttpBody reqOut_body = http_body . reqOut_data + +reqOut_headers :: ReqOut -> HttpHeaders reqOut_headers = http_headers . reqOut_data data ResIn = ResIn { resIn_code :: HttpCode , resIn_reason :: HttpReason , resIn_data :: HttpData } deriving (Show) + +resIn_body :: ResIn -> HttpBody resIn_body = http_body . resIn_data + +resIn_headers :: ResIn -> HttpHeaders resIn_headers = http_headers . resIn_data @@ -100,7 +113,11 @@ , resOut_reason :: Maybe HttpReason , resOut_data :: HttpData } deriving (Show) + +resOut_body :: ResOut -> HttpBody resOut_body = http_body . resOut_data + +resOut_headers :: ResOut -> HttpHeaders resOut_headers = http_headers . resOut_data @@ -114,7 +131,16 @@ mapHdr other = Right (show other) mkHeaderName :: String -> HttpHeaderName -mkHeaderName = Http.HdrCustom +mkHeaderName s' + | s == "content-length" = Http.HdrContentLength + | s == "content-md5" = Http.HdrContentMD5 + | s == "content-type" = Http.HdrContentType + | s == "content-encoding" = Http.HdrContentEncoding + | s == "content-transfer-encoding" = Http.HdrContentTransferEncoding + | s == "transfer-encoding" = Http.HdrTransferEncoding + | s == "user-agent" = Http.HdrUserAgent + | otherwise = Http.HdrCustom s' + where s = map toLower s' url :: String -> HttpUrl url s = case Uri.parseURI s of @@ -133,6 +159,9 @@ urlAppendPath :: HttpPath -> HttpUrl -> HttpUrl urlAppendPath path uri = uri { Uri.uriPath = Uri.uriPath uri ++ path } +urlSetPath :: HttpPath -> HttpUrl -> HttpUrl +urlSetPath path uri = uri { Uri.uriPath = path } + -- | Splits off the first path component of a URL. -- @urlSplit (url "http://svr/foo/bar") == Just ("/foo", url "http://svr/bar")@ -- @urlSplit (url "http://svr/") == Just ("/", url "http://svr")@ @@ -140,7 +169,7 @@ urlSplit :: Monad m => HttpUrl -> m (HttpPath, HttpUrl) urlSplit uri = liftM mapUri (uriPathSplit $ Uri.uriPath uri) where - mapUri (head, tail) = (head, uri { Uri.uriPath = tail }) + mapUri (hd, tl) = (hd, uri { Uri.uriPath = tl }) uriPathSplit "" = fail "Empty URL Path." uriPathSplit "/" = return ("/", "") uriPathSplit ('/':path) = liftM (first ('/':)) (uriPathSplit path) @@ -161,7 +190,7 @@ completeReq :: IsHttp req => req -> req completeReq r = if clen /= 0 then r2 else r where - clen = length (httpBody r) + clen = BSL.length (httpBody r) r1 | not (httpHasHeader Http.HdrTransferEncoding r) && not (httpHasHeader Http.HdrContentLength r) = httpSetHeader Http.HdrContentLength (show clen) r @@ -188,12 +217,12 @@ httpBody :: a -> HttpBody httpBody = http_body . httpData httpGetHeader :: HttpHeaderName -> a -> Maybe HttpHeaderValue - httpGetHeader n x = - case n of + httpGetHeader hn x = + case hn of Http.HdrCustom mixedName -> headMay vals where vals = [v | (Http.HdrCustom n, v) <- httpHeaders x, map toLower n == name] name = map toLower mixedName - _ -> lookup n (httpHeaders x) + _ -> lookup hn (httpHeaders x) httpHasHeader :: HttpHeaderName -> a -> Bool httpHasHeader n = (/=Nothing) . httpGetHeader n httpSetBody :: HttpBody -> a -> a @@ -220,6 +249,8 @@ reqSetUrl :: HttpUrl -> a -> a reqUrlPath :: a -> HttpPath reqUrlPath req = Uri.uriPath (reqUrl req) + reqSetUrlPath :: HttpPath -> a -> a + reqSetUrlPath p req = reqSetUrl (urlSetPath p (reqUrl req)) req reqAppendUrlPath :: HttpPath -> a -> a reqAppendUrlPath p req = reqSetUrl (urlAppendPath p (reqUrl req)) req reqAddUrlParam :: HttpParamName -> HttpParamValue -> a -> a @@ -261,13 +292,13 @@ reqMethod = reqIn_method reqUrl = reqIn_fullUrl reqSetMethod meth req = req { reqIn_method = meth } - reqSetUrl url req = req { reqIn_fullUrl = url } + reqSetUrl newUrl req = req { reqIn_fullUrl = newUrl } instance IsReq ReqOut where reqMethod = reqOut_method reqUrl = reqOut_url reqSetMethod meth req = req { reqOut_method = meth } - reqSetUrl url req = req { reqOut_url = url } + reqSetUrl newUrl req = req { reqOut_url = newUrl } pprReq :: IsReq req => req -> Doc @@ -277,17 +308,61 @@ pprRes :: IsRes res => res -> Doc pprRes res = int (resCode res) <+> text (resReason res) $+$ ppr (httpData res) +pprHttpBody :: Maybe String -> BSL.ByteString -> Doc +pprHttpBody mctype b = + case mctype of + Just ctype | "text/xml" `isPrefixOf` ctype || "application/xml" `isPrefixOf` ctype + -> pprWithEncoding (xmlEncoding b) + Just ctype | "text/" `isPrefixOf` ctype + -> pprWithEncoding (encodingFromContentType ctype) + Nothing | BSL.length b == 0 -> empty + _ -> + let hd' = BSL.take (fromIntegral maxbytes) b + hd = BSLChar.takeWhile (<'\128') hd' + unfold x = if BSL.length x > (fromIntegral maxlinelen) + then Just (BSL.splitAt (fromIntegral maxlinelen) x) + else Nothing + in if BSL.length hd' > 20 + then (text . BSLChar.unpack . BSL.concat . intersperse binsep) (unfoldr unfold hd) + else (text "[" <> text (show $ BSL.length b) <+> text "bytes" + <+> text (fromMaybe "binary data" mctype) <> text "]") + where + pprWithEncoding Nothing = + (text ("Could not determine encoding of body of content-type " + ++ fromMaybe "(unknown)" mctype ++ ".") + $+$ text "The first 64 bytes are: " + $+$ text (show (BSL.take 64 b))) + pprWithEncoding (Just enc) = + case decodeLazyByteStringExplicit enc b of + Left err -> text ("Could not decode body with " ++ show (BSL.length b) ++ " bytes " ++ + " using the given encoding " ++ show enc ++ ": " ++ show err) + Right s -> foldl ($+$) empty (map text $ "" : showlines s) + showlines s | (showlines'' s) /= lines s = (showlines'' s) ++ ["[body shortend!]"] + | otherwise = bodylines s + showlines'' s = map (shorten maxlinelen) (showlines' s) + showlines' s = + let (shorts,longs) = (span ((<=maxtakelinelen) . length) . take 25) (bodylines s) + in shorts ++ take 1 longs + bodylines s = lines (take maxbytes s) + maxbytes = 1500 + binsep = BSLChar.pack "\\\n" + maxtakelinelen = 160 + maxlinelen = 100 + +shorten :: Int -> String -> String +shorten i s + | length s <= i = s + | otherwise = take (i-3) s ++ "..." + instance Pretty Uri.URI where ppr = text . show instance Pretty HttpData where - ppr (HttpData hds b) = foldl ($+$) empty (map pprHd hds) - $+$ foldl ($+$) empty (map text $ "" : bodylines) - where pprHd (n,v) = text (show n) <> colon <+> text v - showlines | showlines' /= bodylines = bodylines ++ ["[...]"] - | otherwise = bodylines - showlines' = takeWhile ((<=80) . length) $ take 5 bodylines - bodylines = lines b + ppr http@(HttpData hds b) = headers $+$ body + where + body = pprHttpBody (httpGetHeader Http.HdrContentType http) b + headers = foldl ($+$) empty (map pprHd hds) + pprHd (n,v) = text (show n) <> colon <+> text v instance Pretty ReqIn where ppr = pprReq diff --git a/src/Data/HttpSpec/MiscHelper.hs b/src/Data/HttpSpec/MiscHelper.hs deleted file mode 100644 --- a/src/Data/HttpSpec/MiscHelper.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Data.HttpSpec.MiscHelper - (errorToMaybe, errorToDefault, maybeToM, eitherToM, safeMain) -where - ----------------------------------------- --- STDLIB ----------------------------------------- -import Prelude hiding (catch) - -import Control.Monad (liftM) -import Control.Monad.Error (MonadError, catchError) -import Control.Exception (catch,SomeException) - -import System.IO (hPutStrLn,stderr) -import System.Exit (exitFailure) -import System.Environment (getProgName) - - -maybeToM :: Monad m => String -> Maybe a -> m a -maybeToM _msg (Just x) = return x -maybeToM msg Nothing = fail msg - -errorToMaybe :: MonadError e m => m a -> m (Maybe a) -errorToMaybe ma = catchError (liftM Just ma) (\_ -> return Nothing) - -errorToDefault :: MonadError e m => a -> m a -> m a -errorToDefault a ma = catchError ma (\_ -> return a) - -eitherToM :: (Show a, Monad m) => Either a b -> m b -eitherToM (Left err) = fail (show err) -eitherToM (Right ok) = return ok - -safeMain :: IO () -> IO () -safeMain io = io `catch` handle - where - handle :: SomeException -> IO () - handle e = - do s <- getProgName - hPutStrLn stderr ("Caught exception while running " ++ s ++ ": " ++ show e) - exitFailure diff --git a/src/Data/HttpSpec/Pretty.hs b/src/Data/HttpSpec/Pretty.hs --- a/src/Data/HttpSpec/Pretty.hs +++ b/src/Data/HttpSpec/Pretty.hs @@ -3,8 +3,10 @@ ---------------------------------------- -- SITE-PACKAGES ---------------------------------------- -import Text.PrettyPrint.HughesPJ (Doc) - +import Text.PrettyPrint.HughesPJ (Doc, text) class Pretty a where ppr :: a -> Doc + ppr = text . pprString + pprString :: a -> String + pprString = show . ppr diff --git a/src/Data/HttpSpec/XmlHelper.hs b/src/Data/HttpSpec/XmlHelper.hs deleted file mode 100644 --- a/src/Data/HttpSpec/XmlHelper.hs +++ /dev/null @@ -1,240 +0,0 @@ -module Data.HttpSpec.XmlHelper - --- == EXPORTS ================================================================= - (XmlEncoding, xmlEncodingFromString, xmlEncodingToString - ,serializeXml, parseXml - ,pickle, pickleWithEnc, pickleStr, unpickle, unpickleStr, unpickleDocM - ,fromPair,fromTriple,fromQuadruple,fromQuintuple - ,PUCase, xpOne, xpMany, xpTagSwitch, xpCase, xpCaseConst, xpSwitch - ,xpTextFixed - ,_ISO8859_1_, _ISO8859_2_, _ISO8859_3_, _ISO8859_4_, _ISO8859_5_ - ,_ISO8859_6_, _ISO8859_7_, _ISO8859_8_, _ISO8859_9_, _ISO8859_10_ - ,_ISO8859_11_, _ISO8859_13_, _ISO8859_14_, _ISO8859_15_, _ISO8859_16_ - ,_USASCII_, _UCS2_, _UTF8_, _UTF16_, _UTF16BE_, _UTF16LE_, _ISOLATIN1_ - ,_UNICODE_) -where - --- == IMPORTS ================================================================= - ----------------------------------------- --- STDLIB ----------------------------------------- -import Control.Monad (liftM) - -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import Data.List (elemIndex) - ----------------------------------------- --- SITE-PACKAGES ----------------------------------------- -import Control.Arrow.ArrowIf (when) -import Control.Arrow.ArrowList (this,none) -import Control.Arrow.ArrowTree (processChildren, processTopDown) - -import qualified Data.ByteString.Lazy.Char8 as BSLChar - -import Data.Tree.NTree.TypeDefs (NTrees, NTree(..)) - -import Text.XML.HXT.Arrow - ( XmlTree, XmlPickler(..) - ,runLA, constA, (>>>), arr - ,addXmlPi,addXmlPiEncoding,replaceChildren,xshow,mkText,escapeXmlDoc - ,getChildren, xread) - -import Text.XML.HXT.Arrow.Pickle (PU(..), Schema, unpickleDoc, - pickleDoc ,xpElem, xpList, xpAlt, xpWrap, - xpWrapMaybe, xpLift, xpText) -import Text.XML.HXT.Arrow.Pickle.Schema (scFixed) -import Text.XML.HXT.Arrow.ParserInterface (parseXmlDoc,substXmlEntityRefs) -import Text.XML.HXT.Arrow.Edit (canonicalizeContents, removeDocWhiteSpace - ,transfAllCharRef, indentDoc) -import Text.XML.HXT.Arrow.GeneralEntitySubstitution (processGeneralEntities) -import Text.XML.HXT.Arrow.XmlArrow (root, isPi, hasName) -import Text.XML.HXT.Arrow.DocumentOutput (encodeDocument') -import Text.XML.HXT.DOM.TypeDefs (XNode(..)) -import Text.XML.HXT.DOM.XmlKeywords - (t_xml - ,iso8859_1, iso8859_2, iso8859_3, iso8859_4, iso8859_5, iso8859_6 - ,iso8859_7, iso8859_8, iso8859_9, iso8859_10, iso8859_11, iso8859_13 - ,iso8859_14, iso8859_15, iso8859_16, usAscii, ucs2, utf8, utf16, utf16be - ,utf16le, unicodeString, isoLatin1) -import Text.XML.HXT.Arrow.Namespace (propagateNamespaces, validateNamespaces) - ----------------------------------------- --- LOCAL ----------------------------------------- -import Data.HttpSpec.MiscHelper (maybeToM) - --- == TYPES =================================================================== - -newtype XmlEncoding = XmlEncoding { xmlEncodingName :: String } deriving (Eq) - - -instance Show XmlEncoding where - show (XmlEncoding name) = name - -_UNICODE_ = XmlEncoding unicodeString -_ISO8859_1_ = XmlEncoding iso8859_1 -_ISO8859_2_ = XmlEncoding iso8859_2 -_ISO8859_3_ = XmlEncoding iso8859_3 -_ISO8859_4_ = XmlEncoding iso8859_4 -_ISO8859_5_ = XmlEncoding iso8859_5 -_ISO8859_6_ = XmlEncoding iso8859_6 -_ISO8859_7_ = XmlEncoding iso8859_7 -_ISO8859_8_ = XmlEncoding iso8859_8 -_ISO8859_9_ = XmlEncoding iso8859_9 -_ISO8859_10_ = XmlEncoding iso8859_10 -_ISO8859_11_ = XmlEncoding iso8859_11 -_ISO8859_13_ = XmlEncoding iso8859_13 -_ISO8859_14_ = XmlEncoding iso8859_14 -_ISO8859_15_ = XmlEncoding iso8859_15 -_ISO8859_16_ = XmlEncoding iso8859_16 -_USASCII_ = XmlEncoding usAscii -_UCS2_ = XmlEncoding ucs2 -_UTF8_ = XmlEncoding utf8 -_UTF16_ = XmlEncoding utf16 -_UTF16BE_ = XmlEncoding utf16be -_UTF16LE_ = XmlEncoding utf16le -_ISOLATIN1_ = XmlEncoding isoLatin1 - - --- == ENCODING FUNCTIONS ====================================================== - -xmlEncodingFromString :: String -> Either String XmlEncoding -xmlEncodingFromString name = - case map toLower name of - "latin1" -> return _ISOLATIN1_ - "latin9" -> return _ISO8859_15_ - "iso-8859-1" -> return _ISO8859_1_ - "iso-8859-2" -> return _ISO8859_2_ - "iso-8859-3" -> return _ISO8859_3_ - "iso-8859-4" -> return _ISO8859_4_ - "iso-8859-5" -> return _ISO8859_5_ - "iso-8859-6" -> return _ISO8859_6_ - "iso-8859-7" -> return _ISO8859_7_ - "iso-8859-8" -> return _ISO8859_8_ - "iso-8859-9" -> return _ISO8859_9_ - "iso-8859-10" -> return _ISO8859_10_ - "iso-8859-11" -> return _ISO8859_11_ - "iso-8859-13" -> return _ISO8859_13_ - "iso-8859-14" -> return _ISO8859_14_ - "iso-8859-15" -> return _ISO8859_15_ - "utf8" -> return _UTF8_ - "utf-8" -> return _UTF8_ - "utf16" -> return _UTF16_ - "utf-16" -> return _UTF16_ - "ascii" -> return _USASCII_ - "us-ascii" -> return _USASCII_ - "unicode" -> return _UNICODE_ - _ -> fail $ "Can't parse unsupported XmlEncoding name `" ++ name ++ "'." - -xmlEncodingToString :: XmlEncoding -> String -xmlEncodingToString = show - --- == XML FUNCTIONS =========================================================== - -xpOne :: PU a -> PU a -xpOne = id - -xpMany :: String -> PU a -> PU [a] -xpMany root pu = xpElem root (xpList pu) - -pickle :: PU a -> a -> BSLChar.ByteString -pickle pu = serializeXml _UTF8_ . pickleDoc pu - -pickleWithEnc :: XmlEncoding -> PU a -> a -> BSLChar.ByteString -pickleWithEnc enc pu = serializeXml' noProlog enc . pickleDoc pu - where noProlog = enc == _UNICODE_ - -unpickle :: Monad m => PU a -> BSLChar.ByteString -> m a -unpickle pu bsl = parseXml True True bsl >>= unpickleDocM pu - -pickleStr :: PU a -> a -> String -pickleStr pu = BSLChar.unpack . pickleWithEnc _UNICODE_ pu - -unpickleDocM :: Monad m => PU a -> XmlTree -> m a -unpickleDocM pu = maybeToM "Unpickling failed." . unpickleDoc pu - -unpickleStr pu = unpickle pu . BSLChar.pack - -serializeXml :: XmlEncoding -> XmlTree -> BSLChar.ByteString -serializeXml enc xml = serializeXml' False enc xml - -serializeXml' :: Bool -> XmlEncoding -> XmlTree -> BSLChar.ByteString -serializeXml' indent enc xml = - let [str] = runLA (constA xml >>> encodeA) undefined - in (BSLChar.pack (strip str)) - where rmpi = enc == _UNICODE_ - encodeA = - (if indent then processChildren indentDoc else this) - >>> - escapeXmlDoc - >>> - encodeDocument' rmpi (xmlEncodingName enc) - >>> - replaceChildren (xshow getChildren >>> arr encode >>> mkText) - >>> - xshow getChildren - encode = id - strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace - isSpace = (`elem` " \n\t") - - -parseXml :: Monad m => Bool -> Bool -> BSLChar.ByteString -> m XmlTree -parseXml rmpi rmspace bstr = - let trees = runLA pipe undefined - in case trees of - [] -> fail "empty result" - (NTree _ ((NTree (XError _ msg) _) : _) : _) -> fail msg - trees -> return (last trees) - where str = BSLChar.unpack bstr - pipe = root [] [] - >>> replaceChildren parse - >>> (if rmpi then removeXmlPi else this) - >>> (if rmspace then removeDocWhiteSpace else this) - parse = constA ("urn:Data.ByteString", str) - >>> parseXmlDoc - >>> substXmlEntityRefs - >>> canonicalizeContents - -- >>> propagateNamespaces - -removeXmlPi = processTopDown (none `when` (isPi >>> hasName t_xml)) - -fromPair :: (a -> b -> c) -> (a, b) -> c -fromPair f ~(a, b) = f a b - -fromTriple :: (a -> b -> c -> d) -> (a, b, c) -> d -fromTriple f ~(a, b, c) = f a b c - -fromQuadruple :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e -fromQuadruple f ~(a, b, c, d) = f a b c d - -fromQuintuple :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f -fromQuintuple f ~(a, b, c, d, e) = f a b c d e - -data PUCase a = PUCase { case_value :: a - , case_spec :: PU a } - -xpCase :: (a -> b, b -> a) -> PU a -> PUCase b -xpCase wrapfuns@(aToB,_bToA) specA = PUCase value spec - where value = aToB (error "xpCase: tagging function requires evaluation") - spec = xpWrap wrapfuns specA - -xpCaseConst :: a -> PU () -> PUCase a -xpCaseConst a pu = xpCase (const a, const undefined) pu - where undef = error "xpCaseConst: this value should have been ignored" - -xpSwitch :: Show a => [PUCase a] -> PU a -xpSwitch = xpTagSwitch (takeWhile (/= ' ') . show) - -xpTagSwitch :: Eq t => (a -> t) -> [PUCase a] -> PU a -xpTagSwitch tag cases = xpAlt idx (map case_spec cases) - where idx = fromMaybe err . flip elemIndex tags . tag - err = error $ "xpTagSwitch: no case matched" - tags = map (tag . case_value) cases - -xpTextFixed :: String -> PU () -xpTextFixed text = - (xpWrapMaybe (\t -> if t == text then Just () else Nothing, const text) - xpText) { theSchema = scFixed text }