module Factis.Haskoon.Web
(Web(..),WebIO,FromRq(..),ToWebRes(..), WebWebRes, WebRec(..)
,webRepl,webOk,webNotFound,webFileNotFound,webBadRequest
,webSendString,webGetCookie,webRedirect,webWithData,webCheckData
,webSendFile, notEmpty, optional
,webLogNotice,webLogTrace,webLogDebug
,Cookie(..), newCookie, findCookie, deleteCookie, showCookie, readCookies
,
) where
import Control.Monad (MonadPlus(mplus), liftM)
import Control.Monad.Trans (MonadIO,liftIO)
import Data.Char (toLower)
import Data.List (find, isSuffixOf)
import System.FilePath.Posix ((</>))
import System.Directory (doesFileExist)
import System.Log.Logger (Priority(..))
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import qualified Data.ByteString.Lazy as BSL
import Network.URI (URI)
import Network.CGI.Cookie (Cookie(..), newCookie, findCookie, deleteCookie
,showCookie, readCookies)
import Factis.Haskoon.RqAccess (FromRq(..))
import Factis.Haskoon.RqAccessM (RqData(..), runRqAccessM)
type WebParams = [(String,String)]
type WebHeaders = [(String,String)]
type WebCookies = [(String,String)]
data WebRec m
= WebRec
{ web_documentRoot :: m FilePath
, web_containerUri :: m URI
, web_requestUri :: m URI
, web_pathInfo :: m String
, web_method :: m String
, web_getBody :: m BSL.ByteString
, web_getParams :: m WebParams
, web_getHeaders :: m WebHeaders
, web_getCookies :: m WebCookies
, web_setStatus :: Int -> Maybe String -> m ()
, web_sendBSL :: BSL.ByteString -> m (WebRes m)
, web_setHeader :: String -> String -> m ()
, web_setCookie :: Cookie -> m ()
, web_unsetCookie :: Cookie -> m ()
, web_log :: String -> Priority -> String -> m ()
, web_getRepls :: m [String]
, web_fail :: forall a. String -> m a
, web_withRepls :: forall a. [String] -> m a -> m a
}
class Monad m => Web m where
type WebRes m
webRec :: WebRec m
webRec = WebRec webDocumentRoot webContainerUri webRequestUri webPathInfo webMethod
webGetBody webGetParams webGetHeaders webGetCookies webSetStatus
webSendBSL webSetHeader webSetCookie webUnsetCookie webLog
webGetRepls webFail webWithRepls
webDocumentRoot :: m FilePath
webDocumentRoot = web_documentRoot webRec
webContainerUri :: m URI
webContainerUri = web_containerUri webRec
webRequestUri :: m URI
webRequestUri = web_requestUri webRec
webPathInfo :: m String
webPathInfo = web_pathInfo webRec
webMethod :: m String
webMethod = web_method webRec
webGetBody :: m BSL.ByteString
webGetBody = web_getBody webRec
webGetParams :: m WebParams
webGetParams = web_getParams webRec
webGetHeaders :: m WebHeaders
webGetHeaders = web_getHeaders webRec
webGetCookies :: m WebCookies
webGetCookies = web_getCookies webRec
webSetStatus :: Int -> Maybe String -> m ()
webSetStatus = web_setStatus webRec
webSendBSL :: BSL.ByteString -> m (WebRes m)
webSendBSL = web_sendBSL webRec
webSetHeader :: String -> String -> m ()
webSetHeader = web_setHeader webRec
webSetCookie :: Cookie -> m ()
webSetCookie = web_setCookie webRec
webUnsetCookie :: Cookie -> m ()
webUnsetCookie = web_unsetCookie webRec
webLog :: String -> Priority -> String -> m ()
webLog = web_log webRec
webGetRepls :: m [String]
webGetRepls = web_getRepls webRec
webWithRepls :: [String] -> m a -> m a
webWithRepls = web_withRepls webRec
webFail :: String -> m a
webFail = web_fail webRec
webRunFromRq :: FromRq a => m (Either String a)
webRunFromRq =
do meth <- webMethod
headers <- webGetHeaders
repls <- webGetRepls
params <- webGetParams
cookies <- webGetCookies
let rqdata = RqData meth params headers repls cookies
return (runRqAccessM fromRq rqdata)
webSendError :: Int -> String -> m (WebRes m)
webSendError status msg =
do webSetStatus status Nothing
webSetHeader "Content-Type" "text/plain; charset=UTF-8"
webSendBSL (BSLU.fromString msg)
webGetHeader :: String -> m (Maybe String)
webGetHeader n = liftM lookup' webGetHeaders
where lookup' = fmap snd . find ((==map toLower n) . map toLower . fst)
webGetParam :: String -> m (Maybe String)
webGetParam n = liftM (lookup n) webGetParams
type WebWebRes m = m (WebRes m)
webRepl :: Web m => Int -> m String
webRepl i = liftM (!! i) webGetRepls
webOk :: (Web m, ToWebRes a) => a -> m (WebRes m)
webOk = toWebRes
webNotFound :: Web m => [Char] -> m (WebRes m)
webNotFound name = webSendError 404 ("Not found: " ++ name)
webFileNotFound :: Web m => [Char] -> m (WebRes m)
webFileNotFound fpath = webSendError 404 ("File not found: " ++ fpath)
webBadRequest :: Web m => [Char] -> m (WebRes m)
webBadRequest msg = webSendError 401 ("Bad Request: " ++ msg)
webSendString :: Web m => String -> m (WebRes m)
webSendString str = webOk str
webGetCookie :: Web m => String -> m (Maybe String)
webGetCookie n = liftM (lookup n) webGetCookies
webRedirect :: Web m => Bool -> String -> m (WebRes m)
webRedirect temp url =
do webSetHeader "Location" url
webSetHeader "Content-Type" "text/plain; charset=UTF-8"
webSetStatus (if temp then 302 else 301) Nothing
webSendBSL (BSLU.fromString $ "Redirecting to "++url++".")
_LOGNAME_ :: [Char]
_LOGNAME_ = "Web"
webLogNotice, webLogDebug, webLogTrace :: Web m => String -> m ()
webLogNotice = webLog _LOGNAME_ NOTICE
webLogDebug = webLog _LOGNAME_ INFO
webLogTrace = webLog _LOGNAME_ DEBUG
class (MonadIO m, Web m) => WebIO m
notEmpty :: Monad m => m String -> m String
notEmpty m = m >>= \x -> if x == "" then fail "empty string" else return x
optional :: MonadPlus m => m a -> m (Maybe a)
optional action = liftM Just action `mplus` return Nothing
webWithData :: (Web m, FromRq a) => (a -> m (WebRes m)) -> m (WebRes m)
webWithData cont = webCheckData cont webBadRequest
webCheckData :: (Web m, FromRq a) =>
(a -> m (WebRes m))
-> (String -> m (WebRes m))
-> m (WebRes m)
webCheckData withData withErr =
do aOrErr <- webRunFromRq
case aOrErr of
Right a -> withData a
Left err -> withErr err
class ToWebRes a where
toWebContentType :: a -> String
toWebBody :: a -> BSL.ByteString
toWebRes :: Web m => a -> m (WebRes m)
toWebRes a =
do webSetHeader "Content-Type" (toWebContentType a)
webSendBSL (toWebBody a)
instance ToWebRes String where
toWebContentType _ = "text/plain"
toWebBody str = BSLU.fromString str
webSendFile :: WebIO m => FilePath -> m (WebRes m)
webSendFile fpath =
do docroot <- webDocumentRoot
let abspath = docroot </> fpath
exists <- liftIO (doesFileExist abspath)
case exists of
True -> do contents <- liftIO (BSL.readFile abspath)
webSetHeader "Content-Type" ctype
webSendBSL contents
False -> webFileNotFound fpath
where ctype | ".html" `isSuffixOf` fpath = "text/html"
| ".css" `isSuffixOf` fpath = "text/css"
| ".js" `isSuffixOf` fpath = "application/x-javascript"
| ".png" `isSuffixOf` fpath = "image/png"
| otherwise = "text/plain"