module Factis.Haskoon.WebSitemap
(SitemapT, Sitemap, liftMaybe
,matchFirst, matchPath, matchRegex, matchMeth
,runSitemapT, fromSitemapT, runSitemap, runWithSitemap)
where
import Control.Monad (MonadPlus(..), msum, guard)
import Control.Monad.Trans (MonadIO,MonadTrans,lift,liftIO)
import Data.String.Utils (replace)
import Text.Regex.Posix ((=~))
import Control.Monad.Maybe (MaybeT(..))
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
-> SitemapT m (WebRes m)
-> SitemapT m (WebRes m)
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)