httpspec (empty) → 0.1
raw patch · 9 files changed
+1149/−0 lines, 9 filesdep +HTTPdep +Safedep +basesetup-changed
Dependencies added: HTTP, Safe, base, bidispec, bytestring, cgi, containers, encoding, filepath, hxt, mtl, network, pretty, tagsoup
Files
- LICENSE +165/−0
- Setup.hs +2/−0
- httpspec.cabal +64/−0
- src/Data/HttpSpec.hs +245/−0
- src/Data/HttpSpec/EncodingHelper.hs +33/−0
- src/Data/HttpSpec/HttpTypes.hs +350/−0
- src/Data/HttpSpec/MiscHelper.hs +40/−0
- src/Data/HttpSpec/Pretty.hs +10/−0
- src/Data/HttpSpec/XmlHelper.hs +240/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ httpspec.cabal view
@@ -0,0 +1,64 @@+Name: httpspec+Version: 0.1+Synopsis: Specification of HTTP request/response generators and parsers+License: LGPL+License-file: LICENSE+Author: David Leuschner+Maintainer: David Leuschner <leuschner@openfactis.org>+Category: Data, Web+Description:+ Using httpspec you can write a specification for a HTTP request/response+ defining the method, headers, url parameters and the body. This+ specification bidirectionally maps an abstract request/response data+ type to a concrete realisation as a HTTP request/response. The+ specification can be used to generate HTTP requests/responses from an+ abstract description and it can be used to parse a HTTP request/response+ into such an abstract description. The idea is very similar to the way+ pickling of XML data is described in HXT.++ For example, the abstract representation of an authentication request+ and response could be described as++ data AuthUserReq+ = AuthUserReq+ { authUser_user :: String+ , authUser_pass :: String+ }++ data AuthUserRes+ = AuthUserOk { authUserOk_sid :: String }+ | AuthUserFailed++ Using httpspec you can define a mapping between HTTP and these types:++ instance HasReqSpec AuthUserReq where+ reqSpec =+ rsMeth Http.POST $+ rsPath "/authenticate-user" $+ rsWrap (uncurry AuthUserReq, \(AuthUserReq a b) -> (a,b)) $+ rsPair (rsParam "uid") (rsParam "pass")++ instance HasResSpec AuthUserRes where+ resSpec =+ rsSwitch+ [ rsCase (AuthUserOk,authUserOk_sid) $+ rsStatus 200 $+ rsContentType "text/plain" $+ rsEncodingFixed UTF8 $+ rsBody+ , rsCaseConst AuthUserFailed $+ rsStatus 403+ ]+Build-Type: Simple+Cabal-Version: >= 1.2++Library+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ 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+ Exposed-Modules: Data.HttpSpec,Data.HttpSpec.HttpTypes+ Data.HttpSpec.Pretty, Data.HttpSpec.MiscHelper+ Data.HttpSpec.XmlHelper, Data.HttpSpec.EncodingHelper
+ src/Data/HttpSpec.hs view
@@ -0,0 +1,245 @@+{-# 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
+ src/Data/HttpSpec/EncodingHelper.hs view
@@ -0,0 +1,33 @@+module Data.HttpSpec.EncodingHelper (encodingName) where++encodingName :: Show enc => enc -> String+encodingName enc =+ case show enc of+ "UTF8" -> "UTF-8"+ "UTF16" -> "UTF-16"+ "UTF32" -> "UTF-32"+ "ISO88591" -> "ISO-8859-1"+ "ISO88592" -> "ISO-8859-2"+ "ISO88593" -> "ISO-8859-3"+ "ISO88594" -> "ISO-8859-4"+ "ISO88595" -> "ISO-8859-5"+ "ISO88596" -> "ISO-8859-6"+ "ISO88597" -> "ISO-8859-7"+ "ISO88598" -> "ISO-8859-8"+ "ISO88599" -> "ISO-8859-9"+ "ISO885910" -> "ISO-8859-10"+ "ISO885911" -> "ISO-8859-11"+ "ISO885913" -> "ISO-8859-13"+ "ISO885914" -> "ISO-8859-14"+ "ISO885915" -> "ISO-8859-15"+ "ISO885916" -> "ISO-8859-16"+ "CP1250" -> "WINDOWS-1250"+ "CP1251" -> "WINDOWS-1251"+ "CP1252" -> "WINDOWS-1252"+ "CP1253" -> "WINDOWS-1253"+ "CP1254" -> "WINDOWS-1254"+ "CP1255" -> "WINDOWS-1255"+ "CP1256" -> "WINDOWS-1256"+ "CP1257" -> "WINDOWS-1257"+ "CP1258" -> "WINDOWS-1258"+ _ -> "unknown"
+ src/Data/HttpSpec/HttpTypes.hs view
@@ -0,0 +1,350 @@+module Data.HttpSpec.HttpTypes+ (HttpBody, HttpMethod, HttpUrl, HttpCode, HttpReason+ ,HttpHeaderName, HttpHeaderValue, HttpHeader, HttpHeaders+ ,HttpParamName, HttpParamValue, HttpParams+ ,HttpData(..), ReqIn(..), ReqOut(..), ResIn(..), ResOut(..)+ ,IsHttp(..), IsReq(..), IsRes(..)+ ,reqIn_body, reqIn_headers, reqOut_body, reqOut_headers+ ,resIn_body, resIn_headers, resOut_body, resOut_headers+ ,urlParams, urlMatchPrefix, urlMatchPrefix', urlSplit, url+ ,completeReq, completeRes, mkHeaderName)+where++----------------------------------------+-- STDLIB+----------------------------------------+import Data.Char (toLower)+import Data.Maybe (fromMaybe, catMaybes)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List (isPrefixOf)++import Control.Monad (liftM)+import Control.Arrow (first)++import System.FilePath (takeDirectory, (</>))++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import qualified Network.HTTP as Http+import qualified Network.URI as Uri+import qualified Network.CGI as Cgi++import Text.PrettyPrint.HughesPJ (Doc, vcat, ($+$), (<+>), (<>), text, colon+ ,int, empty)++import Safe (headMay)++----------------------------------------+-- LOCAL+----------------------------------------+import Data.HttpSpec.Pretty (Pretty(..))++-- ============================================================================+-- http types+-- ============================================================================++-- URL types+type HttpPath = String+type HttpParamName = String+type HttpParamValue = String+type HttpParams = [(HttpParamName, HttpParamValue)]+type HttpUrl = Uri.URI++-- Http message types+type HttpHeaderName = Http.HeaderName+type HttpHeaderValue = String+type HttpHeader = (HttpHeaderName, String)+type HttpHeaders = [HttpHeader]+type HttpBody = String++-- Request types+type HttpMethod = Http.RequestMethod++-- Response types+type HttpCode = Int+type HttpReason = String+++data HttpData = HttpData { http_headers :: HttpHeaders+ , http_body :: HttpBody+ }+ deriving (Show)++data ReqIn = ReqIn { reqIn_progUrl :: HttpUrl+ , reqIn_fullUrl :: HttpUrl+ , reqIn_method :: HttpMethod+ , reqIn_data :: HttpData+ }+ deriving (Show)+reqIn_body = http_body . reqIn_data+reqIn_headers = http_headers . reqIn_data++data ReqOut = ReqOut { reqOut_url :: HttpUrl+ , reqOut_method :: HttpMethod+ , reqOut_data :: HttpData }+ deriving (Show)+reqOut_body = http_body . reqOut_data+reqOut_headers = http_headers . reqOut_data++data ResIn = ResIn { resIn_code :: HttpCode+ , resIn_reason :: HttpReason+ , resIn_data :: HttpData }+ deriving (Show)+resIn_body = http_body . resIn_data+resIn_headers = http_headers . resIn_data+++data ResOut = ResOut { resOut_code :: HttpCode+ , resOut_reason :: Maybe HttpReason+ , resOut_data :: HttpData }+ deriving (Show)+resOut_body = http_body . resOut_data+resOut_headers = http_headers . resOut_data+++-- ============================================================================+-- helper functions and instances+-- ============================================================================++instance Ord Http.HeaderName where+ compare hn1 hn2 = compare (mapHdr hn1) (mapHdr hn2)+ where mapHdr (Http.HdrCustom l) = Left l+ mapHdr other = Right (show other)++mkHeaderName :: String -> HttpHeaderName+mkHeaderName = Http.HdrCustom++url :: String -> HttpUrl+url s = case Uri.parseURI s of+ Just uri -> uri+ Nothing -> error $ "HttpTypes.url: Invalid URI `" ++ s ++ "'"++urlParams :: HttpUrl -> HttpParams+urlParams uri = Cgi.formDecode $ dropWhile (=='?') (Uri.uriQuery uri)++urlAddParam :: HttpParamName -> HttpParamValue -> HttpUrl -> HttpUrl+urlAddParam n v uri = uri'+ where params = Cgi.formDecode $ dropWhile (=='?') (Uri.uriQuery uri)+ params' = (n,v) : params+ uri' = uri { Uri.uriQuery = '?' : Cgi.formEncode params' }++urlAppendPath :: HttpPath -> HttpUrl -> HttpUrl+urlAppendPath path uri = uri { Uri.uriPath = Uri.uriPath uri ++ 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")@+-- @urlSplit (url "http://svr") == Nothing@+urlSplit :: Monad m => HttpUrl -> m (HttpPath, HttpUrl)+urlSplit uri = liftM mapUri (uriPathSplit $ Uri.uriPath uri)+ where+ mapUri (head, tail) = (head, uri { Uri.uriPath = tail })+ uriPathSplit "" = fail "Empty URL Path."+ uriPathSplit "/" = return ("/", "")+ uriPathSplit ('/':path) = liftM (first ('/':)) (uriPathSplit path)+ uriPathSplit path = return $ span (/='/') path++urlMatchPrefix :: HttpPath -> HttpUrl -> Maybe HttpUrl+urlMatchPrefix s uri+ | s `isPrefixOf` path = Just $ uri { Uri.uriPath = drop (length s) path }+ | otherwise = Nothing+ where path = Uri.uriPath uri+++urlMatchPrefix' :: HttpUrl -> HttpUrl -> Maybe HttpUrl+urlMatchPrefix' prefixUrl = urlMatchPrefix prefixPath+ where prefixPath = Uri.uriPath prefixUrl+++completeReq :: IsHttp req => req -> req+completeReq r = if clen /= 0 then r2 else r+ where+ clen = length (httpBody r)+ r1 | not (httpHasHeader Http.HdrTransferEncoding r)+ && not (httpHasHeader Http.HdrContentLength r)+ = httpSetHeader Http.HdrContentLength (show clen) r+ | otherwise = r+ r2 | not (httpHasHeader Http.HdrContentType r1)+ = httpSetHeader Http.HdrContentType "application/octet-stream" r1+ | otherwise = r1++completeRes :: IsHttp res => res -> res+completeRes = completeReq++-- ============================================================================+-- access helper type classes+-- ============================================================================+++class IsHttp a where+ -- required methods+ httpData :: a -> HttpData+ httpSetData :: a -> HttpData -> a+ -- methods with default implementations+ httpHeaders :: a -> HttpHeaders+ httpHeaders = http_headers . httpData+ httpBody :: a -> HttpBody+ httpBody = http_body . httpData+ httpGetHeader :: HttpHeaderName -> a -> Maybe HttpHeaderValue+ httpGetHeader n x =+ case n 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)+ httpHasHeader :: HttpHeaderName -> a -> Bool+ httpHasHeader n = (/=Nothing) . httpGetHeader n+ httpSetBody :: HttpBody -> a -> a+ httpSetBody body this = httpSetData this (HttpData (httpHeaders this) body)+ httpSetHeaders :: HttpHeaders -> a -> a+ httpSetHeaders hs this = httpSetData this (HttpData hs (httpBody this))+ httpSetHeader :: HttpHeaderName -> HttpHeaderValue -> a -> a+ httpSetHeader name val this = flip httpSetHeaders this .+ Map.toList $+ Map.insert name val $+ Map.fromList (httpHeaders this)++class IsHttp a => IsRes a where+ resCode :: a -> HttpCode+ resSetStatus :: HttpCode -> Maybe HttpReason -> a -> a+ resReason :: a -> HttpReason+ resReason res = fromMaybe def $ lookup (resCode res) statusCodeMessageMap+ where def = ""++class IsHttp a => IsReq a where+ reqMethod :: a -> HttpMethod+ reqUrl :: a -> HttpUrl+ reqSetMethod :: HttpMethod -> a -> a+ reqSetUrl :: HttpUrl -> a -> a+ reqUrlPath :: a -> HttpPath+ reqUrlPath req = Uri.uriPath (reqUrl req)+ reqAppendUrlPath :: HttpPath -> a -> a+ reqAppendUrlPath p req = reqSetUrl (urlAppendPath p (reqUrl req)) req+ reqAddUrlParam :: HttpParamName -> HttpParamValue -> a -> a+ reqAddUrlParam n v r = reqSetUrl (urlAddParam n v (reqUrl r)) r++instance IsHttp HttpData where+ httpData = id+ httpSetData = const++instance IsHttp ReqIn where+ httpData = reqIn_data+ httpSetData this x = this { reqIn_data = x }++instance IsHttp ReqOut where+ httpData = reqOut_data+ httpSetData this x = this { reqOut_data = x }++instance IsHttp ResIn where+ httpData = resIn_data+ httpSetData this x = this { resIn_data = x }++instance IsHttp ResOut where+ httpData = resOut_data+ httpSetData this x = this { resOut_data = x }+++instance IsRes ResIn where+ resCode = resIn_code+ resSetStatus code mr r = r { resIn_reason = fromMaybe (resIn_reason r) mr+ , resIn_code = code }++instance IsRes ResOut where+ resCode = resOut_code+ resSetStatus code mr r = r { resOut_reason = mr+ , resOut_code = code }+++instance IsReq ReqIn where+ reqMethod = reqIn_method+ reqUrl = reqIn_fullUrl+ reqSetMethod meth req = req { reqIn_method = meth }+ reqSetUrl url req = req { reqIn_fullUrl = url }++instance IsReq ReqOut where+ reqMethod = reqOut_method+ reqUrl = reqOut_url+ reqSetMethod meth req = req { reqOut_method = meth }+ reqSetUrl url req = req { reqOut_url = url }+++pprReq :: IsReq req => req -> Doc+pprReq req = ppr (reqMethod req) <+> ppr (reqUrl req) <+> text "HTTP/1.1"+ $+$ ppr (httpData req)++pprRes :: IsRes res => res -> Doc+pprRes res = int (resCode res) <+> text (resReason res) $+$ ppr (httpData res)++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++instance Pretty ReqIn where+ ppr = pprReq++instance Pretty ReqOut where+ ppr = pprReq++instance Pretty ResIn where+ ppr = pprRes++instance Pretty ResOut where+ ppr = pprRes++instance Pretty Http.RequestMethod where+ ppr = text . show+++statusCodeMessageMap :: [(Int, String)]+statusCodeMessageMap =+ [(100, "Continue")+ ,(101, "Switching Protocols")+ ,(200, "OK")+ ,(201, "Created")+ ,(202, "Accepted")+ ,(203, "Non-Authoritative Information")+ ,(204, "No Content")+ ,(205, "Reset Content")+ ,(206, "Partial Content")+ ,(300, "Multiple Choices")+ ,(301, "Moved Permanently")+ ,(302, "Found")+ ,(303, "See Other")+ ,(304, "Not Modified")+ ,(305, "Use Proxy")+ ,(307, "Temporary Redirect")+ ,(400, "Bad Request")+ ,(401, "Unauthorized")+ ,(402, "Payment Required")+ ,(403, "Forbidden")+ ,(404, "Not Found")+ ,(405, "Method Not Allowed")+ ,(406, "Not Acceptable")+ ,(407, "Proxy Authentication Required")+ ,(408, "Request Time-out")+ ,(409, "Conflict")+ ,(410, "Gone")+ ,(411, "Length Required")+ ,(412, "Precondition Failed")+ ,(413, "Request Entity Too Large")+ ,(414, "Request-URI Too Large")+ ,(415, "Unsupported Media Type")+ ,(416, "Requested range not satisfiable")+ ,(417, "Expectation Failed")+ ,(500, "Internal Server Error")+ ,(501, "Not Implemented")+ ,(502, "Bad Gateway")+ ,(503, "Service Unavailable")+ ,(504, "Gateway Time-out")+ ,(505, "HTTP Version not supported")+ ]
+ src/Data/HttpSpec/MiscHelper.hs view
@@ -0,0 +1,40 @@+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
+ src/Data/HttpSpec/Pretty.hs view
@@ -0,0 +1,10 @@+module Data.HttpSpec.Pretty (Pretty(..)) where++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import Text.PrettyPrint.HughesPJ (Doc)+++class Pretty a where+ ppr :: a -> Doc
+ src/Data/HttpSpec/XmlHelper.hs view
@@ -0,0 +1,240 @@+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 }