module Factis.Haskoon.WebSitemap
(SitemapT, Sitemap, liftMaybe
,matchFirst, matchPath, matchRegex, matchMeth
,runSitemapT, fromSitemapT, runSitemap, runWithSitemap)
where
import Control.Monad (MonadPlus(..), msum, guard, liftM)
import Control.Monad.Trans (MonadIO,MonadTrans,lift)
import Data.String.Utils (replace)
import Text.Regex.Posix ((=~))
import Control.Monad.Maybe (MaybeT(..))
import Factis.Haskoon.Web (Web(..),WebIO,webLogNotice,webNotFound)
import Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec)
type Sitemap m = [SitemapT m (WebRes m)]
newtype SitemapT m a = SitemapT { unSitemapT :: MaybeT m a }
deriving (Monad, MonadIO, MonadTrans)
instance Web m => Web (SitemapT m) where
type WebRes (SitemapT m) = WebRes m
webRec = liftWebRec (liftM id) webRec
webFail = liftWeb . webFail
webWithRepls rs cont = liftMaybe (webWithRepls rs (runSitemapT cont))
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)) =
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)) onError =
do mresult <- try
case mresult of
Just result -> return result
Nothing -> onError
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)