module Factis.Haskoon.WebCGI (WebCGI, runFastCgi, runFastWebCGI
,runWebCGI, runWebCGIResult) where
import Control.Arrow (first)
import Control.Concurrent (forkIO)
import Control.Monad (MonadPlus, liftM, mplus)
import Control.Monad.Trans (MonadTrans(lift))
import Control.Monad.Reader (MonadReader(local),ReaderT(runReaderT),asks)
import Control.Monad.Error (ErrorT(..), throwError)
import Data.Char (toLower)
import Data.Maybe (fromMaybe, maybeToList)
import Data.List (isPrefixOf)
import Network.CGI.Monad (MonadCGI(..))
import Network.CGI as CGI
import Network.URI (parseRelativeReference)
import Network.FastCGI (runFastCGIConcurrent')
import System.Log.Logger (getRootLogger, saveGlobalLogger, setLevel, addHandler
,Priority(..), logM)
import System.Log.Handler.Syslog (openlog,Facility(..))
import Control.Monad.Maybe (MaybeT(..))
import qualified Data.ByteString.Lazy.Char8 as BSLChar
import Factis.Haskoon.Web
import Factis.Haskoon.WebHelper
data WebData = WebData { webd_repls :: [String] }
webd_repls_set :: [String] -> WebData -> WebData
webd_repls_set r wd = wd { webd_repls = r }
newtype WebCGI m a = WebCGI { unWebCGI :: ReaderT WebData (ErrorT String m) a}
deriving (Monad, MonadIO)
inWebCGI :: ReaderT WebData (ErrorT String m) a -> WebCGI m a
inWebCGI x = WebCGI x
liftCGI :: (MonadIO m, MonadCGI m) =>
(forall m'. (MonadIO m', MonadCGI m') => m' a)
-> WebCGI m a
liftCGI cgi = inWebCGI (lift (lift cgi))
instance (MonadIO m, MonadCGI m) => Web (WebCGI m) where
type WebRes (WebCGI m) = CGI.CGIResult
webPathInfo = liftCGI CGI.pathInfo
webSendBSL bs = liftCGI (CGI.outputFPS bs)
webSendError code msg =
liftCGI $
do vars <- CGI.getVars
let details = map (\(x,y) -> x ++ ": " ++ y) vars
CGI.outputError code msg details
webLog name prio msg = liftIO (logM name prio msg)
webSetHeader name value = liftCGI (CGI.setHeader name value)
webGetBody =
liftCGI $
do mctype <- CGI.requestContentType
let ctype = parseContentType (fromMaybe "text/plain" mctype)
case ctype of
Just (ContentType "application" "x-www-form-urlencoded" _) ->
do inputs <- CGI.getInputs
let body = CGI.formEncode inputs
return (BSLChar.pack body)
Just (ContentType "multipart" "form-data" _ps) -> fail msg
_ -> CGI.getBodyFPS
where
msg = "Content-Type multipart/form-data not supported by WebCGI."
webGetParams = liftCGI CGI.getInputs
webGetHeaders =
liftCGI $
do vars <- liftM (filter (\(k,_) -> "HTTP_" `isPrefixOf` k)) CGI.getVars
mctype <- CGI.requestContentType
let varToHdr = first $ map toLower . replaceCh '_' '-' . drop 5
hs = maybeToList (fmap ((,) "content-type") mctype)
++ map varToHdr vars
return hs
webGetRepls = inWebCGI (asks webd_repls)
webWithRepls r (WebCGI cont) = inWebCGI (local (webd_repls_set r) cont)
webFail msg = inWebCGI (throwError msg)
webDocumentRoot =
do mdocroot <- liftCGI (CGI.getVar "DOCUMENT_ROOT")
case mdocroot of
Nothing -> webFail "CGI variable `DOCUMENT_ROOT' not set."
Just value -> return value
webRequestUri =
liftCGI $
do let varname = "REDIRECT_REQUEST_URI"
mreq <- liftM (>>= parseRelativeReference) $ getVar varname
case mreq of
Just req -> return req
Nothing ->
do reqUri <- CGI.requestURI
return reqUri
webContainerUri = liftCGI CGI.progURI
webGetCookies = liftCGI (liftM parseVar (CGI.getVar "HTTP_COOKIE"))
where parseVar = readCookies . fromMaybe ""
webSetCookie aCookie = liftCGI (CGI.setCookie aCookie)
webUnsetCookie aCookie = liftCGI (CGI.deleteCookie aCookie)
webMethod = liftCGI CGI.requestMethod
webSetStatus code mmsg = liftCGI (CGI.setStatus code $ fromMaybe "n/a" msg)
where msg = mmsg `mplus` lookup code statusCodeMessageMap
instance MonadCGI m => MonadCGI (MaybeT m) where
cgiAddHeader n v = lift (cgiAddHeader n v)
cgiGet f = lift (cgiGet f)
instance (MonadCGI m, MonadIO m) => WebIO (WebCGI m)
initialWebData :: WebData
initialWebData = WebData []
runWebCGI :: (MonadCGI m, MonadIO m) => WebCGI m a -> m (Either String a)
runWebCGI webCGI =
let readerT = unWebCGI webCGI
errorT = runReaderT readerT initialWebData
base = runErrorT errorT
in base
runWebCGIResult :: (MonadIO m, MonadCGI m) =>
WebCGI m (WebRes (WebCGI m))
-> m CGIResult
runWebCGIResult webCGI =
let cgiResOrErr = runWebCGI webCGI
cgi = do result <- cgiResOrErr
case result of
Left msg -> CGI.outputError 500 msg [""]
Right res -> return res
in cgi
runFastWebCGI :: String -> WebWebRes (WebCGI (CGIT IO)) -> IO ()
runFastWebCGI name webCGI = runFastCgi name (runWebCGIResult webCGI)
runFastCgi :: String -> CGIT IO CGIResult -> IO ()
runFastCgi name cgi =
do logger <- getRootLogger
syslog <- openlog name [] USER DEBUG
saveGlobalLogger (addHandler syslog (setLevel DEBUG logger))
logM name NOTICE (name ++ " FastCGI process started.")
runFastCGIConcurrent' forkIO 10 cgi
replaceCh :: Char -> Char -> String -> String
replaceCh from to s = map replChar s
where replChar ch | ch == from = to
| otherwise = ch