diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ 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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/haskoon.cabal b/haskoon.cabal
new file mode 100644
--- /dev/null
+++ b/haskoon.cabal
@@ -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
+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
diff --git a/src/Factis/Haskoon/Web.hs b/src/Factis/Haskoon/Web.hs
new file mode 100644
--- /dev/null
+++ b/src/Factis/Haskoon/Web.hs
@@ -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"
diff --git a/src/Factis/Haskoon/WebCGI.hs b/src/Factis/Haskoon/WebCGI.hs
new file mode 100644
--- /dev/null
+++ b/src/Factis/Haskoon/WebCGI.hs
@@ -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
diff --git a/src/Factis/Haskoon/WebHsp.hs b/src/Factis/Haskoon/WebHsp.hs
new file mode 100644
--- /dev/null
+++ b/src/Factis/Haskoon/WebHsp.hs
@@ -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))
diff --git a/src/Factis/Haskoon/WebRqAccessM.hs b/src/Factis/Haskoon/WebRqAccessM.hs
new file mode 100644
--- /dev/null
+++ b/src/Factis/Haskoon/WebRqAccessM.hs
@@ -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
diff --git a/src/Factis/Haskoon/WebSitemap.hs b/src/Factis/Haskoon/WebSitemap.hs
new file mode 100644
--- /dev/null
+++ b/src/Factis/Haskoon/WebSitemap.hs
@@ -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)