{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, UndecidableInstances, PackageImports #-}
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 :: RouteT url m Request
askRq = m Request -> RouteT url m Request
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
localRq :: (Request -> Request) -> RouteT url m a -> RouteT url m a
localRq Request -> Request
f RouteT url m a
m = (m a -> m a) -> RouteT url m a -> RouteT url m a
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT ((Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f) RouteT url m a
m
instance (FilterMonad a m) => FilterMonad a (RouteT url m) where
setFilter :: (a -> a) -> RouteT url m ()
setFilter = m () -> RouteT url m ()
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m () -> RouteT url m ())
-> ((a -> a) -> m ()) -> (a -> a) -> RouteT url m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter
composeFilter :: (a -> a) -> RouteT url m ()
composeFilter = m () -> RouteT url m ()
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m () -> RouteT url m ())
-> ((a -> a) -> m ()) -> (a -> a) -> RouteT url m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
getFilter :: RouteT url m b -> RouteT url m (b, a -> a)
getFilter = (m b -> m (b, a -> a))
-> RouteT url m b -> RouteT url m (b, a -> a)
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT m b -> m (b, a -> a)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter
instance (WebMonad a m) => WebMonad a (RouteT url m) where
finishWith :: a -> RouteT url m b
finishWith = m b -> RouteT url m b
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m b -> RouteT url m b) -> (a -> m b) -> a -> RouteT url m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith
instance (HasRqData m) => HasRqData (RouteT url m) where
askRqEnv :: RouteT url m RqEnv
askRqEnv = m RqEnv -> RouteT url m RqEnv
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT m RqEnv
forall (m :: * -> *). HasRqData m => m RqEnv
askRqEnv
localRqEnv :: (RqEnv -> RqEnv) -> RouteT url m a -> RouteT url m a
localRqEnv RqEnv -> RqEnv
f RouteT url m a
m = (m a -> m a) -> RouteT url m a -> RouteT url m a
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT ((RqEnv -> RqEnv) -> m a -> m a
forall (m :: * -> *) a.
HasRqData m =>
(RqEnv -> RqEnv) -> m a -> m a
localRqEnv RqEnv -> RqEnv
f) RouteT url m a
m
rqDataError :: Errors String -> RouteT url m a
rqDataError = m a -> RouteT url m a
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m a -> RouteT url m a)
-> (Errors String -> m a) -> Errors String -> RouteT url m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errors String -> m a
forall (m :: * -> *) a. HasRqData m => Errors String -> m a
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 :: Text -> Text -> Site url (m a) -> m a
implSite Text
domain Text
approot Site url (m a)
siteSpec =
do Either String a
r <- Text -> Text -> Site url (m a) -> m (Either String a)
forall (m :: * -> *) url a.
(Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text -> Text -> Site url (m a) -> m (Either String a)
implSite_ Text
domain Text
approot Site url (m a)
siteSpec
case Either String a
r of
(Left String
_) -> m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
(Right a
a) -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
implSite_ :: (Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text
-> Text
-> Site url (m a)
-> m (Either String a)
implSite_ :: Text -> Text -> Site url (m a) -> m (Either String a)
implSite_ Text
domain Text
approot Site url (m a)
siteSpec =
String -> m (Either String a) -> m (Either String a)
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dirs (Text -> String
Text.unpack Text
approot) (m (Either String a) -> m (Either String a))
-> m (Either String a) -> m (Either String a)
forall a b. (a -> b) -> a -> b
$
do Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
let f :: Either String (m a)
f = Text -> Site url (m a) -> [Text] -> Either String (m a)
forall url a. Text -> Site url a -> [Text] -> Either String a
runSite (Text
domain Text -> Text -> Text
`Text.append` Text
approot) Site url (m a)
siteSpec ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ Request -> [String]
rqPaths Request
rq)
case Either String (m a)
f of
(Left String
parseError) -> Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
parseError)
(Right m a
sp) -> a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> m a -> m (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (Request -> Request -> Request
forall a b. a -> b -> a
const (Request -> Request -> Request) -> Request -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
rq { rqPaths :: [String]
rqPaths = [] }) m a
sp)
seeOtherURL :: (MonadRoute m, FilterMonad Response m) => URL m -> m Response
seeOtherURL :: URL m -> m Response
seeOtherURL URL m
url =
do Text
otherURL <- URL m -> m Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL m
url
String -> Response -> m Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (Text -> String
Text.unpack Text
otherURL) (String -> Response
forall a. ToMessage a => a -> Response
toResponse String
"")