1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
{-# 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 = 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)
-- | convert a 'Site' to a normal Happstack route
--
-- calls 'mzero' if the route can be decoded.
--
-- see also: 'implSite_'
implSite :: (Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text -- ^ "http://example.org"
-> Text -- ^ path to this handler, .e.g. "/route/" or ""
-> Site url (m a) -- ^ the 'Site'
-> m a
implSite domain approot siteSpec =
do r <- implSite_ domain approot siteSpec
case r of
(Left _) -> mzero
(Right a) -> return a
-- | convert a 'Site' to a normal Happstack route
--
-- If url decoding fails, it returns @Left "the parse error"@,
-- otherwise @Right a@.
--
-- see also: 'implSite'
implSite_ :: (Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text -- ^ "http://example.org" (or "http://example.org:80")
-> Text -- ^ path to this handler, .e.g. "/route/" or ""
-> Site url (m a) -- ^ the 'Site'
-> 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)
{-
implSite__ :: (Monad m) => String -> FilePath -> ([ErrorMsg] -> ServerPartT m a) -> Site url (ServerPartT m a) -> (ServerPartT m a)
implSite__ domain approot handleError siteSpec =
dirs approot $ do rq <- askRq
let pathInfo = intercalate "/" (rqPaths rq)
f = runSite (domain ++ approot) siteSpec pathInfo
case f of
(Failure errs) -> handleError errs
(Success sp) -> localRq (const $ rq { rqPaths = [] }) sp
-}
-- | similar to 'seeOther' but takes a 'URL' 'm' as an argument
seeOtherURL :: (MonadRoute m, FilterMonad Response m) => URL m -> m Response
seeOtherURL url =
do otherURL <- showURL url
seeOther (Text.unpack otherURL) (toResponse "")
|
