module Web.Routes.Happstack where
import Control.Applicative ((<$>))
import Control.Monad (MonadPlus(mzero))
import Data.List (intercalate)
import Happstack.Server (FilterMonad(..), ServerMonad(..), WebMonad(..), ServerPartT, Response, Request(rqPaths), ToMessage(..), dirs, runServerPartT, withRequest)
import Web.Routes.RouteT (RouteT(RouteT), liftRouteT, mapRouteT)
import Web.Routes.Site (Site, runSite)
instance (ServerMonad m) => ServerMonad (RouteT url m) where
askRq = liftRouteT askRq
localRq f m = mapRouteT (localRq f) m
instance (FilterMonad a m)=> FilterMonad a (RouteT url m) where
setFilter = liftRouteT . setFilter
composeFilter = liftRouteT . composeFilter
getFilter = mapRouteT getFilter
instance (WebMonad a m) => WebMonad a (RouteT url m) where
finishWith = liftRouteT . finishWith
implSite :: (Functor m, Monad m, MonadPlus m, ServerMonad m) => String -> FilePath -> Site url (m a) -> m a
implSite domain approot siteSpec =
do r <- implSite_ domain approot siteSpec
case r of
(Left _) -> mzero
(Right a) -> return a
implSite_ :: (Functor m, Monad m, MonadPlus m, ServerMonad m) => String -> FilePath -> Site url (m a) -> m (Either String a)
implSite_ domain approot siteSpec =
dirs approot $ do rq <- askRq
let pathInfo = intercalate "/" (rqPaths rq)
f = runSite (domain ++ approot) siteSpec pathInfo
case f of
(Left parseError) -> return (Left parseError)
(Right sp) -> Right <$> (localRq (const $ rq { rqPaths = [] }) sp)