haskoon-httpspec (empty) → 0.5.0.1
raw patch · 6 files changed
+549/−0 lines, 6 filesdep +HTTPdep +basedep +bidispecsetup-changed
Dependencies added: HTTP, base, bidispec, bytestring, haskoon, hslogger, httpspec, mtl, network
Files
- LICENSE +165/−0
- Setup.hs +2/−0
- haskoon-httpspec.cabal +21/−0
- src/Factis/Haskoon/HttpSpec/SendRecv.hs +164/−0
- src/Factis/Haskoon/HttpSpec/SpecHandler.hs +77/−0
- src/Factis/Haskoon/HttpSpec/WebHandler.hs +120/−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
+ haskoon-httpspec.cabal view
@@ -0,0 +1,21 @@+Name: haskoon-httpspec+Version: 0.5.0.1+Synopsis: Integrating HttpSpec with Haskoon+Description: Allows to send and receive Http requests using the+ HttpSpec specifications.+License: LGPL+License-file: LICENSE+Category: Web+Author: David Leuschner <leuschner@factisresearch.com>, Dirk Spoeri <spoeri@factisresearch.com>, Stefan Wehr <wehr@factisresearch.com>+Maintainer: David Leuschner <leuschner@factisresearch.com>, Dirk Spoeri <spoeri@factisresearch.com>, Stefan Wehr <wehr@factisresearch.com>+Build-Type: Simple+Cabal-Version: >= 1.2++Library+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Build-Depends: base >= 3 && < 5, HTTP, bytestring, mtl, hslogger >= 1.1.0, network,+ haskoon >= 0.3.0 && < 0.4, bidispec, httpspec >= 0.3 && < 0.4+ Exposed-Modules: Factis.Haskoon.HttpSpec.SpecHandler,+ Factis.Haskoon.HttpSpec.WebHandler+ Factis.Haskoon.HttpSpec.SendRecv
+ src/Factis/Haskoon/HttpSpec/SendRecv.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}+module Factis.Haskoon.HttpSpec.SendRecv (getReqIn, sendReqOut, sendResOut, forwardReq) where++----------------------------------------+-- STDLIB+----------------------------------------+import Prelude hiding (log, catch)++import Data.Char (toLower)++import Control.Monad (liftM, when)+import Control.Monad.Trans (MonadIO,liftIO)+import Control.Exception (SomeException, catch)++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import qualified Data.ByteString.Lazy.Char8 as BSL++import Factis.Haskoon.Web hiding (webLogTrace,webLogDebug,webLogNotice)++import qualified Network.HTTP as Http+import qualified Network.Stream++import System.Log.Logger (Priority(..), debugM, infoM, noticeM)++----------------------------------------+-- LOCAL+----------------------------------------+import Data.HttpSpec.HttpTypes+import Data.HttpSpec.Pretty (ppr)++_LOGNAME_ :: String+_LOGNAME_ ="Factis.Haskoon.HttpSpec.SendRecv"++_DEFAULT_CTYPE_ :: String+_DEFAULT_CTYPE_ = "application/octet-stream"+++webLogTrace, webLogDebug, webLogNotice, webLogWarn :: Web m => String -> m ()+webLogTrace = webLog _LOGNAME_ DEBUG+webLogDebug = webLog _LOGNAME_ INFO+webLogNotice = webLog _LOGNAME_ NOTICE+webLogWarn = webLog _LOGNAME_ WARNING++ioLogTrace, ioLogDebug, ioLogNotice :: MonadIO m => String -> m ()+ioLogTrace = liftIO . debugM _LOGNAME_+ioLogDebug = liftIO . infoM _LOGNAME_+ioLogNotice = liftIO . noticeM _LOGNAME_+++getReqIn :: Web m => m ReqIn+getReqIn =+ do webLogTrace "Reading incoming request..."+ meth <- webMethod+ body <-+ case () of+ () | meth == "POST" ->+ do body <- webGetBody+ when (BSL.length body == 0) $+ webLogWarn "Method is POST but body is empty."+ return body+ | otherwise -> return BSL.empty+ progUri <- webContainerUri+ reqUri <- webRequestUri+ origHs <- webGetHeaders+ let reqMeth | meth == "GET" = Http.GET+ | meth == "POST" = Http.POST+ | meth == "HEAD" = Http.HEAD+ | meth == "PUT" = Http.PUT+ | meth == "DELETE" = Http.DELETE+ | otherwise =+ error $ "haskoon-httpspec/SendRecv: unsupported method "++meth+ mkHdr k v = case Http.parseHeader hdrstr of+ Left _ -> error $ "Not a valid header: " ++ show hdrstr+ Right h -> (Http.hdrName h, Http.hdrValue h)+ where hdrstr = k++": "++v+ reqHs = map (uncurry mkHdr) origHs+ req = (ReqIn progUri reqUri reqMeth (HttpData reqHs body))+ webLogDebug $ "Received request.\n" ++ show (ppr req)+ return req++sendReqOut :: MonadIO m => ReqOut -> m (Either String ResIn)+sendReqOut reqOut@(ReqOut fwdUrl fwdMeth (HttpData hs outBody)) =+ do let url' = show $ reqUrl reqOut+ optBody+ | reqMethod reqOut == Http.POST =+ "with " ++ show (BSL.length (httpBody reqOut)) ++ " bytes "+ ++ case httpGetHeader Http.HdrContentType reqOut of+ Just ctype -> "of " ++ ctype ++ " "+ Nothing -> "without content-type "+ | otherwise = ""+ msg = "Issueing outgoing request " ++ optBody ++ " to " ++ url' ++ "..."+ ioLogNotice msg+ ioLogDebug $ "HTTP request is:\n" ++ show (ppr reqOut)+ let clen = BSL.length outBody+ hs' = case lookup Http.HdrContentType hs of+ -- Network.CGI doesn't read requests without content-type+ Just _ -> hs+ Nothing -> (Http.HdrContentType,_DEFAULT_CTYPE_) : hs+ hs'' = case lookup Http.HdrContentLength hs' of+ Just _ -> hs'+ Nothing -> (Http.HdrContentLength,show clen):hs'+ fwdHs = map (uncurry Http.Header) hs''+ fwdBody = outBody+ req = Http.Request fwdUrl fwdMeth fwdHs fwdBody+ result <- liftIO $ Http.simpleHTTP req+ `catch` -- workaround for a bug in the HTTP lib+ ( \(e::SomeException) ->+ return $ Left $ Network.Stream.ErrorMisc (show e))+ case result of+ Left errmsg ->+ do ioLogNotice $ "Request failed! " ++ show errmsg+ return (Left $ show errmsg)+ Right resp ->+ do let status = show (resCode httpRes) ++ " " ++ resReason httpRes+ optCType =+ case httpGetHeader Http.HdrContentType httpRes of+ Just ctype -> "of " ++ ctype ++ " "+ Nothing -> ""+ size = show (BSL.length (httpBody httpRes))+ msg' = "Received " ++ status ++ " response "+ ++ "with " ++ size ++ " bytes " ++ optCType+ ++ "for " ++ show fwdUrl+ ioLogNotice msg'+ ioLogDebug $ "Received HTTP response is:\n" ++ show (ppr httpRes)+ ioLogTrace (show httpRes)+ return (Right httpRes)+ where+ httpRes = ResIn retCode reason (HttpData resHs body)+ body = Http.rspBody resp+ reason = Http.rspReason resp+ mkCode (x,y,z) = x*100+y*10+z+ retCode = mkCode (Http.rspCode resp)+ resHs = [(n,v) | Http.Header n v <- Http.rspHeaders resp]++sendResOut :: Web m => ResOut -> m (WebRes m)+sendResOut resOut@(ResOut retCode mreason (HttpData retHs retBody)) =+ do reqUri <- liftM show webRequestUri+ webLogNotice $ "Sending response for " ++ reqUri ++ ":\n"+ ++ show (ppr resOut)+ webSetStatus retCode mreason+ sequence_ [webSetHeader (map toLower (show hn)) v | (hn,v) <- retHs]+ webSendBSL retBody++forwardReq :: WebIO m =>+ (ReqIn -> m ReqOut) -- wie in ICAP REQMOD+ -> (ResIn -> m ResOut) -- wie in ICAP RESPMOD+ -> m (WebRes m)+forwardReq modReq modRes =+ do reqIn <- getReqIn+ webLogNotice $ "Modifying incoming request..."+ reqOut <- modReq reqIn+ reqResult <- sendReqOut reqOut+ case reqResult of+ Left errmsg ->+ do webLogWarn errmsg+ webSendError 500 errmsg+ Right resIn ->+ do webLogNotice $ "Modifying response..."+ resOut <- modRes resIn+ cgiResult <- sendResOut resOut+ webLogNotice "Done"+ return cgiResult
+ src/Factis/Haskoon/HttpSpec/SpecHandler.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts #-}++module Factis.Haskoon.HttpSpec.SpecHandler+ ( matchBySpec, matchByReqSpec, rawSendBySpec, sendBySpec, rawSendToUrl, sendToUrl+ , rhSendReq, rhParseResIn, rhGenReqOut, rhParseUrl+) where++----------------------------------------+-- STDLIB+----------------------------------------+import Control.Monad.Error (MonadError(..))++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import Data.HttpSpec (HasReqSpec(..),HasResSpec(..),ResSpec,ReqSpec,WebExc(..)+ ,webExcSetResIn, webExcSetReqOut+ ,parseReqIn,genResOut,parseResIn,genReqOut)+import Data.HttpSpec.HttpTypes (HttpUrl,ReqIn(..),ReqOut(..),ResIn(..),ResOut(..))++import qualified Network.URI as Uri++----------------------------------------+-- LOCAL+----------------------------------------+import Factis.Haskoon.HttpSpec.WebHandler (ReqHandler(..))++matchBySpec :: (MonadError WebExc m, HasReqSpec a, HasResSpec b) =>+ (a -> m b)+ -> ReqIn+ -> m ResOut+matchBySpec fun reqIn = parseReqIn reqSpec reqIn >>= fun >>= genResOut resSpec++matchByReqSpec :: (MonadError WebExc m, HasReqSpec a) =>+ (a -> m ResOut)+ -> ReqIn+ -> m ResOut+matchByReqSpec fun reqIn = parseReqIn reqSpec reqIn >>= fun+++rhParseResIn :: ReqHandler m => ResSpec a -> ResIn -> m a+rhParseResIn resInSpec resIn =+ catchError (parseResIn resInSpec resIn) (throwError . webExcSetResIn resIn)++rhGenReqOut :: ReqHandler m => HttpUrl -> ReqSpec a -> a -> m ReqOut+rhGenReqOut baseUrl reqOutSpec a = genReqOut reqOutSpec baseUrl a++rhSendReq :: ReqHandler m => ReqOut -> m ResIn+rhSendReq reqOut =+ catchError (sendReq reqOut) (throwError . webExcSetReqOut reqOut)++rhParseUrl :: ReqHandler m => String -> m HttpUrl+rhParseUrl baseUrlStr =+ case Uri.parseURI baseUrlStr of+ Just uri -> return uri+ Nothing -> fail msg+ where msg = ("SpecHandler: Invalid base URI: `" ++ baseUrlStr ++ "'")++sendBySpec :: (HasReqSpec a, HasResSpec b, ReqHandler m) => HttpUrl -> a -> m b+sendBySpec baseUrl a =+ do resIn <- rawSendBySpec baseUrl a+ rhParseResIn resSpec resIn++rawSendBySpec :: (HasReqSpec a, ReqHandler m) => HttpUrl -> a -> m ResIn+rawSendBySpec baseUrl a =+ do reqOut <- rhGenReqOut baseUrl reqSpec a+ rhSendReq reqOut++rawSendToUrl :: (HasReqSpec a, ReqHandler m) => String -> a -> m ResIn+rawSendToUrl baseUrlStr a =+ do baseUrl <- rhParseUrl baseUrlStr+ rawSendBySpec baseUrl a++sendToUrl :: (HasReqSpec a, HasResSpec b, ReqHandler m) => String -> a -> m b+sendToUrl baseUrlStr a =+ do resIn <- rawSendToUrl baseUrlStr a+ rhParseResIn resSpec resIn
+ src/Factis/Haskoon/HttpSpec/WebHandler.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Factis.Haskoon.HttpSpec.WebHandler+ (ReqHandler(..), ReqHandlerT(..), ReqHandlerState(..)+ ,runWebReq, runWebReqHandlerT, runReqHandlerT, runIOReqHandlerT, match)+where++----------------------------------------+-- STDLIB+----------------------------------------+import Control.Monad (liftM)+import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)+import Control.Monad.Error (MonadError(..), ErrorT(..))+import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import Factis.Haskoon.Web (Web(..),WebIO,webBadRequest)+import Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec)++----------------------------------------+-- LOCAL+----------------------------------------+import Data.HttpSpec (WebExc(..),WebComm(..),WebIn(..),WebErr(..))+import Data.HttpSpec.HttpTypes (ReqIn(..),ReqOut(..),ResIn(..),ResOut(..)+ ,urlMatchPrefix')+import Factis.Haskoon.HttpSpec.SendRecv (getReqIn, sendResOut, sendReqOut)+++class MonadError WebExc m => ReqHandler m where+ sendReq :: ReqOut -> m ResIn++data ReqHandlerState m+ = ReqHandlerState+ { rhst_sendReqOut :: ReqOut -> m (Either String ResIn)+ }++newtype ReqHandlerT m a+ = ReqHandlerT+ { unReqHandlerT :: ReaderT (ReqHandlerState m) (ErrorT WebExc m) a }+ deriving (Monad)++instance Monad m => MonadError WebExc (ReqHandlerT m) where+ throwError err = ReqHandlerT (throwError err)+ catchError (ReqHandlerT action') handler =+ ReqHandlerT (catchError action' handler')+ where handler' err = let ReqHandlerT result = handler err in result++instance MonadIO m => MonadIO (ReqHandlerT m) where+ liftIO m = ReqHandlerT (liftIO m)++instance MonadTrans ReqHandlerT where+ lift m = ReqHandlerT (lift (lift m))++instance WebTrans ReqHandlerT where+ liftWeb = ReqHandlerT . lift . lift+ liftWebFun f cont =+ ReqHandlerT $+ do st <- ask+ res <- lift (lift (f (runReqHandlerT cont st)))+ case res of+ Left msg -> lift (throwError msg)+ Right x -> return x++instance Web m => Web (ReqHandlerT m) where+ type WebRes (ReqHandlerT m) = WebRes m+ webRec = liftWebRec (liftM id) webRec++liftRdr :: ReaderT (ReqHandlerState m) (ErrorT WebExc m) a -> ReqHandlerT m a+liftRdr rdr = ReqHandlerT rdr++instance MonadIO m => ReqHandler (ReqHandlerT m) where+ sendReq rout =+ do sro <- liftRdr (asks rhst_sendReqOut)+ res <- lift (sro rout)+ case res of+ Left err -> fail err+ Right result -> return result++runReqHandlerT :: Monad m =>+ ReqHandlerT m a+ -> ReqHandlerState m+ -> m (Either WebExc a)+runReqHandlerT rh st = runErrorT $ flip runReaderT st $ unReqHandlerT rh++runWebReqHandlerT :: WebIO m => ReqHandlerT m a -> m (Either WebExc a)+runWebReqHandlerT = runIOReqHandlerT++runIOReqHandlerT :: MonadIO m => ReqHandlerT m a -> m (Either WebExc a)+runIOReqHandlerT = flip runReqHandlerT rhState+ where rhState = ReqHandlerState sendReqOut++runWebReq :: WebIO m => (ReqIn -> ReqHandlerT m ResOut) -> m (WebRes m)+runWebReq handler =+ do reqIn <- getReqIn+ case urlMatchPrefix' (reqIn_progUrl reqIn) (reqIn_fullUrl reqIn) of+ Just url ->+ do let reqIn' = reqIn { reqIn_fullUrl = url }+ res <- runWebReqHandlerT (handler reqIn')+ case res of+ Left err -> webBadRequest (show err)+ Right resOut -> sendResOut resOut+ Nothing -> webBadRequest $ "progUrl has to be prefix of fullUrl!"++match :: MonadError WebExc m => [ReqIn -> m ResOut] -> ReqIn -> m ResOut+match [] reqIn = throwError (WebExc comm err)+ where err = WebErrNoMatch reqIn+ comm = Just $ WebCommIn (WebIn (Just reqIn) Nothing)+match (f:fs) reqIn = catchError (f reqIn) handler+ where cont = match fs reqIn+ handler exc@(WebExc _ err) =+ case err of+ WebErrNoMatch {} -> cont+ WebErrInvalidUrl {} -> cont+ WebErrInvalidMethod {} -> cont+ _ -> throwError exc