module Web.Routes.Happstack where
import Control.Applicative ((<$>))
import Control.Monad (MonadPlus(mzero))
import qualified Data.ByteString.Char8 as C
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.Text as Text
import Happstack.Server (Happstack, FilterMonad(..), ServerMonad(..), WebMonad(..), HasRqData(..), ServerPartT, Response, Request(rqPaths), ToMessage(..), dirs, seeOther)
import Web.Routes.RouteT (RouteT(RouteT), MonadRoute, URL, showURL, 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
instance (HasRqData m) => HasRqData (RouteT url m) where
askRqEnv = liftRouteT askRqEnv
localRqEnv f m = mapRouteT (localRqEnv f) m
rqDataError = liftRouteT . rqDataError
instance (Happstack m) => Happstack (RouteT url m)
implSite :: (Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text
-> Text
-> 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) =>
Text
-> Text
-> Site url (m a)
-> m (Either String a)
implSite_ domain approot siteSpec =
dirs (Text.unpack approot) $
do rq <- askRq
let f = runSite (domain `Text.append` approot) siteSpec (map Text.pack $ rqPaths rq)
case f of
(Left parseError) -> return (Left parseError)
(Right sp) -> Right <$> (localRq (const $ rq { rqPaths = [] }) sp)
seeOtherURL :: (MonadRoute m, FilterMonad Response m) => URL m -> m Response
seeOtherURL url =
do otherURL <- showURL url
seeOther (Text.unpack otherURL) (toResponse "")