{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} 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 ---------------------------------------- -- STDLIB ---------------------------------------- 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) ---------------------------------------- -- SITE-PACKAGES ---------------------------------------- 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) ---------------------------------------- -- LOCAL ---------------------------------------- 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 } -- | You may either define @webRec@ or all of @webDocumentRoot@, -- @webContainerUri@, @webPathInfo@, @webMethod@, @webGetBody@, -- @webGetParams@, @webGetHeaders@, @webGetCookies@, @webSetStatus@, -- @webSendBSL@, @webSetHeader@, @webSetCookie@, @webUnsetCookie@, -- @webLog@ and @webGetRepls@, @webWithRepls@ and @webFail@. class Monad m => Web m where type WebRes m -- record-based implementation of most instance methods webRec :: WebRec m webRec = WebRec webDocumentRoot webContainerUri webRequestUri webPathInfo webMethod webGetBody webGetParams webGetHeaders webGetCookies webSetStatus webSendBSL webSetHeader webSetCookie webUnsetCookie webLog webGetRepls webFail webWithRepls -- general webDocumentRoot :: m FilePath webDocumentRoot = web_documentRoot webRec webContainerUri :: m URI webContainerUri = web_containerUri webRec -- request 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 -- response 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 -- special control methods 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 -- default methods that may be overridden 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)) -- continuation with request data -> (String -> m (WebRes m)) -- continuation without data -> 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"