{-# 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, liftM)
import Control.Monad.Trans (MonadIO,MonadTrans,lift)

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import Data.String.Utils (replace)
import Text.Regex.Posix ((=~))
import Control.Monad.Maybe (MaybeT(..))

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