packages feed

haskoon (empty) → 0.1

raw patch · 8 files changed

+784/−0 lines, 8 filesdep +MaybeTdep +MissingHdep +basesetup-changed

Dependencies added: MaybeT, MissingH, base, bytestring, cgi, directory, fastcgi, filepath, hslogger, hsp, hsx, mtl, network, regex-posix, safe, utf8-string

Files

+ LICENSE view
@@ -0,0 +1,165 @@+		   GNU LESSER GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++  This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++  0. Additional Definitions.++  As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++  "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++  An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++  A "Combined Work" is a work produced by combining or linking an+Application with the Library.  The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++  The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++  The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++  1. Exception to Section 3 of the GNU GPL.++  You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++  2. Conveying Modified Versions.++  If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++   a) under this License, provided that you make a good faith effort to+   ensure that, in the event an Application does not supply the+   function or data, the facility still operates, and performs+   whatever part of its purpose remains meaningful, or++   b) under the GNU GPL, with none of the additional permissions of+   this License applicable to that copy.++  3. Object Code Incorporating Material from Library Header Files.++  The object code form of an Application may incorporate material from+a header file that is part of the Library.  You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++   a) Give prominent notice with each copy of the object code that the+   Library is used in it and that the Library and its use are+   covered by this License.++   b) Accompany the object code with a copy of the GNU GPL and this license+   document.++  4. Combined Works.++  You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++   a) Give prominent notice with each copy of the Combined Work that+   the Library is used in it and that the Library and its use are+   covered by this License.++   b) Accompany the Combined Work with a copy of the GNU GPL and this license+   document.++   c) For a Combined Work that displays copyright notices during+   execution, include the copyright notice for the Library among+   these notices, as well as a reference directing the user to the+   copies of the GNU GPL and this license document.++   d) Do one of the following:++       0) Convey the Minimal Corresponding Source under the terms of this+       License, and the Corresponding Application Code in a form+       suitable for, and under terms that permit, the user to+       recombine or relink the Application with a modified version of+       the Linked Version to produce a modified Combined Work, in the+       manner specified by section 6 of the GNU GPL for conveying+       Corresponding Source.++       1) Use a suitable shared library mechanism for linking with the+       Library.  A suitable mechanism is one that (a) uses at run time+       a copy of the Library already present on the user's computer+       system, and (b) will operate properly with a modified version+       of the Library that is interface-compatible with the Linked+       Version.++   e) Provide Installation Information, but only if you would otherwise+   be required to provide such information under section 6 of the+   GNU GPL, and only to the extent that such information is+   necessary to install and execute a modified version of the+   Combined Work produced by recombining or relinking the+   Application with a modified version of the Linked Version. (If+   you use option 4d0, the Installation Information must accompany+   the Minimal Corresponding Source and Corresponding Application+   Code. If you use option 4d1, you must provide the Installation+   Information in the manner specified by section 6 of the GNU GPL+   for conveying Corresponding Source.)++  5. Combined Libraries.++  You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++   a) Accompany the combined library with a copy of the same work based+   on the Library, uncombined with any other library facilities,+   conveyed under the terms of this License.++   b) Give prominent notice with the combined library that part of it+   is a work based on the Library, and explaining where to find the+   accompanying uncombined form of the same work.++  6. Revised Versions of the GNU Lesser General Public License.++  The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++  Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++  If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskoon.cabal view
@@ -0,0 +1,25 @@+Name:                haskoon+Version:             0.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)+                     and a sitemap functionality to map URLs to functions that answer the request.+License:             LGPL+License-file:        LICENSE+Category:            Web+Author:              David Leuschner, Dirk Spöri+Maintainer:          David Leuschner <leuschner@openfactis.org>+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,+                     cgi, network, hsp, hsx+  Exposed-Modules:   Factis.Haskoon.Web+                     Factis.Haskoon.WebSitemap+                     Factis.Haskoon.WebCGI+                     Factis.Haskoon.WebRqAccessM+                     Factis.Haskoon.WebHsp
+ src/Factis/Haskoon/Web.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++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+    ,webSendString,webGetCookie,webRedirect,webWithData,webCheckData+    ,webSendFile, webSetCookie, 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.Maybe (listToMaybe, catMaybes)+import Data.List (find, isSuffixOf)++import System.FilePath.Posix ((</>))+import System.Directory (doesFileExist)++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import System.Log.Logger (getRootLogger, saveGlobalLogger, setLevel, addHandler+                         ,Priority(..), noticeM)+import System.Log.Handler.Syslog (openlog,Facility(..))++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)++class Monad m => Web m where+    type WebRes m+    -- general+    webDocumentRoot :: m FilePath+    webContainerUri :: m URI+    -- request+    webRequestUri :: m URI+    webPathInfo :: m String+    webMethod :: m String+    webGetBody :: m BSL.ByteString+    webGetParams :: m [(String,String)]+    webGetHeaders :: m [(String,String)]+    webGetCookies :: m [(String,String)]+    -- response+    webSetStatus :: Int -> Maybe String -> m ()+    webSendBSL :: BSL.ByteString -> m (WebRes m)+    webSetHeader :: String -> String -> m ()+    webFail :: String -> m a+    webSetCookie :: Cookie -> m ()+    webUnsetCookie :: Cookie -> m ()+    -- request processing+    webGetRepls :: m [String]+    webWithRepls :: [String] -> m a -> m a+    webRunFromRq :: FromRq a => m (Either String a)+    webLog :: String -> Priority -> String -> m ()+    -- default methods that may be overridden+    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 name = webSendError 404 ("Not found: " ++ name)+webFileNotFound fpath = webSendError 404 ("File not found: " ++ fpath)+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_ = "Web"+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++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"
+ src/Factis/Haskoon/WebCGI.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+module Factis.Haskoon.WebCGI (WebCGI, runFastCgi, runFastWebCGI+                             ,runWebCGI, runWebCGIResult) where++----------------------------------------+-- STDLIB+----------------------------------------+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)++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+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++----------------------------------------+-- LOCAL+----------------------------------------+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
+ src/Factis/Haskoon/WebHsp.hs view
@@ -0,0 +1,35 @@+module Factis.Haskoon.WebHsp+    (HSPT, XML, Child, asChild, genElement, genEElement, asAttr, Attr((:=))+    ,webHspHtml, webToHsp+    )+where++----------------------------------------+-- STDLIB+----------------------------------------+import Control.Monad.Trans (lift)++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import qualified Data.ByteString.Lazy.UTF8 as BSLU++import qualified HSP+import HSP (HSPT, XML)+import HSX.XMLGenerator (Child,asChild,genElement,genEElement,asAttr,Attr((:=)))++----------------------------------------+-- HASKOON+----------------------------------------+import Factis.Haskoon.Web (Web, WebRes, WebIO, webSendBSL, webSetHeader)+++webToHsp :: Web m => m a -> HSPT m a+webToHsp = lift . lift++webHspHtml :: WebIO m => HSPT m XML -> m (WebRes m)+webHspHtml page =+    do let env = undefined+       (_, xml) <- HSP.runHSPT HSP.html4Strict page env+       webSetHeader "Content-Type" "text/html; charset=UTF-8"+       webSendBSL (BSLU.fromString (HSP.renderAsHTML xml))
+ src/Factis/Haskoon/WebRqAccessM.hs view
@@ -0,0 +1,58 @@+{-# 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
+ src/Factis/Haskoon/WebSitemap.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Factis.Haskoon.WebSitemap+    (SitemapT, Sitemap, liftMaybe+    ,matchFirst, matchPath, matchRegex, matchMeth+    ,runSitemapT, fromSitemapT, runSitemap, runWithSitemap)+where++----------------------------------------+-- STDLIB+----------------------------------------+import Control.Monad (MonadPlus(..), msum, guard)+import Control.Monad.Trans (MonadIO,MonadTrans,lift,liftIO)++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import Data.String.Utils (replace)+import Text.Regex.Posix ((=~))+import Control.Monad.Maybe (MaybeT(..))++----------------------------------------+-- LOCAL+----------------------------------------+import Factis.Haskoon.Web (Web(..),WebRes,WebIO+                          ,webPathInfo,webMethod,webLogNotice,webNotFound)+++type Sitemap m = [SitemapT m (WebRes m)]++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+    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 Web m => MonadPlus (SitemapT m) where+    mzero = liftMaybe (return Nothing)+    mplus (SitemapT (MaybeT runX)) (SitemapT (MaybeT runY)) =+        liftMaybe $+        do mx <- runX+           case mx of+             Just x -> return (Just x)+             Nothing -> runY++instance (MonadIO m, Web m) => WebIO (SitemapT m)++runSitemapT :: Web m => SitemapT m a -> m (Maybe a)+runSitemapT = runMaybeT . unSitemapT++matchRegex :: Web m =>+              String                  -- regular expression for url path+           -> SitemapT m (WebRes m)   -- continuation+           -> SitemapT m (WebRes m)   -- result+matchRegex regex f =+    do path <- webPathInfo+       if path =~ regex+          then let (_::String, _::String, _::String, groups::[String]) = path =~ regex+               in do webLogNotice $ show path ++ " matches " ++ show regex+                     webWithRepls groups f+          else do webLogNotice $ show path ++ " doesn't match " ++ show regex+                  fail $ "Path `"++path++"' didn't match `"++regex++"'."++matchMeth :: Web m => String -> SitemapT m a -> SitemapT m a+matchMeth exp_meth cont =+    do act_meth <- webMethod+       guard (act_meth == exp_meth)+       cont++matchFirst :: Web m => [SitemapT m (WebRes m)] -> SitemapT m (WebRes m)+matchFirst = msum+++matchPath :: Web m => String -> SitemapT m (WebRes m) -> SitemapT m (WebRes m)+matchPath glob f = matchRegex ("^" ++ globToRegex glob ++ "$") f+    where globToRegex = replace "#=#" "*"+                        . replace "*" "([^/]*)"+                        . replace "**" "(.#=#)"+++fromSitemapT :: Web m => SitemapT m (WebRes m) -> m (WebRes m) -> m (WebRes m)+fromSitemapT (SitemapT (MaybeT try)) catch =+    do mresult <- try+       case mresult of+         Just result -> return result+         Nothing -> catch+++runWithSitemap :: Web m => (m (WebRes m) -> a) -> Sitemap m -> a+runWithSitemap runWeb sitemap = runWeb $+       do webLogNotice "incoming request"+          runSitemap sitemap++runSitemap :: Web m => Sitemap m -> m (WebRes m)+runSitemap sitemap = fromSitemapT (msum sitemap) (webPathInfo >>= webNotFound)