SendRecv.hs

{-# 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