haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

yesod-core compiles with yesod-routes (tests fail)

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-03 20:33:51 +02:00
parent fa4fd5690f
commit c499e880b6
12 changed files with 284 additions and 751 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
package-list.sh
View File

@ -1,6 +1,7 @@
#!/bin/bash #!/bin/bash
pkgs=( ./yesod-core pkgs=( ./yesod-routes
./yesod-core
./yesod-json ./yesod-json
./yesod-static ./yesod-static
./yesod-persistent ./yesod-persistent

119
yesod-core/Yesod/Dispatch.hs
View File

@ -28,11 +28,10 @@ import Data.Either (partitionEithers)
import Prelude hiding (exp) import Prelude hiding (exp)
import Yesod.Internal.Core import Yesod.Internal.Core
import Yesod.Handler hiding (lift) import Yesod.Handler hiding (lift)
import Yesod.Internal.Dispatch
import Yesod.Widget (GWidget) import Yesod.Widget (GWidget)
import Web.PathPieces import Web.PathPieces
import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck) import Yesod.Internal.RouteParsing (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import qualified Network.Wai as W import qualified Network.Wai as W
@ -44,6 +43,13 @@ import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession import Web.ClientSession
import Data.Char (isUpper) import Data.Char (isUpper)
import Data.Text (Text) import Data.Text (Text)
import Data.Monoid (mappend)
import qualified Data.ByteString as S
import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301)
import Yesod.Routes.TH
import Yesod.Content (chooseRep)
import Yesod.Internal.RouteParsing
type Texts = [Text] type Texts = [Text]
@ -51,7 +57,7 @@ type Texts = [Text]
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
-- Use 'parseRoutes' to create the 'Resource's. -- Use 'parseRoutes' to create the 'Resource's.
mkYesod :: String -- ^ name of the argument datatype mkYesod :: String -- ^ name of the argument datatype
-> [Resource] -> RouteString
-> Q [Dec] -> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
@ -62,7 +68,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-- be embedded in other sites. -- be embedded in other sites.
mkYesodSub :: String -- ^ name of the argument datatype mkYesodSub :: String -- ^ name of the argument datatype
-> Cxt -> Cxt
-> [Resource] -> RouteString
-> Q [Dec] -> Q [Dec]
mkYesodSub name clazzes = mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@ -73,28 +79,28 @@ mkYesodSub name clazzes =
-- your handlers elsewhere. For example, this is the only way to break up a -- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with -- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that. -- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [Resource] -> Q [Dec] mkYesodData :: String -> RouteString -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name [] False res mkYesodData name res = mkYesodDataGeneral name [] False res
mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec] mkYesodSubData :: String -> Cxt -> RouteString -> Q [Dec]
mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec] mkYesodDataGeneral :: String -> Cxt -> Bool -> RouteString -> Q [Dec]
mkYesodDataGeneral name clazzes isSub res = do mkYesodDataGeneral name clazzes isSub res = do
let (name':rest) = words name let (name':rest) = words name
(x, _) <- mkYesodGeneral name' rest clazzes isSub res (x, _) <- mkYesodGeneral name' rest clazzes isSub res
let rname = mkName $ "resources" ++ name let rname = mkName $ "resources" ++ name
eres <- lift res eres <- [|parseRouteString $(lift res)|]
let y = [ SigD rname $ ListT `AppT` ConT ''Resource let y = [ SigD rname $ ListT `AppT` ConT ''Resource
, FunD rname [Clause [] (NormalB eres) []] , FunD rname [Clause [] (NormalB eres) []]
] ]
return $ x ++ y return $ x ++ y
-- | See 'mkYesodData'. -- | See 'mkYesodData'.
mkYesodDispatch :: String -> [Resource] -> Q [Dec] mkYesodDispatch :: String -> RouteString -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec] mkYesodSubDispatch :: String -> Cxt -> RouteString -> Q [Dec]
mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True
where (name':rest) = words name where (name':rest) = words name
@ -102,40 +108,26 @@ mkYesodGeneral :: String -- ^ foundation name
-> [String] -- ^ parameters for foundation -> [String] -- ^ parameters for foundation
-> Cxt -- ^ classes -> Cxt -- ^ classes
-> Bool -- ^ is subsite? -> Bool -- ^ is subsite?
-> [Resource] -> RouteString
-> Q ([Dec], [Dec]) -> Q ([Dec], [Dec])
mkYesodGeneral name args clazzes isSub res = do mkYesodGeneral name args clazzes isSub resS = do
let args' = map mkName args let res = parseRouteString resS
arg = foldl AppT (ConT name') $ map VarT args' renderRouteDec <- mkRenderRouteInstance (ConT name') res
th' <- mapM thResourceFromResource res
let th = map fst th'
w' <- createRoutes th
let routesName = mkName $ name ++ "Route"
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
let x = TySynInstD ''Route [arg] $ ConT routesName
render <- createRender th disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)
[ FunD (mkName "renderRoute") render
]
let splitter :: (THResource, Maybe String)
-> Either
(THResource, Maybe String)
(THResource, Maybe String)
splitter a@((_, SubSite{}), _) = Left a
splitter a = Right a
let (resSub, resLoc) = partitionEithers $ map splitter th'
yd <- mkYesodDispatch' resSub resLoc
let master = mkName "master" let master = mkName "master"
let ctx = if isSub let ctx = if isSub
then ClassP (mkName "Yesod") [VarT master] : clazzes then ClassP (mkName "Yesod") [VarT master] : clazzes
else [] else []
let args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT args'
let ytyp = if isSub let ytyp = if isSub
then ConT ''YesodDispatch `AppT` arg `AppT` VarT master then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
else ConT ''YesodDispatch `AppT` arg `AppT` arg else ConT ''YesodDispatch `AppT` arg `AppT` arg
let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]] let yesodDispatch =
return ([w, x, x'] ++ masterTypSyns, [y]) InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
return (renderRouteDec : masterTypSyns, [yesodDispatch])
where where
name' = mkName name name' = mkName name
masterTypSyns masterTypSyns
@ -151,45 +143,46 @@ mkYesodGeneral name args clazzes isSub res = do
(ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0) (ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0)
] ]
thResourceFromResource :: Resource -> Q (THResource, Maybe String)
thResourceFromResource (Resource n ps atts)
| all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
thResourceFromResource (Resource n ps [stype, toSubArg]) = do
let stype' = ConT $ mkName stype
parse <- [|error "ssParse"|]
dispatch <- [|error "ssDispatch"|]
render <- [|renderRoute|]
tmg <- [|error "ssToMasterArg"|]
return ((n, SubSite
{ ssType = ConT ''Route `AppT` stype'
, ssParse = parse
, ssRender = render
, ssDispatch = dispatch
, ssToMasterArg = tmg
, ssPieces = ps
}), Just toSubArg)
thResourceFromResource (Resource n _ _) =
error $ "Invalid attributes for resource: " ++ n
-- | Convert the given argument into a WAI application, executable with any WAI -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This is the same as 'toWaiAppPlain', except it includes two -- handler. This is the same as 'toWaiAppPlain', except it includes two
-- middlewares: GZIP compression and autohead. This is the -- middlewares: GZIP compression and autohead. This is the
-- recommended approach for most users. -- recommended approach for most users.
toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application toWaiApp :: ( Yesod master
, YesodDispatch master master
) => master -> IO W.Application
toWaiApp y = gzip (gzipCompressFiles y) . autohead <$> toWaiAppPlain y toWaiApp y = gzip (gzipCompressFiles y) . autohead <$> toWaiAppPlain y
-- | Convert the given argument into a WAI application, executable with any WAI -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it uses no middlewares. -- handler. This differs from 'toWaiApp' in that it uses no middlewares.
toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application toWaiAppPlain :: ( Yesod master
, YesodDispatch master master
) => master -> IO W.Application
toWaiAppPlain a = toWaiApp' a <$> encryptKey a toWaiAppPlain a = toWaiApp' a <$> encryptKey a
toWaiApp' :: (Yesod y, YesodDispatch y y) toWaiApp' :: ( Yesod master
=> y , YesodDispatch master master
)
=> master
-> Maybe Key -> Maybe Key
-> W.Application -> W.Application
toWaiApp' y key' env = toWaiApp' y key' env =
case yesodDispatch y key' (W.pathInfo env) y id of yesodDispatch y y id app404 handler405 method (W.pathInfo env) key' env
Just app -> app env where
Nothing -> yesodRunner y y id key' Nothing notFound env app404 = yesodRunner notFound y y Nothing id
handler405 = error "handler405"
method = error "method"
sendRedirect :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env =
return $ W.responseLBS status301
[ ("Content-Type", "text/plain")
, ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting"
where
dest = joinPath y (approot y) segments' []
dest' =
if S.null (W.rawQueryString env)
then dest
else (dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))

7
yesod-core/Yesod/Handler.hs
View File

@ -24,8 +24,7 @@
--------------------------------------------------------- ---------------------------------------------------------
module Yesod.Handler module Yesod.Handler
( -- * Type families ( -- * Type families
Route YesodSubRoute (..)
, YesodSubRoute (..)
-- * Handler monad -- * Handler monad
, GHandler , GHandler
-- ** Read information from handler -- ** Read information from handler
@ -174,9 +173,7 @@ import Network.Wai (requestBody)
import Data.Conduit (($$)) import Data.Conduit (($$))
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Control.Monad.Base import Control.Monad.Base
import Yesod.Routes.Class
-- | The type-safe URLs associated with a site argument.
type family Route a
class YesodSubRoute s y where class YesodSubRoute s y where
fromSubRoute :: s -> y -> Route s -> Route y fromSubRoute :: s -> y -> Route s -> Route y

45
yesod-core/Yesod/Internal/Core.hs
View File

@ -33,6 +33,8 @@ module Yesod.Internal.Core
import Yesod.Content import Yesod.Content
import Yesod.Handler hiding (lift) import Yesod.Handler hiding (lift)
import Yesod.Routes.Class
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad (forM) import Control.Monad (forM)
import Yesod.Widget import Yesod.Widget
@ -92,31 +94,34 @@ yesodVersion = "0.9.4"
#define HAMLET $hamlet #define HAMLET $hamlet
#endif #endif
class Eq u => RenderRoute u where
renderRoute :: u -> ([Text], [(Text, Text)])
-- | This class is automatically instantiated when you use the template haskell -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.
class YesodDispatch a master where class YesodDispatch sub master where
yesodDispatch yesodDispatch
:: Yesod master :: Yesod master
=> a => master
-> sub
-> (Route sub -> Route master)
-> (Maybe CS.Key -> W.Application) -- ^ 404 handler
-> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler
-> Text -- ^ request method
-> [Text] -- ^ pieces
-> Maybe CS.Key -> Maybe CS.Key
-> [Text] -> W.Application
-> master
-> (Route a -> Route master)
-> Maybe W.Application
yesodRunner :: Yesod master yesodRunner :: Yesod master
=> a => GHandler sub master ChooseRep
-> master -> master
-> (Route a -> Route master) -> sub
-> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application -> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe CS.Key
-> W.Application
yesodRunner = defaultYesodRunner yesodRunner = defaultYesodRunner
-- | Define settings for a Yesod applications. The only required setting is -- | Define settings for a Yesod applications. The only required setting is
-- 'approot'; other than that, there are intelligent defaults. -- 'approot'; other than that, there are intelligent defaults.
class RenderRoute (Route a) => Yesod a where class RenderRoute a => Yesod a where
-- | An absolute URL to the root of the application. Do not include -- | An absolute URL to the root of the application. Do not include
-- trailing slash. -- trailing slash.
-- --
@ -322,14 +327,14 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
char = show . snd . loc_start char = show . snd . loc_start
defaultYesodRunner :: Yesod master defaultYesodRunner :: Yesod master
=> a => GHandler sub master ChooseRep
-> master -> master
-> (Route a -> Route master) -> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe CS.Key -> Maybe CS.Key
-> Maybe (Route a)
-> GHandler a master ChooseRep
-> W.Application -> W.Application
defaultYesodRunner _ m toMaster _ murl _ req defaultYesodRunner _ m _ murl toMaster _ req
| maximumContentLength m (fmap toMaster murl) < len = | maximumContentLength m (fmap toMaster murl) < len =
return $ W.responseLBS return $ W.responseLBS
(H.Status 413 "Too Large") (H.Status 413 "Too Large")
@ -341,7 +346,7 @@ defaultYesodRunner _ m toMaster _ murl _ req
case reads $ S8.unpack s of case reads $ S8.unpack s of
[] -> Nothing [] -> Nothing
(x, _):_ -> Just x (x, _):_ -> Just x
defaultYesodRunner s master toMasterRoute mkey murl handler req = do defaultYesodRunner handler master sub murl toMasterRoute mkey req = do
now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
@ -374,7 +379,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
handler handler
let sessionMap = Map.fromList let sessionMap = Map.fromList
$ filter (\(x, _) -> x /= nonceKey) session' $ filter (\(x, _) -> x /= nonceKey) session'
yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h yar <- handlerToYAR master sub toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
let mnonce = reqNonce rr let mnonce = reqNonce rr
-- FIXME should we be caching this IV value and reusing it for efficiency? -- FIXME should we be caching this IV value and reusing it for efficiency?
iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey

322
yesod-core/Yesod/Internal/Dispatch.hs
View File

@ -1,322 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-- | A bunch of Template Haskell used in the Yesod.Dispatch module.
module Yesod.Internal.Dispatch
( mkYesodDispatch'
) where
import Prelude hiding (exp)
import Language.Haskell.TH.Syntax
import Web.PathPieces
import Yesod.Internal.RouteParsing
import Control.Monad (foldM)
import Yesod.Handler (badMethod)
import Yesod.Content (chooseRep)
import qualified Network.Wai as W
import Yesod.Internal.Core (yesodRunner, yesodDispatch)
import Data.List (foldl')
import Data.Char (toLower)
import qualified Data.ByteString as S
import Yesod.Internal.Core (Yesod (joinPath, approot, cleanPath))
import Network.HTTP.Types (status301)
import Data.Text (Text)
import Data.Monoid (mappend)
import qualified Blaze.ByteString.Builder
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text
{-|
Alright, let's explain how routing works. We want to take a [String] and found
out which route it applies to. For static pieces, we need to ensure an exact
match against the segment. For a single or multi piece, we need to check the
result of fromPathPiece/fromMultiPathPiece, respectively.
We want to create a tree of case statements basically resembling:
case testRoute1 of
Just app -> Just app
Nothing ->
case testRoute2 of
Just app -> Just app
Nothing ->
case testRoute3 of
Just app -> Just app
Nothing -> Nothing
Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int):
case segments of
"name" : as ->
case as of
[] -> Nothing
b:bs ->
case fromPathPiece b of
Left _ -> Nothing
Right name ->
case bs of
"age":cs ->
case cs of
[] -> Nothing
d:ds ->
case fromPathPiece d of
Left _ -> Nothing
Right age ->
case ds of
[] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)...
_ -> Nothing
_ -> Nothing
_ -> Nothing
Obviously we would never want to write code by hand like this, but generating it is not too bad.
This function generates a clause for the yesodDispatch function based on a set of routes.
NOTE: We deal with subsites first; if none of those match, we try to apply
cleanPath. If that indicates a redirect, we perform it. Otherwise, we match
local routes.
-}
sendRedirect :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env =
return $ W.responseLBS status301
[ ("Content-Type", "text/plain")
, ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting"
where
dest = joinPath y (approot y) segments' []
dest' =
if S.null (W.rawQueryString env)
then dest
else (dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
mkYesodDispatch' :: [((String, Pieces), Maybe String)]
-> [((String, Pieces), Maybe String)]
-> Q Clause
mkYesodDispatch' resSub resLoc = do
sub <- newName "sub"
master <- newName "master"
mkey <- newName "mkey"
segments <- newName "segments"
segments' <- newName "segmentsClean"
toMasterRoute <- newName "toMasterRoute"
nothing <- [|Nothing|]
bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc
cp <- [|cleanPath|]
sr <- [|sendRedirect|]
just <- [|Just|]
let bodyLoc' =
CaseE (cp `AppE` VarE master `AppE` VarE segments)
[ Match (ConP (mkName "Left") [VarP segments'])
(NormalB $ just `AppE`
(sr `AppE` VarE master `AppE` VarE segments'))
[]
, Match (ConP (mkName "Right") [VarP segments'])
(NormalB bodyLoc)
[]
]
body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub
return $ Clause
[VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
(NormalB body)
[]
where
go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub)
app <- newName "app"
return $ CaseE test
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
]
go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)
just <- [|Just|]
app <- newName "app"
return $ CaseE test
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
]
go _ _ _ _ _ _ _ = error "Invalid combination"
mkSimpleExp :: Exp -- ^ segments
-> [Piece]
-> ([Exp] -> [Exp]) -- ^ variables already parsed
-> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods
-> Q Exp
mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
just <- [|Just|]
nothing <- [|Nothing|]
onSuccess <- newName "onSuccess"
req <- newName "req"
badMethod' <- [|badMethod|]
rm <- [|S8.unpack . W.requestMethod|]
let caseExp = rm `AppE` VarE req
yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|]
eq <- [|(==)|]
let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
runHandler' h = yr `AppE` sub
`AppE` VarE master
`AppE` toMasterRoute
`AppE` VarE mkey
`AppE` (just `AppE` url)
`AppE` h
`AppE` VarE req
let match :: String -> Q Match
match m = do
x <- newName "x"
return $ Match
(VarP x)
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ LitE $ StringL m) -- FIXME need to pack, right?
, runHandlerVars $ map toLower m ++ constr
)
])
[]
clauses <-
case methods of
[] -> return [Clause [VarP req] (NormalB $ runHandlerVars $ "handle" ++ constr) []]
_ -> do
matches <- mapM match methods
return [Clause [VarP req] (NormalB $ CaseE caseExp $ matches ++
[Match WildP (NormalB $ runHandler' badMethod') []]) []]
let exp = CaseE segments
[ Match
(ConP (mkName "[]") [])
(NormalB $ just `AppE` VarE onSuccess)
[FunD onSuccess clauses]
, Match
WildP
(NormalB nothing)
[]
]
return exp
mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments"
innerExp <- mkSimpleExp (VarE srest) pieces frontVars x
nothing <- [|Nothing|]
y <- newName "y"
pack <- [|Data.Text.pack|]
eq <- [|(==)|]
let exp = CaseE segments
[ Match
(InfixP (VarP y) (mkName ":") (VarP srest))
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
, innerExp
)
])
[]
, Match WildP (NormalB nothing) []
]
return exp
mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
srest <- newName "segments"
next' <- newName "next'"
innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
next <- newName "next"
fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next)
[ Match
(ConP (mkName "Nothing") [])
(NormalB nothing)
[]
, Match
(ConP (mkName "Just") [VarP next'])
(NormalB innerExp)
[]
]
let exp = CaseE segments
[ Match
(InfixP (VarP next) (mkName ":") (VarP srest))
(NormalB exp')
[]
, Match WildP (NormalB nothing) []
]
return exp
mkSimpleExp segments [MultiPiece _] frontVars x = do
next' <- newName "next'"
srest <- [|[]|]
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
fmp <- [|fromPathMultiPiece|]
let exp = CaseE (fmp `AppE` segments)
[ Match
(ConP (mkName "Nothing") [])
(NormalB nothing)
[]
, Match
(ConP (mkName "Just") [VarP next'])
(NormalB innerExp)
[]
]
return exp
mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"
mkSubsiteExp :: Name -- ^ segments
-> [Piece]
-> ([Exp] -> [Exp]) -- ^ variables already parsed
-> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub
-> Q Exp
mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
yd <- [|yesodDispatch|]
dot <- [|(.)|]
let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []
-- proper handling for sub-subsites
let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars []
let app = yd `AppE` sub'
`AppE` VarE mkey
`AppE` VarE segments
`AppE` VarE master
`AppE` con
just <- [|Just|]
return $ just `AppE` app
mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece"
mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments"
innerExp <- mkSubsiteExp srest pieces frontVars x
nothing <- [|Nothing|]
y <- newName "y"
pack <- [|Data.Text.pack|]
eq <- [|(==)|]
let exp = CaseE (VarE segments)
[ Match
(InfixP (VarP y) (mkName ":") (VarP srest))
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
, innerExp
)
])
[]
, Match WildP (NormalB nothing) []
]
return exp
mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
srest <- newName "segments"
next' <- newName "next'"
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
next <- newName "next"
fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next)
[ Match
(ConP (mkName "Nothing") [])
(NormalB nothing)
[]
, Match
(ConP (mkName "Just") [VarP next'])
(NormalB innerExp)
[]
]
let exp = CaseE (VarE segments)
[ Match
(InfixP (VarP next) (mkName ":") (VarP srest))
(NormalB exp')
[]
, Match WildP (NormalB nothing) []
]
return exp

319
yesod-core/Yesod/Internal/RouteParsing.hs
View File

@ -2,18 +2,12 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
module Yesod.Internal.RouteParsing module Yesod.Internal.RouteParsing
( createRoutes ( parseRoutes
, createRender
, createParse
, createDispatch
, Pieces (..)
, THResource
, parseRoutes
, parseRoutesFile , parseRoutesFile
, parseRoutesNoCheck , parseRoutesNoCheck
, parseRoutesFileNoCheck , parseRoutesFileNoCheck
, Resource (..) , RouteString
, Piece (..) , parseRouteString
) where ) where
import Web.PathPieces import Web.PathPieces
@ -21,204 +15,12 @@ import Language.Haskell.TH.Syntax
import Data.Maybe import Data.Maybe
import Data.Either import Data.Either
import Data.List import Data.List
import Data.Char (toLower) import Data.Char (toLower, isUpper)
import qualified Data.Text import qualified Data.Text
import Language.Haskell.TH.Quote import Language.Haskell.TH.Quote
import Data.Data import Data.Data
import qualified System.IO as SIO import qualified System.IO as SIO
import Yesod.Routes.TH
data Pieces =
SubSite
{ ssType :: Type
, ssParse :: Exp
, ssRender :: Exp
, ssDispatch :: Exp
, ssToMasterArg :: Exp
, ssPieces :: [Piece]
}
| Simple [Piece] [String] -- ^ methods
deriving Show
type THResource = (String, Pieces)
createRoutes :: [THResource] -> Q [Con]
createRoutes res =
return $ map go res
where
go (n, SubSite{ssType = s, ssPieces = pieces}) =
NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
go' (StaticPiece _) = Nothing
-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.
createParse :: [THResource] -> Q [Clause]
createParse res = do
final' <- final
clauses <- mapM go res
return $ if areResourcesComplete res
then clauses
else clauses ++ [final']
where
cons x y = ConP (mkName ":") [x, y]
go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
ri <- [|Right|]
be <- [|ape|]
(pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
x <- newName "x"
let pat = init pat' ++ [VarP x]
--let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces
let eitherSub = p `AppE` VarE x
let bod = be `AppE` parse `AppE` eitherSub
--let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub
return $ Clause [foldr1 cons pat] (NormalB bod) []
go (n, Simple ps _) = do
ri <- [|Right|]
be <- [|ape|]
(pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
return $ Clause [foldr1 cons pat] (NormalB parse) []
final = do
no <- [|Left "Invalid URL"|]
return $ Clause [WildP] (NormalB no) []
mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
mkPat' be [MultiPiece s] parse = do
v <- newName $ "var" ++ s
fmp <- [|fromPathMultiPiece|]
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
return ([VarP v], parse')
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
mkPat' be (StaticPiece s:rest) parse = do
(x, parse') <- mkPat' be rest parse
let sp = LitP $ StringL s
return (sp : x, parse')
mkPat' be (SinglePiece s:rest) parse = do
fsp <- [|fromPathPiece|]
v <- newName $ "var" ++ s
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
(x, parse'') <- mkPat' be rest parse'
return (VarP v : x, parse'')
mkPat' _ [] parse = return ([ListP []], parse)
-- | 'ap' for 'Either'
ape :: Either String (a -> b) -> Either String a -> Either String b
ape (Left e) _ = Left e
ape (Right _) (Left e) = Left e
ape (Right f) (Right a) = Right $ f a
-- | Generates the set of clauses necesary to render the given 'Resource's. See
-- 'quasiRender'.
createRender :: [THResource] -> Q [Clause]
createRender = mapM go
where
go (n, Simple ps _) = do
let ps' = zip [1..] ps
let pat = ConP (mkName n) $ mapMaybe go' ps'
bod <- mkBod ps'
return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
cons' <- [|\a (b, c) -> (a ++ b, c)|]
let cons a b = cons' `AppE` a `AppE` b
x <- newName "x"
let r' = r `AppE` VarE x
let pieces' = zip [1..] pieces
let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
bod <- mkBod pieces'
return $ Clause [pat] (NormalB $ cons bod r') []
go' (_, StaticPiece _) = Nothing
go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
mkBod :: (Show t) => [(t, Piece)] -> Q Exp
mkBod [] = lift ([] :: [String])
mkBod ((_, StaticPiece x):xs) = do
x' <- lift x
pack <- [|Data.Text.pack|]
xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
mkBod ((i, SinglePiece _):xs) = do
let x' = VarE $ mkName $ "var" ++ show i
tsp <- [|toPathPiece|]
let x'' = tsp `AppE` x'
xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
mkBod ((i, MultiPiece _):_) = do
let x' = VarE $ mkName $ "var" ++ show i
tmp <- [|toPathMultiPiece|]
return $ tmp `AppE` x'
-- | Whether the set of resources cover all possible URLs.
areResourcesComplete :: [THResource] -> Bool
areResourcesComplete res =
let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
in case slurps of
[] -> False
_ -> let minSlurp = minimum slurps
in helper minSlurp $ reverse $ sort noSlurps
where
go :: THResource -> Maybe (Either Int Int)
go (_, Simple ps _) =
case reverse ps of
[] -> Just $ Right 0
(MultiPiece _:rest) -> go' Left rest
x -> go' Right x
go (n, SubSite{ssPieces = ps}) =
go (n, Simple (ps ++ [MultiPiece ""]) [])
go' b x = if all isSingle x then Just (b $ length x) else Nothing
helper 0 _ = True
helper _ [] = False
helper m (i:is)
| i >= m = helper m is
| i + 1 == m = helper i is
| otherwise = False
isSingle (SinglePiece _) = True
isSingle _ = False
notStatic :: Piece -> Bool
notStatic StaticPiece{} = False
notStatic _ = True
createDispatch :: Exp -- ^ modify a master handler
-> Exp -- ^ convert a subsite handler to a master handler
-> [THResource]
-> Q [Clause]
createDispatch modMaster toMaster = mapM go
where
go :: (String, Pieces) -> Q Clause
go (n, Simple ps methods) = do
meth <- newName "method"
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
let pat = [ ConP (mkName n) $ map VarP xs
, if null methods then WildP else VarP meth
]
bod <- go' n meth xs methods
return $ Clause pat (NormalB bod) []
go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
meth <- newName "method"
x <- newName "x"
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
let bod = d `AppE` VarE x `AppE` VarE meth
fmap' <- [|fmap|]
let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
tma' = foldl AppE tma $ map VarE xs
let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
let bod' = InfixE (Just toMaster') fmap' (Just bod)
let bod'' = InfixE (Just modMaster) fmap' (Just bod')
return $ Clause pat (NormalB bod'') []
go' n _ xs [] = do
jus <- [|Just|]
let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
return $ jus `AppE` (modMaster `AppE` bod)
go' n meth xs methods = do
noth <- [|Nothing|]
j <- [|Just|]
let noMatch = Match WildP (NormalB noth) []
return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
go'' n xs j method =
let pat = LitP $ StringL method
func = map toLower method ++ n
bod = foldl AppE (VarE $ mkName func) $ map VarE xs
in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []
-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
@ -226,15 +28,24 @@ createDispatch modMaster toMaster = mapM go
parseRoutes :: QuasiQuoter parseRoutes :: QuasiQuoter
parseRoutes = QuasiQuoter parseRoutes = QuasiQuoter
{ quoteExp = x { quoteExp = x
, quotePat = y
} }
where where
x s = do x s = do
let res = resourcesFromString s let res = resourcesFromString s
case findOverlaps res of case findOverlaps res of
[] -> lift res [] -> liftParse s
z -> error $ "Overlapping routes: " ++ unlines (map show z) z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z)
y = dataToPatQ (const Nothing) . resourcesFromString
newtype RouteString = RouteString String
liftParse :: String -> Q Exp
liftParse s = [|RouteString s|]
parseRouteString :: RouteString -> [Resource]
parseRouteString (RouteString s) = resourcesFromString s
instance Lift RouteString where
lift (RouteString s) = [|RouteString $(lift s)|]
parseRoutesFile :: FilePath -> Q Exp parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile fp = do parseRoutesFile fp = do
@ -255,51 +66,8 @@ readUtf8File fp = do
-- | Same as 'parseRoutes', but performs no overlap checking. -- | Same as 'parseRoutes', but performs no overlap checking.
parseRoutesNoCheck :: QuasiQuoter parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter parseRoutesNoCheck = QuasiQuoter
{ quoteExp = x { quoteExp = liftParse
, quotePat = y
} }
where
x = lift . resourcesFromString
y = dataToPatQ (const Nothing) . resourcesFromString
instance Lift Resource where
lift (Resource s ps h) = do
r <- [|Resource|]
s' <- lift s
ps' <- lift ps
h' <- lift h
return $ r `AppE` s' `AppE` ps' `AppE` h'
-- | A single resource pattern.
--
-- First argument is the name of the constructor, second is the URL pattern to
-- match, third is how to dispatch.
data Resource = Resource String [Piece] [String]
deriving (Read, Show, Eq, Data, Typeable)
-- | A single piece of a URL, delimited by slashes.
--
-- In the case of StaticPiece, the argument is the value of the piece; for the
-- other constructors, it is the name of the parameter represented by this
-- piece. That value is not used here, but may be useful elsewhere.
data Piece = StaticPiece String
| SinglePiece String
| MultiPiece String
deriving (Read, Show, Eq, Data, Typeable)
instance Lift Piece where
lift (StaticPiece s) = do
c <- [|StaticPiece|]
s' <- lift s
return $ c `AppE` s'
lift (SinglePiece s) = do
c <- [|SinglePiece|]
s' <- lift s
return $ c `AppE` s'
lift (MultiPiece s) = do
c <- [|MultiPiece|]
s' <- lift s
return $ c `AppE` s'
-- | Convert a multi-line string to a set of resources. See documentation for -- | Convert a multi-line string to a set of resources. See documentation for
-- the format of this string. This is a partial function which calls 'error' on -- the format of this string. This is a partial function which calls 'error' on
@ -311,28 +79,48 @@ resourcesFromString =
go s = go s =
case takeWhile (/= "--") $ words s of case takeWhile (/= "--") $ words s of
(pattern:constr:rest) -> (pattern:constr:rest) ->
let pieces = piecesFromString $ drop1Slash pattern let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
in Just $ Resource constr pieces rest disp = dispatchFromString rest mmulti
in Just $ Resource constr pieces disp
[] -> Nothing [] -> Nothing
_ -> error $ "Invalid resource line: " ++ s _ -> error $ "Invalid resource line: " ++ s
dispatchFromString :: [String] -> Maybe Type -> Dispatch
dispatchFromString rest mmulti
| null rest = Methods mmulti []
| all (all isUpper) rest = Methods mmulti rest
dispatchFromString [subTyp, subFun] Nothing =
Subsite (parseType subTyp) subFun
dispatchFromString [subTyp, subFun] Just{} =
error "Subsites cannot have a multipiece"
dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
drop1Slash :: String -> String drop1Slash :: String -> String
drop1Slash ('/':x) = x drop1Slash ('/':x) = x
drop1Slash x = x drop1Slash x = x
piecesFromString :: String -> [Piece] piecesFromString :: String -> ([Piece], Maybe Type)
piecesFromString "" = [] piecesFromString "" = ([], Nothing)
piecesFromString x = piecesFromString x =
let (y, z) = break (== '/') x case (this, rest) of
in pieceFromString y : piecesFromString (drop1Slash z) (Left typ, ([], Nothing)) -> ([], Just typ)
(Left typ, _) -> error "Multipiece must be last piece"
(Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)
where
(y, z) = break (== '/') x
this = pieceFromString y
rest = piecesFromString $ drop 1 z
pieceFromString :: String -> Piece parseType :: String -> Type
pieceFromString ('#':x) = SinglePiece x parseType = ConT . mkName -- FIXME handle more complicated stuff
pieceFromString ('*':x) = MultiPiece x
pieceFromString x = StaticPiece x pieceFromString :: String -> Either Type Piece
pieceFromString ('#':x) = Right $ Dynamic $ parseType x
pieceFromString ('*':x) = Left $ parseType x
pieceFromString x = Right $ Static x
-- n^2, should be a way to speed it up -- n^2, should be a way to speed it up
findOverlaps :: [Resource] -> [(Resource, Resource)] findOverlaps :: [Resource] -> [[Resource]]
findOverlaps = go . map justPieces findOverlaps = go . map justPieces
where where
justPieces :: Resource -> ([Piece], Resource) justPieces :: Resource -> ([Piece], Resource)
@ -342,8 +130,10 @@ findOverlaps = go . map justPieces
go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
mOverlap :: ([Piece], Resource) -> ([Piece], Resource) -> mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
Maybe (Resource, Resource) Maybe [Resource]
mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr) mOverlap _ _ = Nothing
{- FIXME mOverlap
mOverlap (Static x:xs, xr) (Static y:ys, yr)
| x == y = mOverlap (xs, xr) (ys, yr) | x == y = mOverlap (xs, xr) (ys, yr)
| otherwise = Nothing | otherwise = Nothing
mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr) mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
@ -352,3 +142,4 @@ findOverlaps = go . map justPieces
mOverlap ([], _) (_, _) = Nothing mOverlap ([], _) (_, _) = Nothing
mOverlap (_, _) ([], _) = Nothing mOverlap (_, _) ([], _) = Nothing
mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr) mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)
-}

3
yesod-core/Yesod/Widget.hs
View File

@ -63,8 +63,9 @@ import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
import Text.Coffee import Text.Coffee
import Yesod.Routes.Class
import Yesod.Handler import Yesod.Handler
( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams, MonadLift (..) , getMessageRender, getUrlRenderParams, MonadLift (..)
) )
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)

9
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -20,14 +20,13 @@ data Subsite = Subsite
getSubsite :: a -> Subsite getSubsite :: a -> Subsite
getSubsite = const Subsite getSubsite = const Subsite
data SubsiteRoute = SubsiteRoute [TS.Text] instance RenderRoute Subsite where
deriving (Eq, Show, Read) data Route Subsite = SubsiteRoute [TS.Text]
type instance Route Subsite = SubsiteRoute deriving (Eq, Show, Read)
instance RenderRoute SubsiteRoute where
renderRoute (SubsiteRoute x) = (x, []) renderRoute (SubsiteRoute x) = (x, [])
instance YesodDispatch Subsite master where instance YesodDispatch Subsite master where
yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
status200 status200
[ ("Content-Type", "SUBSITE") [ ("Content-Type", "SUBSITE")
] $ L8.pack $ show pieces ] $ L8.pack $ show pieces

2
yesod-core/yesod-core.cabal
View File

@ -46,6 +46,7 @@ library
build-depends: wai-test build-depends: wai-test
build-depends: time >= 1.1.4 build-depends: time >= 1.1.4
, yesod-routes >= 0.0 && < 0.1
, wai >= 1.0 && < 1.1 , wai >= 1.0 && < 1.1
, wai-extra >= 1.0 && < 1.1 , wai-extra >= 1.0 && < 1.1
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
@ -94,7 +95,6 @@ library
Yesod.Internal.Core Yesod.Internal.Core
Yesod.Internal.Session Yesod.Internal.Session
Yesod.Internal.Request Yesod.Internal.Request
Yesod.Internal.Dispatch
Yesod.Internal.RouteParsing Yesod.Internal.RouteParsing
Paths_yesod_core Paths_yesod_core
ghc-options: -Wall ghc-options: -Wall

83
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -8,7 +8,7 @@ import Prelude hiding (exp)
import Yesod.Routes.TH.Types import Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Control.Monad (forM) import Control.Monad (forM, replicateM)
import Data.Text (pack) import Data.Text (pack)
import qualified Yesod.Routes.Dispatch as D import qualified Yesod.Routes.Dispatch as D
import qualified Data.Map as Map import qualified Data.Map as Map
@ -66,9 +66,10 @@ import Data.List (foldl')
-- request method and path pieces. -- request method and path pieces.
mkDispatchClause :: Q Exp -- ^ runHandler function mkDispatchClause :: Q Exp -- ^ runHandler function
-> Q Exp -- ^ dispatcher function -> Q Exp -- ^ dispatcher function
-> Q Exp -- ^ fixHandler function
-> [Resource] -> [Resource]
-> Q Clause -> Q Clause
mkDispatchClause runHandler dispatcher ress = do mkDispatchClause runHandler dispatcher fixHandler ress = do
-- Allocate the names to be used. Start off with the names passed to the -- Allocate the names to be used. Start off with the names passed to the
-- function itself (with a 0 suffix). -- function itself (with a 0 suffix).
-- --
@ -91,7 +92,7 @@ mkDispatchClause runHandler dispatcher ress = do
let dispatched = VarE dispatch `AppE` VarE pieces0 let dispatched = VarE dispatch `AppE` VarE pieces0
-- The 'D.Route's used in the dispatch function -- The 'D.Route's used in the dispatch function
routes <- mapM (buildRoute runHandler dispatcher) ress routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress
-- The dispatch function itself -- The dispatch function itself
toDispatch <- [|D.toDispatch|] toDispatch <- [|D.toDispatch|]
@ -101,7 +102,7 @@ mkDispatchClause runHandler dispatcher ress = do
let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0] let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
-- For each resource that dispatches based on methods, build up a map for handling the dispatching. -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
methodMaps <- catMaybes <$> mapM buildMethodMap ress methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress
u <- [|case $(return dispatched) of u <- [|case $(return dispatched) of
Just f -> f $(return $ VarE master0) Just f -> f $(return $ VarE master0)
@ -118,9 +119,11 @@ mkDispatchClause runHandler dispatcher ress = do
methodMapName :: String -> Name methodMapName :: String -> Name
methodMapName s = mkName $ "methods" ++ s methodMapName s = mkName $ "methods" ++ s
buildMethodMap :: Resource -> Q (Maybe Dec) buildMethodMap :: Q Exp -- ^ fixHandler
buildMethodMap (Resource _ _ (Methods _ [])) = return Nothing -- single handle function -> Resource
buildMethodMap (Resource name _ (Methods _ methods)) = do -> Q (Maybe Dec)
buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
fromList <- [|Map.fromList|] fromList <- [|Map.fromList|]
methods' <- mapM go methods methods' <- mapM go methods
let exp = fromList `AppE` ListE methods' let exp = fromList `AppE` ListE methods'
@ -128,14 +131,20 @@ buildMethodMap (Resource name _ (Methods _ methods)) = do
return $ Just fun return $ Just fun
where where
go method = do go method = do
fh <- fixHandler
let func = VarE $ mkName $ map toLower method ++ name let func = VarE $ mkName $ map toLower method ++ name
pack' <- [|pack|] pack' <- [|pack|]
return $ TupE [pack' `AppE` LitE (StringL method), func] let isDynamic Dynamic{} = True
buildMethodMap (Resource _ _ Subsite{}) = return Nothing isDynamic _ = False
let argCount = length (filter isDynamic pieces) + maybe 0 (const 1) mmulti
xs <- replicateM argCount $ newName "arg"
let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
return $ TupE [pack' `AppE` LitE (StringL method), rhs]
buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing
-- | Build a single 'D.Route' expression. -- | Build a single 'D.Route' expression.
buildRoute :: Q Exp -> Q Exp -> Resource -> Q Exp buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource -> Q Exp
buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
-- First two arguments to D.Route -- First two arguments to D.Route
routePieces <- ListE <$> mapM convertPiece resPieces routePieces <- ListE <$> mapM convertPiece resPieces
isMulti <- isMulti <-
@ -143,15 +152,16 @@ buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
Methods Nothing _ -> [|False|] Methods Nothing _ -> [|False|]
_ -> [|True|] _ -> [|True|]
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|] [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name resPieces resDisp)|]
routeArg3 :: Q Exp -- ^ runHandler routeArg3 :: Q Exp -- ^ runHandler
-> Q Exp -- ^ dispatcher -> Q Exp -- ^ dispatcher
-> Q Exp -- ^ fixHandler
-> String -- ^ name of resource -> String -- ^ name of resource
-> [Piece] -> [Piece]
-> Dispatch -> Dispatch
-> Q Exp -> Q Exp
routeArg3 runHandler dispatcher name resPieces resDisp = do routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
pieces <- newName "pieces" pieces <- newName "pieces"
-- Allocate input piece variables (xs) and variables that have been -- Allocate input piece variables (xs) and variables that have been
@ -190,7 +200,7 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
_ -> return ([], []) _ -> return ([], [])
-- The final expression that actually uses the values we've computed -- The final expression that actually uses the values we've computed
caller <- buildCaller runHandler dispatcher xrest name resDisp $ map snd ys ++ yrest' caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest'
-- Put together all the statements -- Put together all the statements
just <- [|Just|] just <- [|Just|]
@ -211,12 +221,13 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
-- | The final expression in the individual Route definitions. -- | The final expression in the individual Route definitions.
buildCaller :: Q Exp -- ^ runHandler buildCaller :: Q Exp -- ^ runHandler
-> Q Exp -- ^ dispatcher -> Q Exp -- ^ dispatcher
-> Q Exp -- ^ fixHandler
-> Name -- ^ xrest -> Name -- ^ xrest
-> String -- ^ name of resource -> String -- ^ name of resource
-> Dispatch -> Dispatch
-> [Name] -- ^ ys -> [Name] -- ^ ys
-> Q Exp -> Q Exp
buildCaller runHandler dispatcher xrest name resDisp ys = do buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
master <- newName "master" master <- newName "master"
sub <- newName "sub" sub <- newName "sub"
toMaster <- newName "toMaster" toMaster <- newName "toMaster"
@ -234,28 +245,36 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
Methods _ ms -> do Methods _ ms -> do
handler <- newName "handler" handler <- newName "handler"
-- Figure out what the handler is
handlerExp <-
if null ms
then return $ foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
else do
mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
f <- newName "f"
let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
return $ CaseE mf
[ Match (ConP 'Just [VarP f]) (NormalB apply) []
, Match (ConP 'Nothing []) (NormalB $ VarE handler405) []
]
-- Run the whole thing -- Run the whole thing
runner <- [|$(runHandler) runner <- [|$(runHandler)
$(return $ VarE handler) $(return $ VarE handler)
$(return $ VarE master) $(return $ VarE master)
$(return $ VarE sub) $(return $ VarE sub)
$(return route) (Just $(return route))
$(return $ VarE toMaster)|] $(return $ VarE toMaster)|]
return $ LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner let myLet handlerExp =
LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
if null ms
then do
-- Just a single handler
fh <- fixHandler
let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
return $ myLet he
else do
-- Individual methods
mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
f <- newName "f"
let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
let body405 =
VarE handler405
`AppE` route
return $ CaseE mf
[ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
, Match (ConP 'Nothing []) (NormalB body405) []
]
Subsite _ getSub -> do Subsite _ getSub -> do
let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
[|$(dispatcher) [|$(dispatcher)
@ -263,7 +282,7 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
$(return sub2) $(return sub2)
($(return $ VarE toMaster) . $(return route)) ($(return $ VarE toMaster) . $(return route))
$(return $ VarE app404) $(return $ VarE app404)
$(return $ VarE handler405) ($(return $ VarE handler405) . $(return route))
$(return $ VarE method) $(return $ VarE method)
$(return $ VarE xrest) $(return $ VarE xrest)
|] |]
@ -272,5 +291,5 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
-- | Convert a 'Piece' to a 'D.Piece' -- | Convert a 'Piece' to a 'D.Piece'
convertPiece :: Piece -> Q Exp convertPiece :: Piece -> Q Exp
convertPiece (Static s) = [|D.Static $(lift s)|] convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|] convertPiece (Dynamic _) = [|D.Dynamic|]

44
yesod-routes/Yesod/Routes/TH/Types.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
module Yesod.Routes.TH.Types module Yesod.Routes.TH.Types
( -- * Data types ( -- * Data types
Resource (..) Resource (..)
@ -9,13 +10,48 @@ module Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
liftOccName :: OccName -> Q Exp
liftOccName oc = [|mkOccName $(lift $ occString oc)|]
liftNameFlavour :: NameFlavour -> Q Exp
liftNameFlavour NameS = [|NameS|]
liftName :: Name -> Q Exp
liftName (Name a b) = [|Name $(liftOccName a) $(liftNameFlavour b)|]
liftType :: Type -> Q Exp
liftType (VarT name) = [|VarT $(liftName name)|]
liftType (ConT name) = [|ConT $(liftName name)|]
liftType (TupleT i) = [|TupleT $(lift i)|]
liftType ArrowT = [|ArrowT|]
liftType ListT = [|ListT|]
liftType (AppT a b) = [|AppT $(liftType a) $(liftType b)|]
liftType (SigT a b) = [|SigT $(liftType a) $(liftKind b)|]
liftKind :: Kind -> Q Exp
liftKind StarK = [|StarK|]
liftKind (ArrowK a b) = [|ArrowK $(liftKind a) $(liftKind b)|]
data Resource = Resource data Resource = Resource
{ resourceName :: String { resourceName :: String
, resourcePieces :: [Piece] , resourcePieces :: [Piece]
, resourceDispatch :: Dispatch , resourceDispatch :: Dispatch
} }
deriving Show
{-
instance Lift Resource where
lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
-}
data Piece = Static String | Dynamic Type data Piece = Static String | Dynamic Type
deriving Show
{-
instance Lift Piece where
lift (Static s) = [|Static $(lift s)|]
lift (Dynamic t) = [|Static $(liftType t)|]
-}
data Dispatch = data Dispatch =
Methods Methods
@ -26,6 +62,14 @@ data Dispatch =
{ subsiteType :: Type { subsiteType :: Type
, subsiteFunc :: String , subsiteFunc :: String
} }
deriving Show
{-
instance Lift Dispatch where
lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
lift (Methods (Just t) b) = [|Methods (Just $(liftType t)) $(lift b)|]
lift (Subsite t b) = [|Subsite $(liftType t) $(lift b)|]
-}
resourceMulti :: Resource -> Maybe Type resourceMulti :: Resource -> Maybe Type
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t

79
yesod-routes/test/main.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
@ -10,7 +9,7 @@
import Test.Hspec.Monadic import Test.Hspec.Monadic
import Test.Hspec.HUnit () import Test.Hspec.HUnit ()
import Test.HUnit ((@?=)) import Test.HUnit ((@?=))
import Data.Text (Text, unpack, singleton) import Data.Text (Text, pack, unpack, singleton)
import Yesod.Routes.Dispatch hiding (Static, Dynamic) import Yesod.Routes.Dispatch hiding (Static, Dynamic)
import Yesod.Routes.Class hiding (Route) import Yesod.Routes.Class hiding (Route)
import qualified Yesod.Routes.Class as YRC import qualified Yesod.Routes.Class as YRC
@ -18,6 +17,12 @@ import qualified Yesod.Routes.Dispatch as D
import Yesod.Routes.TH hiding (Dispatch) import Yesod.Routes.TH hiding (Dispatch)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
result :: ([Text] -> Maybe Int) -> Dispatch Int result :: ([Text] -> Maybe Int) -> Dispatch Int
result f ts = f ts result f ts = f ts
@ -28,19 +33,19 @@ justRoot = toDispatch
twoStatics :: Dispatch Int twoStatics :: Dispatch Int
twoStatics = toDispatch twoStatics = toDispatch
[ Route [D.Static "foo"] False $ result $ const $ Just 2 [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 2
, Route [D.Static "bar"] False $ result $ const $ Just 3 , Route [D.Static $ pack "bar"] False $ result $ const $ Just 3
] ]
multi :: Dispatch Int multi :: Dispatch Int
multi = toDispatch multi = toDispatch
[ Route [D.Static "foo"] False $ result $ const $ Just 4 [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 4
, Route [D.Static "bar"] True $ result $ const $ Just 5 , Route [D.Static $ pack "bar"] True $ result $ const $ Just 5
] ]
dynamic :: Dispatch Int dynamic :: Dispatch Int
dynamic = toDispatch dynamic = toDispatch
[ Route [D.Static "foo"] False $ result $ const $ Just 6 [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 6
, Route [D.Dynamic] False $ result $ \ts -> , Route [D.Dynamic] False $ result $ \ts ->
case ts of case ts of
[t] -> [t] ->
@ -52,13 +57,13 @@ dynamic = toDispatch
overlap :: Dispatch Int overlap :: Dispatch Int
overlap = toDispatch overlap = toDispatch
[ Route [D.Static "foo"] False $ result $ const $ Just 20 [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 20
, Route [D.Static "foo"] True $ result $ const $ Just 21 , Route [D.Static $ pack "foo"] True $ result $ const $ Just 21
, Route [] True $ result $ const $ Just 22 , Route [] True $ result $ const $ Just 22
] ]
test :: Dispatch Int -> [Text] -> Maybe Int test :: Dispatch Int -> [String] -> Maybe Int
test dispatch ts = dispatch ts test dispatch ts = dispatch $ map pack ts
data MyApp = MyApp data MyApp = MyApp
@ -80,8 +85,8 @@ instance RenderRoute MySubParam where
getMySubParam :: MyApp -> Int -> MySubParam getMySubParam :: MyApp -> Int -> MySubParam
getMySubParam _ = MySubParam getMySubParam _ = MySubParam
type Handler sub master = String type Handler sub master = Text
type App sub master = (String, Maybe (YRC.Route master)) type App sub master = (Text, Maybe (YRC.Route master))
class Dispatcher sub master where class Dispatcher sub master where
dispatcher dispatcher
@ -89,7 +94,7 @@ class Dispatcher sub master where
-> sub -> sub
-> (YRC.Route sub -> YRC.Route master) -> (YRC.Route sub -> YRC.Route master)
-> App sub master -- ^ 404 page -> App sub master -- ^ 404 page
-> Handler sub master -- ^ 405 page -> (YRC.Route sub -> App sub master) -- ^ 405 page
-> Text -- ^ method -> Text -- ^ method
-> [Text] -> [Text]
-> App sub master -> App sub master
@ -99,7 +104,7 @@ class RunHandler sub master where
:: Handler sub master :: Handler sub master
-> master -> master
-> sub -> sub
-> YRC.Route sub -> Maybe (YRC.Route sub)
-> (YRC.Route sub -> YRC.Route master) -> (YRC.Route sub -> YRC.Route master)
-> App sub master -> App sub master
@ -113,7 +118,7 @@ do
, Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam" , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
] ]
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
return return
[ rrinst [ rrinst
, InstanceD , InstanceD
@ -125,15 +130,15 @@ do
] ]
instance RunHandler MyApp master where instance RunHandler MyApp master where
runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute) runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
instance Dispatcher MySub master where instance Dispatcher MySub master where
dispatcher _ _ toMaster _ _ _ pieces = ("subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, [])) dispatcher _ _ toMaster _ _ _ pieces = (pack $ "subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
instance Dispatcher MySubParam master where instance Dispatcher MySubParam master where
dispatcher _ (MySubParam i) toMaster app404 _ _ pieces = dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
case map unpack pieces of case map unpack pieces of
[[c]] -> ("subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c) [[c]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
_ -> app404 _ -> app404
{- {-
@ -232,37 +237,37 @@ main = hspecX $ do
describe "RenderRoute instance" $ do describe "RenderRoute instance" $ do
it "renders root correctly" $ renderRoute RootR @?= ([], []) it "renders root correctly" $ renderRoute RootR @?= ([], [])
it "renders blog post correctly" $ renderRoute (BlogPostR "foo") @?= (["blog", "foo"], []) it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], [])
it "renders wiki correctly" $ renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], []) it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], [])
it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")])) it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")]))
@?= (["subsite", "foo", "bar"], [("baz", "bin")]) @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")])
it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c') it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c')
@?= (["subparam", "6", "c"], []) @?= (map pack ["subparam", "6", "c"], [])
describe "thDispatch" $ do describe "thDispatch" $ do
let disp = dispatcher MyApp MyApp id ("404" :: String, Nothing) "405" let disp m ps = dispatcher MyApp MyApp id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
it "routes to root" $ disp "GET" [] @?= ("this is the root", Just RootR) it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR)
it "POST root is 405" $ disp "POST" [] @?= ("405", Just RootR) it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)
it "invalid page is a 404" $ disp "GET" ["not-found"] @?= ("404", Nothing) it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing)
it "routes to blog post" $ disp "GET" ["blog", "somepost"] it "routes to blog post" $ disp "GET" ["blog", "somepost"]
@?= ("some blog post: somepost", Just $ BlogPostR "somepost") @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost")
it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"] it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]
@?= ("POST some blog post: somepost2", Just $ BlogPostR "somepost2") @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2")
it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"] it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"]
@?= ("the wiki: [\"foo\",\"bar\"]", Just $ WikiR ["foo", "bar"]) @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"])
it "routes to subsite" $ disp "PUT" ["subsite", "baz"] it "routes to subsite" $ disp "PUT" ["subsite", "baz"]
@?= ("subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute (["baz"], [])) @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], []))
it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"] it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
@?= ("subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q') @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
getRootR :: String getRootR :: Text
getRootR = "this is the root" getRootR = pack "this is the root"
getBlogPostR :: Text -> String getBlogPostR :: Text -> String
getBlogPostR t = "some blog post: " ++ unpack t getBlogPostR t = "some blog post: " ++ unpack t
postBlogPostR :: Text -> String postBlogPostR :: Text -> Text
postBlogPostR t = "POST some blog post: " ++ unpack t postBlogPostR t = pack $ "POST some blog post: " ++ unpack t
handleWikiR :: [Text] -> String handleWikiR :: [Text] -> String
handleWikiR ts = "the wiki: " ++ show ts handleWikiR ts = "the wiki: " ++ show ts