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