httpspec 0.1 → 0.3.0.1

raw patch · 7 files changed

+287/−365 lines, 7 filesdep +MissingHdep +hxthelperdep +safedep −Safedep −tagsoupdep ~hxtnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: MissingH, hxthelper, safe

Dependencies removed: Safe, tagsoup

Dependency ranges changed: hxt

API changes (from Hackage documentation)

Files

• httpspec.cabal +10/−7
• src/Data/HttpSpec.hs +167/−54
• src/Data/HttpSpec/EncodingHelper.hs +10/−1
• src/Data/HttpSpec/HttpTypes.hs +96/−21
• src/Data/HttpSpec/MiscHelper.hs +0/−40
• src/Data/HttpSpec/Pretty.hs +4/−2
• src/Data/HttpSpec/XmlHelper.hs +0/−240

@@ -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 <leuschner@openfactis.org> 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

@@ -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}

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 }