diff --git a/haskoon.cabal b/haskoon.cabal --- a/haskoon.cabal +++ b/haskoon.cabal @@ -1,5 +1,6 @@ +--*- coding: utf-8 -*-- Name: haskoon -Version: 0.1 +Version: 0.3.1.1 Synopsis: Web Application Abstraction Description: Web Astraction Layer with a binding to CGI providing a simple way to map parameter and header values to data structures (inspired by HAppS) @@ -7,19 +8,28 @@ License: LGPL License-file: LICENSE Category: Web -Author: David Leuschner, Dirk Spöri -Maintainer: David Leuschner +Author: David Leuschner , Dirk Spöri , Stefan Wehr +Maintainer: David Leuschner , Dirk Spöri , Stefan Wehr Build-Type: Simple Cabal-Version: >= 1.2 Library Hs-Source-Dirs: src - GHC-Options: -Wall - Build-Depends: base >= 3 && < 4, bytestring, utf8-string, hslogger, regex-posix, - MissingH, directory, filepath, mtl, safe, MaybeT, fastcgi, + GHC-Options: -Wall -fno-warn-orphans + Build-Depends: base >= 4 && < 5, bytestring, utf8-string, hslogger >= 1.1.0, regex-posix, + MissingH, directory, filepath, mtl, safe, MaybeT, cgi, network, hsp, hsx + if impl(ghc < 6.12) + Build-Depends: fastcgi == 3001.0.2.2 + else + Build-Depends: fastcgi Exposed-Modules: Factis.Haskoon.Web Factis.Haskoon.WebSitemap Factis.Haskoon.WebCGI - Factis.Haskoon.WebRqAccessM + Factis.Haskoon.RqAccess + Factis.Haskoon.RqAccessM Factis.Haskoon.WebHsp + Factis.Haskoon.WebHelper + Factis.Haskoon.WebTrans + Factis.Haskoon.WebIdT + Factis.Haskoon.WebReaderT diff --git a/src/Factis/Haskoon/RqAccess.hs b/src/Factis/Haskoon/RqAccess.hs new file mode 100644 --- /dev/null +++ b/src/Factis/Haskoon/RqAccess.hs @@ -0,0 +1,14 @@ +module Factis.Haskoon.RqAccess (RqAccess(..), FromRq(..)) where + +import Control.Monad (MonadPlus) +import Control.Monad.Error () + +class MonadPlus m => RqAccess m where + param :: String -> m String + header :: String -> m String + repl :: Int -> m String + cookie :: String -> m String + checkMethod :: (String -> Bool) -> m String + +class FromRq a where + fromRq :: RqAccess m => m a diff --git a/src/Factis/Haskoon/RqAccessM.hs b/src/Factis/Haskoon/RqAccessM.hs new file mode 100644 --- /dev/null +++ b/src/Factis/Haskoon/RqAccessM.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Factis.Haskoon.RqAccessM + (RqData(..), RqAccess(..), RqAccessM(..), runRqAccessM) +where + +---------------------------------------- +-- STDLIB +---------------------------------------- +import Control.Monad (MonadPlus) +import Control.Monad.Reader (ReaderT(runReaderT),asks) + +---------------------------------------- +-- SITE-PACKAGES +---------------------------------------- +import Safe (atMay) + +---------------------------------------- +-- LOCAL +---------------------------------------- +import Factis.Haskoon.RqAccess (RqAccess(..)) + +data RqData = RqData { rqd_method :: String + , rqd_params :: [(String,String)] + , rqd_headers :: [(String,String)] + , rqd_repls :: [String] + , rqd_cookies :: [(String, String)] + } + +type RqRead a = ReaderT RqData (Either String) a + +newtype RqAccessM a = RqAccessM (RqRead a) deriving (Monad, MonadPlus) + + +instance RqAccess RqAccessM where + param n = RqAccessM (readFromPairs rqd_params n "Parameter") + repl i = RqAccessM (readFromRqData rqd_repls (flip atMay i) desc) + where desc = "Replacement "++show i + cookie n = RqAccessM (readFromPairs rqd_cookies n "Cookie") + header n = RqAccessM (readFromPairs rqd_headers n "Header") + checkMethod isMethOk = + RqAccessM $ + do meth <- asks rqd_method + if isMethOk meth + then return meth + else fail $ "Invalid request method `"++meth++"'." + +readFromPairs :: (Eq a,Show a) => (RqData -> [(a,b)]) -> a -> String -> RqRead b +readFromPairs rqd_pairs key name = readFromRqData rqd_pairs findIn desc + where findIn = lookup key + desc = name ++ " `"++show key++"'" + +readFromRqData :: (RqData -> a) -> (a -> Maybe b) -> String -> RqRead b +readFromRqData rqd_value findIn desc = + do value <- asks rqd_value + case findIn value of + Nothing -> fail $ desc ++ " not found." + Just v -> return v + +runRqAccessM :: RqAccessM t -> RqData -> Either String t +runRqAccessM (RqAccessM r) d = runReaderT r d diff --git a/src/Factis/Haskoon/Web.hs b/src/Factis/Haskoon/Web.hs --- a/src/Factis/Haskoon/Web.hs +++ b/src/Factis/Haskoon/Web.hs @@ -4,18 +4,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE Rank2Types #-} module Factis.Haskoon.Web - (Web,WebRes,WebIO,RqAccess(..),FromRq(..),ToWebRes(..), WebWebRes - ,webDocumentRoot,webContainerUri,webRequestUri,webPathInfo,webMethod - ,webGetBody,webGetParams,webGetHeaders,webGetCookies,webSetStatus - ,webSendBSL,webFail,webSetHeader,webUnsetCookie,webGetRepls - ,webWithRepls,webRunFromRq,webLog,webSendError,webGetHeader - ,webGetParam,webRepl,webOk,webNotFound,webFileNotFound,webBadRequest + (Web(..),WebIO,FromRq(..),ToWebRes(..), WebWebRes, WebRec(..) + ,webRepl,webOk,webNotFound,webFileNotFound,webBadRequest ,webSendString,webGetCookie,webRedirect,webWithData,webCheckData - ,webSendFile, webSetCookie, notEmpty, optional + ,webSendFile, notEmpty, optional ,webLogNotice,webLogTrace,webLogDebug ,Cookie(..), newCookie, findCookie, deleteCookie, showCookie, readCookies + , ) where ---------------------------------------- @@ -25,7 +23,6 @@ import Control.Monad.Trans (MonadIO,liftIO) import Data.Char (toLower) -import Data.Maybe (listToMaybe, catMaybes) import Data.List (find, isSuffixOf) import System.FilePath.Posix (()) @@ -34,9 +31,7 @@ ---------------------------------------- -- SITE-PACKAGES ---------------------------------------- -import System.Log.Logger (getRootLogger, saveGlobalLogger, setLevel, addHandler - ,Priority(..), noticeM) -import System.Log.Handler.Syslog (openlog,Facility(..)) +import System.Log.Logger (Priority(..)) import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Lazy as BSL @@ -45,40 +40,109 @@ 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 - webGetParams :: m [(String,String)] - webGetHeaders :: m [(String,String)] - webGetCookies :: m [(String,String)] + 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 () - webFail :: String -> m a + webSetHeader = web_setHeader webRec webSetCookie :: Cookie -> m () + webSetCookie = web_setCookie webRec webUnsetCookie :: Cookie -> m () - -- request processing + 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 - webRunFromRq :: FromRq a => m (Either String a) - webLog :: String -> Priority -> String -> m () + 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) + 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 @@ -90,8 +154,13 @@ 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) @@ -107,22 +176,16 @@ 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 -class MonadPlus m => RqAccess m where - param :: String -> m String - header :: String -> m String - repl :: Int -> m String - cookie :: String -> m String - checkMethod :: (String -> Bool) -> m String - -class FromRq a where - fromRq :: RqAccess m => m a notEmpty :: Monad m => m String -> m String notEmpty m = m >>= \x -> if x == "" then fail "empty string" else return x diff --git a/src/Factis/Haskoon/WebCGI.hs b/src/Factis/Haskoon/WebCGI.hs --- a/src/Factis/Haskoon/WebCGI.hs +++ b/src/Factis/Haskoon/WebCGI.hs @@ -12,7 +12,7 @@ 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.Reader (MonadReader(local),ReaderT(runReaderT),asks) import Control.Monad.Error (ErrorT(..), throwError) import Data.Char (toLower) @@ -22,9 +22,9 @@ ---------------------------------------- -- SITE-PACKAGES ---------------------------------------- -import Network.CGI.Monad (MonadCGI(..), CGIT) -import Network.CGI.Cookie (readCookies) +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 @@ -39,7 +39,7 @@ -- LOCAL ---------------------------------------- import Factis.Haskoon.Web -import Factis.Haskoon.WebRqAccessM +import Factis.Haskoon.WebHelper data WebData = WebData { webd_repls :: [String] } @@ -49,10 +49,11 @@ 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) + (forall m'. (MonadIO m', MonadCGI m') => m' a) -> WebCGI m a liftCGI cgi = inWebCGI (lift (lift cgi)) @@ -76,7 +77,7 @@ do inputs <- CGI.getInputs let body = CGI.formEncode inputs return (BSLChar.pack body) - Just (ContentType "multipart" "form-data" ps) -> fail msg + Just (ContentType "multipart" "form-data" _ps) -> fail msg _ -> CGI.getBodyFPS where msg = "Content-Type multipart/form-data not supported by WebCGI." @@ -91,26 +92,26 @@ 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 + 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 cookie = liftCGI (CGI.setCookie cookie) - webUnsetCookie cookie = liftCGI (CGI.deleteCookie cookie) + 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 @@ -121,6 +122,7 @@ instance (MonadCGI m, MonadIO m) => WebIO (WebCGI m) +initialWebData :: WebData initialWebData = WebData [] runWebCGI :: (MonadCGI m, MonadIO m) => WebCGI m a -> m (Either String a) @@ -152,49 +154,6 @@ 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 diff --git a/src/Factis/Haskoon/WebHelper.hs b/src/Factis/Haskoon/WebHelper.hs new file mode 100644 --- /dev/null +++ b/src/Factis/Haskoon/WebHelper.hs @@ -0,0 +1,45 @@ +module Factis.Haskoon.WebHelper (statusCodeMessageMap) where + +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") + ] diff --git a/src/Factis/Haskoon/WebHsp.hs b/src/Factis/Haskoon/WebHsp.hs --- a/src/Factis/Haskoon/WebHsp.hs +++ b/src/Factis/Haskoon/WebHsp.hs @@ -16,7 +16,7 @@ import qualified HSP import HSP (HSPT, XML) -import HSX.XMLGenerator (Child,asChild,genElement,genEElement,asAttr,Attr((:=))) +import HSX.XMLGenerator (Child,asChild,genElement,genEElement,asAttr,Attr) ---------------------------------------- -- HASKOON @@ -29,7 +29,7 @@ webHspHtml :: WebIO m => HSPT m XML -> m (WebRes m) webHspHtml page = - do let env = undefined + do let env = error "webHspHtml: undefined" (_, xml) <- HSP.runHSPT HSP.html4Strict page env webSetHeader "Content-Type" "text/html; charset=UTF-8" webSendBSL (BSLU.fromString (HSP.renderAsHTML xml)) diff --git a/src/Factis/Haskoon/WebIdT.hs b/src/Factis/Haskoon/WebIdT.hs new file mode 100644 --- /dev/null +++ b/src/Factis/Haskoon/WebIdT.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Factis.Haskoon.WebIdT (WebTrans(..), WebIdT(..)) where + +---------------------------------------- +-- STDLIB +---------------------------------------- +import Control.Monad.Trans (MonadTrans(..), MonadIO(..)) + +---------------------------------------- +-- LOCAL +---------------------------------------- +import Factis.Haskoon.WebTrans (WebTrans(..)) + +newtype WebIdT m a = WebIdT { runWebIdT :: m a } deriving (Monad) + +instance MonadTrans WebIdT where + lift = WebIdT + +instance MonadIO m => MonadIO (WebIdT m) where + liftIO = WebIdT . liftIO + +instance WebTrans WebIdT where + liftWeb = WebIdT + liftWebFun f cont = WebIdT (f (runWebIdT cont)) diff --git a/src/Factis/Haskoon/WebReaderT.hs b/src/Factis/Haskoon/WebReaderT.hs new file mode 100644 --- /dev/null +++ b/src/Factis/Haskoon/WebReaderT.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies #-} +module Factis.Haskoon.WebReaderT (WebReaderT, runWebReaderT) where + +---------------------------------------- +-- STDLIB +---------------------------------------- +import Control.Monad (liftM) +import Control.Monad.Trans (MonadTrans, MonadIO, lift) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, local, ask) + +---------------------------------------- +-- LOCAL +---------------------------------------- +import Factis.Haskoon.Web (Web(..)) +import Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec) + +newtype WebReaderT r m a = WebReaderT (ReaderT r m a) + deriving (Monad, MonadTrans, MonadIO) + +instance Monad m => MonadReader r (WebReaderT r m) where + ask = WebReaderT ask + local f (WebReaderT cont) = WebReaderT (local f cont) + +instance WebTrans (WebReaderT r) where + liftWeb web = WebReaderT (lift web) + liftWebFun f cont = WebReaderT $ ask >>= lift . f . runWebReaderT cont + +instance Web m => Web (WebReaderT r m) where + type WebRes (WebReaderT r m) = WebRes m + webRec = liftWebRec (liftM id) webRec + +runWebReaderT :: Monad m => WebReaderT r m a -> r -> m a +runWebReaderT (WebReaderT readerT) = runReaderT readerT diff --git a/src/Factis/Haskoon/WebRqAccessM.hs b/src/Factis/Haskoon/WebRqAccessM.hs deleted file mode 100644 --- a/src/Factis/Haskoon/WebRqAccessM.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Factis.Haskoon.WebRqAccessM - (RqData(..), RqAccess(..), RqAccessM(..), runRqAccessM) -where - ----------------------------------------- --- STDLIB ----------------------------------------- -import Control.Monad (MonadPlus, liftM) -import Control.Monad.Reader (MonadReader(ask,local),ReaderT(runReaderT),asks) - ----------------------------------------- --- SITE-PACKAGES ----------------------------------------- -import Safe (atMay) - ----------------------------------------- --- LOCAL ----------------------------------------- -import Factis.Haskoon.Web (RqAccess(..)) - -data RqData = RqData { rqd_method :: String - , rqd_params :: [(String,String)] - , rqd_headers :: [(String,String)] - , rqd_repls :: [String] - , rqd_cookies :: [(String, String)] - } - -type RqRead a = ReaderT RqData (Either String) a - -newtype RqAccessM a = RqAccessM (RqRead a) deriving (Monad, MonadPlus) - - -instance RqAccess RqAccessM where - param n = RqAccessM (readFromPairs rqd_params n "Parameter") - repl i = RqAccessM (readFromRqData rqd_repls (flip atMay i) desc) - where desc = "Replacement "++show i - cookie n = RqAccessM (readFromPairs rqd_cookies n "Cookie") - header n = RqAccessM (readFromPairs rqd_headers n "Header") - checkMethod pred = RqAccessM $ - do meth <- asks rqd_method - if pred meth - then return meth - else fail $ "Invalid request method `"++meth++"'." - -readFromPairs :: (Eq a,Show a) => (RqData -> [(a,b)]) -> a -> String -> RqRead b -readFromPairs rqd_pairs key name = readFromRqData rqd_pairs findIn desc - where findIn = lookup key - desc = name ++ " `"++show key++"'" - -readFromRqData :: (RqData -> a) -> (a -> Maybe b) -> String -> RqRead b -readFromRqData rqd_value findIn desc = - do value <- asks rqd_value - case findIn value of - Nothing -> fail $ desc ++ " not found." - Just v -> return v - -runRqAccessM (RqAccessM r) d = runReaderT r d diff --git a/src/Factis/Haskoon/WebSitemap.hs b/src/Factis/Haskoon/WebSitemap.hs --- a/src/Factis/Haskoon/WebSitemap.hs +++ b/src/Factis/Haskoon/WebSitemap.hs @@ -10,8 +10,8 @@ ---------------------------------------- -- STDLIB ---------------------------------------- -import Control.Monad (MonadPlus(..), msum, guard) -import Control.Monad.Trans (MonadIO,MonadTrans,lift,liftIO) +import Control.Monad (MonadPlus(..), msum, guard, liftM) +import Control.Monad.Trans (MonadIO,MonadTrans,lift) ---------------------------------------- -- SITE-PACKAGES @@ -23,8 +23,8 @@ ---------------------------------------- -- LOCAL ---------------------------------------- -import Factis.Haskoon.Web (Web(..),WebRes,WebIO - ,webPathInfo,webMethod,webLogNotice,webNotFound) +import Factis.Haskoon.Web (Web(..),WebIO,webLogNotice,webNotFound) +import Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec) type Sitemap m = [SitemapT m (WebRes m)] @@ -32,37 +32,19 @@ newtype SitemapT m a = SitemapT { unSitemapT :: MaybeT m a } deriving (Monad, MonadIO, MonadTrans) -liftWeb :: Web m => m a -> SitemapT m a -liftWeb web = SitemapT (lift web) - -liftMaybe :: Web m => m (Maybe a) -> SitemapT m a -liftMaybe web = SitemapT (MaybeT web) - instance Web m => Web (SitemapT m) where type WebRes (SitemapT m) = WebRes m - webDocumentRoot = liftWeb webDocumentRoot - webContainerUri = liftWeb webContainerUri - webRequestUri = liftWeb webRequestUri - webPathInfo = liftWeb webPathInfo - webMethod = liftWeb webMethod - webGetBody = liftWeb webGetBody - webGetParams = liftWeb webGetParams - webGetHeaders = liftWeb webGetHeaders - webGetCookies = liftWeb webGetCookies - webSetStatus code mmsg = liftWeb (webSetStatus code mmsg) - webSendBSL bsl = liftWeb (webSendBSL bsl) - webSetHeader k m = liftWeb (webSetHeader k m) - webFail msg = liftWeb (webFail msg) - webSetCookie c = liftWeb (webSetCookie c) - webUnsetCookie c = liftWeb (webUnsetCookie c) - webGetRepls = liftWeb webGetRepls + webRec = liftWebRec (liftM id) webRec + webFail = liftWeb . webFail webWithRepls rs cont = liftMaybe (webWithRepls rs (runSitemapT cont)) - webRunFromRq = liftWeb webRunFromRq - webLog name prio msg = liftWeb (webLog name prio msg) - webSendError code msg = liftWeb (webSendError code msg) - webGetHeader n = liftWeb (webGetHeader n) - webGetParam n = liftWeb (webGetParam n) +instance WebTrans SitemapT where + liftWeb web = SitemapT (lift web) + liftWebFun f cont = liftMaybe (f (runSitemapT cont)) + +liftMaybe :: Web m => m (Maybe a) -> SitemapT m a +liftMaybe web = SitemapT (MaybeT web) + instance Web m => MonadPlus (SitemapT m) where mzero = liftMaybe (return Nothing) mplus (SitemapT (MaybeT runX)) (SitemapT (MaybeT runY)) = @@ -108,11 +90,11 @@ fromSitemapT :: Web m => SitemapT m (WebRes m) -> m (WebRes m) -> m (WebRes m) -fromSitemapT (SitemapT (MaybeT try)) catch = +fromSitemapT (SitemapT (MaybeT try)) onError = do mresult <- try case mresult of Just result -> return result - Nothing -> catch + Nothing -> onError runWithSitemap :: Web m => (m (WebRes m) -> a) -> Sitemap m -> a diff --git a/src/Factis/Haskoon/WebTrans.hs b/src/Factis/Haskoon/WebTrans.hs new file mode 100644 --- /dev/null +++ b/src/Factis/Haskoon/WebTrans.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Rank2Types #-} +module Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec) where + +---------------------------------------- +-- STDLIB +---------------------------------------- +import Control.Monad.Trans (MonadTrans) + +---------------------------------------- +-- LOCAL +---------------------------------------- +import Factis.Haskoon.Web (Web(..), WebRec(..)) + +class MonadTrans t => WebTrans t where + liftWeb :: Web m => m a -> t m a + liftWebFun :: Web m => (forall a. m a -> m a) -> t m b -> t m b + +liftWebRec :: (Web m, WebTrans t) => (m (WebRes m) -> m (WebRes (t m))) -> WebRec m -> WebRec (t m) +liftWebRec liftRes wr = + WebRec + { web_documentRoot = lift0 (web_documentRoot wr) + , web_containerUri = lift0 (web_containerUri wr) + , web_requestUri = lift0 (web_requestUri wr) + , web_pathInfo = lift0 (web_pathInfo wr) + , web_method = lift0 (web_method wr) + , web_getBody = lift0 (web_getBody wr) + , web_getParams = lift0 (web_getParams wr) + , web_getHeaders = lift0 (web_getHeaders wr) + , web_getCookies = lift0 (web_getCookies wr) + , web_setStatus = lift2 (web_setStatus wr) + , web_sendBSL = \x -> lift0 (liftRes $ web_sendBSL wr x) + , web_setHeader = lift2 (web_setHeader wr) + , web_setCookie = lift1 (web_setCookie wr) + , web_unsetCookie = lift1 (web_unsetCookie wr) + , web_log = lift3 (web_log wr) + , web_getRepls = lift0 (web_getRepls wr) + , web_withRepls = \rs cont -> liftWebFun (web_withRepls wr rs) cont + , web_fail = lift1 (web_fail wr) + } + where + lift0 = liftWeb + lift1 f x = lift0 (f x) + lift2 f x y = lift0 (f x y) + lift3 f x y z = lift0 (f x y z)