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(ask,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(..), CGIT)
import Network.CGI.Cookie (readCookies)
import Network.CGI as CGI
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.WebRqAccessM
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 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)
webRunFromRq =
do meth <- webMethod
headers <- webGetHeaders
repls <- webGetRepls
params <- webGetParams
cookies <- webGetCookies
let rqdata = RqData meth params headers repls cookies
return (runRqAccessM fromRq rqdata)
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 CGI.requestURI
webContainerUri = liftCGI CGI.progURI
webGetCookies = liftCGI (liftM parseVar (CGI.getVar "HTTP_COOKIE"))
where parseVar = readCookies . fromMaybe ""
webSetCookie cookie = liftCGI (CGI.setCookie cookie)
webUnsetCookie cookie = liftCGI (CGI.deleteCookie cookie)
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 []
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
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")
]
replaceCh :: Char -> Char -> String -> String
replaceCh from to s = map replChar s
where replChar ch | ch == from = to
| otherwise = ch