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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
module Hierarchy
( hierarchy
, Dispatcher (..)
, runHandler
, Handler2
, App
, toText
, Env (..)
, subDispatch
-- to avoid warnings
, deleteDelete2
, deleteDelete3
) where
import Test.Hspec
import Test.HUnit
import Yesod.Routes.Parse
import Yesod.Routes.TH
import Yesod.Routes.Class
import Language.Haskell.TH.Syntax
import Data.Text (Text, pack, unpack, append)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.Set as Set
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
type Handler2 sub master a = a
type Handler site a = Handler2 site site a
type Request = ([Text], ByteString) -- path info, method
type App sub master = Request -> (Text, Maybe (Route master))
data Env sub master = Env
{ envToMaster :: Route sub -> Route master
, envSub :: sub
, envMaster :: master
}
subDispatch
:: (Env sub master -> App sub master)
-> (Handler2 sub master Text -> Env sub master -> Maybe (Route sub) -> App sub master)
-> (master -> sub)
-> (Route sub -> Route master)
-> Env master master
-> App sub master
subDispatch handler _runHandler getSub toMaster env req =
handler env' req
where
env' = env
{ envToMaster = envToMaster env . toMaster
, envSub = getSub $ envMaster env
}
class Dispatcher sub master where
dispatcher :: Env sub master -> App sub master
runHandler
:: ToText a
=> Handler2 sub master a
-> Env sub master
-> Maybe (Route sub)
-> App sub master
runHandler h Env {..} route _ = (toText h, fmap envToMaster route)
data Hierarchy = Hierarchy
do
let resources = [parseRoutes|
/ HomeR GET
----------------------------------------
/!#Int BackwardsR GET
/admin/#Int AdminR:
/ AdminRootR GET
/login LoginR GET POST
/table/#Text TableR GET
/nest/ NestR !NestingAttr:
/spaces SpacedR GET !NonNested
/nest2 Nest2:
/ GetPostR GET POST
/get Get2 GET
/post Post2 POST
-- /#Int Delete2 DELETE
/nest3 Nest3:
/get Get3 GET
/post Post3 POST
-- /#Int Delete3 DELETE
/afterwards AfterR !parent !key=value1:
/ After GET !child !key=value2
-- /trailing-nest TrailingNestR:
-- /foo TrailingFooR GET
-- /#Int TrailingIntR GET
|]
rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
dispatch <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|runHandler|]
, mdsSubDispatcher = [|subDispatch|]
, mdsGetPathInfo = [|fst|]
, mdsMethod = [|snd|]
, mdsSetPathInfo = [|\p (_, m) -> (p, m)|]
, mds404 = [|pack "404"|]
, mds405 = [|pack "405"|]
, mdsGetHandler = defaultGetHandler
, mdsUnwrapper = return
} resources
return
#if MIN_VERSION_template_haskell(2,11,0)
$ InstanceD Nothing
#else
$ InstanceD
#endif
[]
(ConT ''Dispatcher
`AppT` ConT ''Hierarchy
`AppT` ConT ''Hierarchy)
[FunD (mkName "dispatcher") [dispatch]]
: prinst
: rainst
: rrinst
getSpacedR :: Handler site String
getSpacedR = "root-leaf"
getGet2 :: Handler site String; getGet2 = "get"
postPost2 :: Handler site String; postPost2 = "post"
deleteDelete2 :: Int -> Handler site String; deleteDelete2 = const "delete"
getGet3 :: Handler site String; getGet3 = "get"
postPost3 :: Handler site String; postPost3 = "post"
deleteDelete3 :: Int -> Handler site String; deleteDelete3 = const "delete"
getAfter :: Handler site String; getAfter = "after"
getHomeR :: Handler site String
getHomeR = "home"
getBackwardsR :: Int -> Handler site Text
getBackwardsR _ = pack "backwards"
getAdminRootR :: Int -> Handler site Text
getAdminRootR i = pack $ "admin root: " ++ show i
getLoginR :: Int -> Handler site Text
getLoginR i = pack $ "login: " ++ show i
postLoginR :: Int -> Handler site Text
postLoginR i = pack $ "post login: " ++ show i
getTableR :: Int -> Text -> Handler site Text
getTableR _ = append "TableR "
getGetPostR :: Handler site Text
getGetPostR = pack "get"
postGetPostR :: Handler site Text
postGetPostR = pack "post"
hierarchy :: Spec
hierarchy = describe "hierarchy" $ do
it "nested with spacing" $
renderRoute (NestR SpacedR) @?= (["nest", "spaces"], [])
it "renders root correctly" $
renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
it "renders table correctly" $
renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])
let disp m ps = dispatcher
(Env
{ envToMaster = id
, envMaster = Hierarchy
, envSub = Hierarchy
})
(map pack ps, S8.pack m)
let testGetPost route getRes postRes = do
let routeStrs = map unpack $ fst (renderRoute route)
disp "GET" routeStrs @?= (getRes, Just route)
disp "POST" routeStrs @?= (postRes, Just route)
it "dispatches routes with multiple METHODs: admin" $
testGetPost (AdminR 1 LoginR) "login: 1" "post login: 1"
it "dispatches routes with multiple METHODs: nesting" $
testGetPost (NestR $ Nest2 GetPostR) "get" "post"
it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)
it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")
it "parses" $ do
parseRoute ([], []) @?= Just HomeR
parseRoute ([], [("foo", "bar")]) @?= Just HomeR
parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)
parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy))
it "inherited attributes" $ do
routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]
it "pair attributes" $
routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"]
|
