{-# 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)