module Factis.Haskoon.HttpSpec.SendRecv (getReqIn, sendReqOut, sendResOut, forwardReq) where
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)
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)
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
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`
( \(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)
-> (ResIn -> m ResOut)
-> 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