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