haskoon 0.1 → 0.3.1.1

raw patch · 12 files changed

+374/−189 lines, 12 filesdep ~basedep ~fastcgidep ~hsloggernew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, fastcgi, hslogger

API changes (from Hackage documentation)

Files

• haskoon.cabal +17/−7
• src/Factis/Haskoon/RqAccess.hs +14/−0
• src/Factis/Haskoon/RqAccessM.hs +60/−0
• src/Factis/Haskoon/Web.hs +92/−29
• src/Factis/Haskoon/WebCGI.hs +19/−60
• src/Factis/Haskoon/WebHelper.hs +45/−0
• src/Factis/Haskoon/WebHsp.hs +2/−2
• src/Factis/Haskoon/WebIdT.hs +24/−0
• src/Factis/Haskoon/WebReaderT.hs +38/−0
• src/Factis/Haskoon/WebRqAccessM.hs +0/−58
• src/Factis/Haskoon/WebSitemap.hs +15/−33
• src/Factis/Haskoon/WebTrans.hs +48/−0

@@ -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 <leuschner@openfactis.org>+Author:              David Leuschner <leuschner@factisresearch.com>, Dirk Spöri <spoeri@factisresearch.com>, Stefan Wehr <wehr@factisresearch.com>+Maintainer:          David Leuschner <leuschner@factisresearch.com>, Dirk Spöri <spoeri@factisresearch.com>, Stefan Wehr <wehr@factisresearch.com> 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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")+    ]

@@ -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))

@@ -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))

@@ -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

@@ -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

@@ -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

@@ -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)