yesod-core compiles with yesod-routes (tests fail)
This commit is contained in:
Michael Snoyman
parent
fa4fd5690f
commit
c499e880b6
@ -1,6 +1,7 @@
|
||||
#!/bin/bash
|
||||
|
||||
pkgs=( ./yesod-core
|
||||
pkgs=( ./yesod-routes
|
||||
./yesod-core
|
||||
./yesod-json
|
||||
./yesod-static
|
||||
./yesod-persistent
|
||||
|
||||
@ -28,11 +28,10 @@ import Data.Either (partitionEithers)
|
||||
import Prelude hiding (exp)
|
||||
import Yesod.Internal.Core
|
||||
import Yesod.Handler hiding (lift)
|
||||
import Yesod.Internal.Dispatch
|
||||
import Yesod.Widget (GWidget)
|
||||
|
||||
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 qualified Network.Wai as W
|
||||
@ -44,6 +43,13 @@ import Data.ByteString.Lazy.Char8 ()
|
||||
import Web.ClientSession
|
||||
import Data.Char (isUpper)
|
||||
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]
|
||||
|
||||
@ -51,7 +57,7 @@ type Texts = [Text]
|
||||
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
|
||||
-- Use 'parseRoutes' to create the 'Resource's.
|
||||
mkYesod :: String -- ^ name of the argument datatype
|
||||
-> [Resource]
|
||||
-> RouteString
|
||||
-> Q [Dec]
|
||||
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
|
||||
|
||||
@ -62,7 +68,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
|
||||
-- be embedded in other sites.
|
||||
mkYesodSub :: String -- ^ name of the argument datatype
|
||||
-> Cxt
|
||||
-> [Resource]
|
||||
-> RouteString
|
||||
-> Q [Dec]
|
||||
mkYesodSub name clazzes =
|
||||
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
|
||||
-- monolithic file into smaller parts. Use this function, paired with
|
||||
-- 'mkYesodDispatch', to do just that.
|
||||
mkYesodData :: String -> [Resource] -> Q [Dec]
|
||||
mkYesodData :: String -> RouteString -> Q [Dec]
|
||||
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
|
||||
|
||||
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec]
|
||||
mkYesodDataGeneral :: String -> Cxt -> Bool -> RouteString -> Q [Dec]
|
||||
mkYesodDataGeneral name clazzes isSub res = do
|
||||
let (name':rest) = words name
|
||||
(x, _) <- mkYesodGeneral name' rest clazzes isSub res
|
||||
let rname = mkName $ "resources" ++ name
|
||||
eres <- lift res
|
||||
eres <- [|parseRouteString $(lift res)|]
|
||||
let y = [ SigD rname $ ListT `AppT` ConT ''Resource
|
||||
, FunD rname [Clause [] (NormalB eres) []]
|
||||
]
|
||||
return $ x ++ y
|
||||
|
||||
-- | See 'mkYesodData'.
|
||||
mkYesodDispatch :: String -> [Resource] -> Q [Dec]
|
||||
mkYesodDispatch :: String -> RouteString -> Q [Dec]
|
||||
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
|
||||
where (name':rest) = words name
|
||||
|
||||
@ -102,40 +108,26 @@ mkYesodGeneral :: String -- ^ foundation name
|
||||
-> [String] -- ^ parameters for foundation
|
||||
-> Cxt -- ^ classes
|
||||
-> Bool -- ^ is subsite?
|
||||
-> [Resource]
|
||||
-> RouteString
|
||||
-> Q ([Dec], [Dec])
|
||||
mkYesodGeneral name args clazzes isSub res = do
|
||||
let args' = map mkName args
|
||||
arg = foldl AppT (ConT name') $ map VarT args'
|
||||
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
|
||||
mkYesodGeneral name args clazzes isSub resS = do
|
||||
let res = parseRouteString resS
|
||||
renderRouteDec <- mkRenderRouteInstance (ConT name') res
|
||||
|
||||
render <- createRender th
|
||||
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
|
||||
disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
|
||||
let master = mkName "master"
|
||||
let ctx = if isSub
|
||||
then ClassP (mkName "Yesod") [VarT master] : clazzes
|
||||
else []
|
||||
let args' = map mkName args
|
||||
arg = foldl AppT (ConT name') $ map VarT args'
|
||||
let ytyp = if isSub
|
||||
then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
|
||||
else ConT ''YesodDispatch `AppT` arg `AppT` arg
|
||||
let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
|
||||
return ([w, x, x'] ++ masterTypSyns, [y])
|
||||
let yesodDispatch =
|
||||
InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
|
||||
|
||||
return (renderRouteDec : masterTypSyns, [yesodDispatch])
|
||||
where
|
||||
name' = mkName name
|
||||
masterTypSyns
|
||||
@ -151,45 +143,46 @@ mkYesodGeneral name args clazzes isSub res = do
|
||||
(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
|
||||
-- handler. This is the same as 'toWaiAppPlain', except it includes two
|
||||
-- middlewares: GZIP compression and autohead. This is the
|
||||
-- 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
|
||||
|
||||
-- | Convert the given argument into a WAI application, executable with any WAI
|
||||
-- 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
|
||||
|
||||
|
||||
toWaiApp' :: (Yesod y, YesodDispatch y y)
|
||||
=> y
|
||||
toWaiApp' :: ( Yesod master
|
||||
, YesodDispatch master master
|
||||
)
|
||||
=> master
|
||||
-> Maybe Key
|
||||
-> W.Application
|
||||
toWaiApp' y key' env =
|
||||
case yesodDispatch y key' (W.pathInfo env) y id of
|
||||
Just app -> app env
|
||||
Nothing -> yesodRunner y y id key' Nothing notFound env
|
||||
yesodDispatch y y id app404 handler405 method (W.pathInfo env) key' env
|
||||
where
|
||||
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))
|
||||
|
||||
@ -24,8 +24,7 @@
|
||||
---------------------------------------------------------
|
||||
module Yesod.Handler
|
||||
( -- * Type families
|
||||
Route
|
||||
, YesodSubRoute (..)
|
||||
YesodSubRoute (..)
|
||||
-- * Handler monad
|
||||
, GHandler
|
||||
-- ** Read information from handler
|
||||
@ -174,9 +173,7 @@ import Network.Wai (requestBody)
|
||||
import Data.Conduit (($$))
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Base
|
||||
|
||||
-- | The type-safe URLs associated with a site argument.
|
||||
type family Route a
|
||||
import Yesod.Routes.Class
|
||||
|
||||
class YesodSubRoute s y where
|
||||
fromSubRoute :: s -> y -> Route s -> Route y
|
||||
|
||||
@ -33,6 +33,8 @@ module Yesod.Internal.Core
|
||||
import Yesod.Content
|
||||
import Yesod.Handler hiding (lift)
|
||||
|
||||
import Yesod.Routes.Class
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Monad (forM)
|
||||
import Yesod.Widget
|
||||
@ -92,31 +94,34 @@ yesodVersion = "0.9.4"
|
||||
#define HAMLET $hamlet
|
||||
#endif
|
||||
|
||||
class Eq u => RenderRoute u where
|
||||
renderRoute :: u -> ([Text], [(Text, Text)])
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
class YesodDispatch a master where
|
||||
class YesodDispatch sub master where
|
||||
yesodDispatch
|
||||
:: 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
|
||||
-> [Text]
|
||||
-> master
|
||||
-> (Route a -> Route master)
|
||||
-> Maybe W.Application
|
||||
-> W.Application
|
||||
|
||||
yesodRunner :: Yesod master
|
||||
=> a
|
||||
=> GHandler sub master ChooseRep
|
||||
-> master
|
||||
-> (Route a -> Route master)
|
||||
-> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
|
||||
-> sub
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> Maybe CS.Key
|
||||
-> W.Application
|
||||
yesodRunner = defaultYesodRunner
|
||||
|
||||
-- | Define settings for a Yesod applications. The only required setting is
|
||||
-- '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
|
||||
-- trailing slash.
|
||||
--
|
||||
@ -322,14 +327,14 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
|
||||
char = show . snd . loc_start
|
||||
|
||||
defaultYesodRunner :: Yesod master
|
||||
=> a
|
||||
=> GHandler sub master ChooseRep
|
||||
-> master
|
||||
-> (Route a -> Route master)
|
||||
-> sub
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> Maybe CS.Key
|
||||
-> Maybe (Route a)
|
||||
-> GHandler a master ChooseRep
|
||||
-> W.Application
|
||||
defaultYesodRunner _ m toMaster _ murl _ req
|
||||
defaultYesodRunner _ m _ murl toMaster _ req
|
||||
| maximumContentLength m (fmap toMaster murl) < len =
|
||||
return $ W.responseLBS
|
||||
(H.Status 413 "Too Large")
|
||||
@ -341,7 +346,7 @@ defaultYesodRunner _ m toMaster _ murl _ req
|
||||
case reads $ S8.unpack s of
|
||||
[] -> Nothing
|
||||
(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
|
||||
let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
|
||||
let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
|
||||
@ -374,7 +379,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
|
||||
handler
|
||||
let sessionMap = Map.fromList
|
||||
$ 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
|
||||
-- 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
|
||||
|
||||
@ -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
|
||||
@ -2,18 +2,12 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
|
||||
module Yesod.Internal.RouteParsing
|
||||
( createRoutes
|
||||
, createRender
|
||||
, createParse
|
||||
, createDispatch
|
||||
, Pieces (..)
|
||||
, THResource
|
||||
, parseRoutes
|
||||
( parseRoutes
|
||||
, parseRoutesFile
|
||||
, parseRoutesNoCheck
|
||||
, parseRoutesFileNoCheck
|
||||
, Resource (..)
|
||||
, Piece (..)
|
||||
, RouteString
|
||||
, parseRouteString
|
||||
) where
|
||||
|
||||
import Web.PathPieces
|
||||
@ -21,204 +15,12 @@ import Language.Haskell.TH.Syntax
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Char (toLower)
|
||||
import Data.Char (toLower, isUpper)
|
||||
import qualified Data.Text
|
||||
import Language.Haskell.TH.Quote
|
||||
import Data.Data
|
||||
import qualified System.IO as SIO
|
||||
|
||||
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)) []
|
||||
import Yesod.Routes.TH
|
||||
|
||||
-- | 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
|
||||
@ -226,15 +28,24 @@ createDispatch modMaster toMaster = mapM go
|
||||
parseRoutes :: QuasiQuoter
|
||||
parseRoutes = QuasiQuoter
|
||||
{ quoteExp = x
|
||||
, quotePat = y
|
||||
}
|
||||
where
|
||||
x s = do
|
||||
let res = resourcesFromString s
|
||||
case findOverlaps res of
|
||||
[] -> lift res
|
||||
z -> error $ "Overlapping routes: " ++ unlines (map show z)
|
||||
y = dataToPatQ (const Nothing) . resourcesFromString
|
||||
[] -> liftParse s
|
||||
z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z)
|
||||
|
||||
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 fp = do
|
||||
@ -255,51 +66,8 @@ readUtf8File fp = do
|
||||
-- | Same as 'parseRoutes', but performs no overlap checking.
|
||||
parseRoutesNoCheck :: QuasiQuoter
|
||||
parseRoutesNoCheck = QuasiQuoter
|
||||
{ quoteExp = x
|
||||
, quotePat = y
|
||||
{ quoteExp = liftParse
|
||||
}
|
||||
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
|
||||
-- the format of this string. This is a partial function which calls 'error' on
|
||||
@ -311,28 +79,48 @@ resourcesFromString =
|
||||
go s =
|
||||
case takeWhile (/= "--") $ words s of
|
||||
(pattern:constr:rest) ->
|
||||
let pieces = piecesFromString $ drop1Slash pattern
|
||||
in Just $ Resource constr pieces rest
|
||||
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
|
||||
disp = dispatchFromString rest mmulti
|
||||
in Just $ Resource constr pieces disp
|
||||
[] -> Nothing
|
||||
_ -> 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 ('/':x) = x
|
||||
drop1Slash x = x
|
||||
|
||||
piecesFromString :: String -> [Piece]
|
||||
piecesFromString "" = []
|
||||
piecesFromString :: String -> ([Piece], Maybe Type)
|
||||
piecesFromString "" = ([], Nothing)
|
||||
piecesFromString x =
|
||||
let (y, z) = break (== '/') x
|
||||
in pieceFromString y : piecesFromString (drop1Slash z)
|
||||
case (this, rest) of
|
||||
(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
|
||||
pieceFromString ('#':x) = SinglePiece x
|
||||
pieceFromString ('*':x) = MultiPiece x
|
||||
pieceFromString x = StaticPiece x
|
||||
parseType :: String -> Type
|
||||
parseType = ConT . mkName -- FIXME handle more complicated stuff
|
||||
|
||||
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
|
||||
findOverlaps :: [Resource] -> [(Resource, Resource)]
|
||||
findOverlaps :: [Resource] -> [[Resource]]
|
||||
findOverlaps = go . map justPieces
|
||||
where
|
||||
justPieces :: Resource -> ([Piece], Resource)
|
||||
@ -342,8 +130,10 @@ findOverlaps = go . map justPieces
|
||||
go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
|
||||
|
||||
mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
|
||||
Maybe (Resource, Resource)
|
||||
mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
|
||||
Maybe [Resource]
|
||||
mOverlap _ _ = Nothing
|
||||
{- FIXME mOverlap
|
||||
mOverlap (Static x:xs, xr) (Static y:ys, yr)
|
||||
| x == y = mOverlap (xs, xr) (ys, yr)
|
||||
| otherwise = Nothing
|
||||
mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
|
||||
@ -352,3 +142,4 @@ findOverlaps = go . map justPieces
|
||||
mOverlap ([], _) (_, _) = Nothing
|
||||
mOverlap (_, _) ([], _) = Nothing
|
||||
mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)
|
||||
-}
|
||||
|
||||
@ -63,8 +63,9 @@ import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Julius
|
||||
import Text.Coffee
|
||||
import Yesod.Routes.Class
|
||||
import Yesod.Handler
|
||||
( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
, getMessageRender, getUrlRenderParams, MonadLift (..)
|
||||
)
|
||||
import Yesod.Message (RenderMessage)
|
||||
|
||||
@ -20,14 +20,13 @@ data Subsite = Subsite
|
||||
getSubsite :: a -> Subsite
|
||||
getSubsite = const Subsite
|
||||
|
||||
data SubsiteRoute = SubsiteRoute [TS.Text]
|
||||
deriving (Eq, Show, Read)
|
||||
type instance Route Subsite = SubsiteRoute
|
||||
instance RenderRoute SubsiteRoute where
|
||||
instance RenderRoute Subsite where
|
||||
data Route Subsite = SubsiteRoute [TS.Text]
|
||||
deriving (Eq, Show, Read)
|
||||
renderRoute (SubsiteRoute x) = (x, [])
|
||||
|
||||
instance YesodDispatch Subsite master where
|
||||
yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS
|
||||
yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
|
||||
status200
|
||||
[ ("Content-Type", "SUBSITE")
|
||||
] $ L8.pack $ show pieces
|
||||
|
||||
@ -46,6 +46,7 @@ library
|
||||
build-depends: wai-test
|
||||
|
||||
build-depends: time >= 1.1.4
|
||||
, yesod-routes >= 0.0 && < 0.1
|
||||
, wai >= 1.0 && < 1.1
|
||||
, wai-extra >= 1.0 && < 1.1
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
@ -94,7 +95,6 @@ library
|
||||
Yesod.Internal.Core
|
||||
Yesod.Internal.Session
|
||||
Yesod.Internal.Request
|
||||
Yesod.Internal.Dispatch
|
||||
Yesod.Internal.RouteParsing
|
||||
Paths_yesod_core
|
||||
ghc-options: -Wall
|
||||
|
||||
@ -8,7 +8,7 @@ import Prelude hiding (exp)
|
||||
import Yesod.Routes.TH.Types
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Maybe (catMaybes)
|
||||
import Control.Monad (forM)
|
||||
import Control.Monad (forM, replicateM)
|
||||
import Data.Text (pack)
|
||||
import qualified Yesod.Routes.Dispatch as D
|
||||
import qualified Data.Map as Map
|
||||
@ -66,9 +66,10 @@ import Data.List (foldl')
|
||||
-- request method and path pieces.
|
||||
mkDispatchClause :: Q Exp -- ^ runHandler function
|
||||
-> Q Exp -- ^ dispatcher function
|
||||
-> Q Exp -- ^ fixHandler function
|
||||
-> [Resource]
|
||||
-> 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
|
||||
-- function itself (with a 0 suffix).
|
||||
--
|
||||
@ -91,7 +92,7 @@ mkDispatchClause runHandler dispatcher ress = do
|
||||
let dispatched = VarE dispatch `AppE` VarE pieces0
|
||||
|
||||
-- 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
|
||||
toDispatch <- [|D.toDispatch|]
|
||||
@ -101,7 +102,7 @@ mkDispatchClause runHandler dispatcher ress = do
|
||||
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.
|
||||
methodMaps <- catMaybes <$> mapM buildMethodMap ress
|
||||
methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress
|
||||
|
||||
u <- [|case $(return dispatched) of
|
||||
Just f -> f $(return $ VarE master0)
|
||||
@ -118,9 +119,11 @@ mkDispatchClause runHandler dispatcher ress = do
|
||||
methodMapName :: String -> Name
|
||||
methodMapName s = mkName $ "methods" ++ s
|
||||
|
||||
buildMethodMap :: Resource -> Q (Maybe Dec)
|
||||
buildMethodMap (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
|
||||
buildMethodMap (Resource name _ (Methods _ methods)) = do
|
||||
buildMethodMap :: Q Exp -- ^ fixHandler
|
||||
-> Resource
|
||||
-> Q (Maybe Dec)
|
||||
buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
|
||||
buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
|
||||
fromList <- [|Map.fromList|]
|
||||
methods' <- mapM go methods
|
||||
let exp = fromList `AppE` ListE methods'
|
||||
@ -128,14 +131,20 @@ buildMethodMap (Resource name _ (Methods _ methods)) = do
|
||||
return $ Just fun
|
||||
where
|
||||
go method = do
|
||||
fh <- fixHandler
|
||||
let func = VarE $ mkName $ map toLower method ++ name
|
||||
pack' <- [|pack|]
|
||||
return $ TupE [pack' `AppE` LitE (StringL method), func]
|
||||
buildMethodMap (Resource _ _ Subsite{}) = return Nothing
|
||||
let isDynamic Dynamic{} = True
|
||||
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.
|
||||
buildRoute :: Q Exp -> Q Exp -> Resource -> Q Exp
|
||||
buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
|
||||
buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource -> Q Exp
|
||||
buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
|
||||
-- First two arguments to D.Route
|
||||
routePieces <- ListE <$> mapM convertPiece resPieces
|
||||
isMulti <-
|
||||
@ -143,15 +152,16 @@ buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
|
||||
Methods Nothing _ -> [|False|]
|
||||
_ -> [|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
|
||||
-> Q Exp -- ^ dispatcher
|
||||
-> Q Exp -- ^ fixHandler
|
||||
-> String -- ^ name of resource
|
||||
-> [Piece]
|
||||
-> Dispatch
|
||||
-> Q Exp
|
||||
routeArg3 runHandler dispatcher name resPieces resDisp = do
|
||||
routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
|
||||
pieces <- newName "pieces"
|
||||
|
||||
-- Allocate input piece variables (xs) and variables that have been
|
||||
@ -190,7 +200,7 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
|
||||
_ -> return ([], [])
|
||||
|
||||
-- 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
|
||||
just <- [|Just|]
|
||||
@ -211,12 +221,13 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
|
||||
-- | The final expression in the individual Route definitions.
|
||||
buildCaller :: Q Exp -- ^ runHandler
|
||||
-> Q Exp -- ^ dispatcher
|
||||
-> Q Exp -- ^ fixHandler
|
||||
-> Name -- ^ xrest
|
||||
-> String -- ^ name of resource
|
||||
-> Dispatch
|
||||
-> [Name] -- ^ ys
|
||||
-> Q Exp
|
||||
buildCaller runHandler dispatcher xrest name resDisp ys = do
|
||||
buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
|
||||
master <- newName "master"
|
||||
sub <- newName "sub"
|
||||
toMaster <- newName "toMaster"
|
||||
@ -234,28 +245,36 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
|
||||
Methods _ ms -> do
|
||||
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
|
||||
runner <- [|$(runHandler)
|
||||
$(return $ VarE handler)
|
||||
$(return $ VarE master)
|
||||
$(return $ VarE sub)
|
||||
$(return route)
|
||||
(Just $(return route))
|
||||
$(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
|
||||
let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
|
||||
[|$(dispatcher)
|
||||
@ -263,7 +282,7 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
|
||||
$(return sub2)
|
||||
($(return $ VarE toMaster) . $(return route))
|
||||
$(return $ VarE app404)
|
||||
$(return $ VarE handler405)
|
||||
($(return $ VarE handler405) . $(return route))
|
||||
$(return $ VarE method)
|
||||
$(return $ VarE xrest)
|
||||
|]
|
||||
@ -272,5 +291,5 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
|
||||
|
||||
-- | Convert a 'Piece' to a 'D.Piece'
|
||||
convertPiece :: Piece -> Q Exp
|
||||
convertPiece (Static s) = [|D.Static $(lift s)|]
|
||||
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
|
||||
convertPiece (Dynamic _) = [|D.Dynamic|]
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Routes.TH.Types
|
||||
( -- * Data types
|
||||
Resource (..)
|
||||
@ -9,13 +10,48 @@ module Yesod.Routes.TH.Types
|
||||
|
||||
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
|
||||
{ resourceName :: String
|
||||
, resourcePieces :: [Piece]
|
||||
, 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
|
||||
deriving Show
|
||||
|
||||
{-
|
||||
instance Lift Piece where
|
||||
lift (Static s) = [|Static $(lift s)|]
|
||||
lift (Dynamic t) = [|Static $(liftType t)|]
|
||||
-}
|
||||
|
||||
data Dispatch =
|
||||
Methods
|
||||
@ -26,6 +62,14 @@ data Dispatch =
|
||||
{ subsiteType :: Type
|
||||
, 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 { resourceDispatch = Methods (Just t) _ } = Just t
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
@ -10,7 +9,7 @@
|
||||
import Test.Hspec.Monadic
|
||||
import Test.Hspec.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.Class hiding (Route)
|
||||
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 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 f ts = f ts
|
||||
|
||||
@ -28,19 +33,19 @@ justRoot = toDispatch
|
||||
|
||||
twoStatics :: Dispatch Int
|
||||
twoStatics = toDispatch
|
||||
[ Route [D.Static "foo"] False $ result $ const $ Just 2
|
||||
, Route [D.Static "bar"] False $ result $ const $ Just 3
|
||||
[ Route [D.Static $ pack "foo"] False $ result $ const $ Just 2
|
||||
, Route [D.Static $ pack "bar"] False $ result $ const $ Just 3
|
||||
]
|
||||
|
||||
multi :: Dispatch Int
|
||||
multi = toDispatch
|
||||
[ Route [D.Static "foo"] False $ result $ const $ Just 4
|
||||
, Route [D.Static "bar"] True $ result $ const $ Just 5
|
||||
[ Route [D.Static $ pack "foo"] False $ result $ const $ Just 4
|
||||
, Route [D.Static $ pack "bar"] True $ result $ const $ Just 5
|
||||
]
|
||||
|
||||
dynamic :: Dispatch Int
|
||||
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 ->
|
||||
case ts of
|
||||
[t] ->
|
||||
@ -52,13 +57,13 @@ dynamic = toDispatch
|
||||
|
||||
overlap :: Dispatch Int
|
||||
overlap = toDispatch
|
||||
[ Route [D.Static "foo"] False $ result $ const $ Just 20
|
||||
, Route [D.Static "foo"] True $ result $ const $ Just 21
|
||||
[ Route [D.Static $ pack "foo"] False $ result $ const $ Just 20
|
||||
, Route [D.Static $ pack "foo"] True $ result $ const $ Just 21
|
||||
, Route [] True $ result $ const $ Just 22
|
||||
]
|
||||
|
||||
test :: Dispatch Int -> [Text] -> Maybe Int
|
||||
test dispatch ts = dispatch ts
|
||||
test :: Dispatch Int -> [String] -> Maybe Int
|
||||
test dispatch ts = dispatch $ map pack ts
|
||||
|
||||
data MyApp = MyApp
|
||||
|
||||
@ -80,8 +85,8 @@ instance RenderRoute MySubParam where
|
||||
getMySubParam :: MyApp -> Int -> MySubParam
|
||||
getMySubParam _ = MySubParam
|
||||
|
||||
type Handler sub master = String
|
||||
type App sub master = (String, Maybe (YRC.Route master))
|
||||
type Handler sub master = Text
|
||||
type App sub master = (Text, Maybe (YRC.Route master))
|
||||
|
||||
class Dispatcher sub master where
|
||||
dispatcher
|
||||
@ -89,7 +94,7 @@ class Dispatcher sub master where
|
||||
-> sub
|
||||
-> (YRC.Route sub -> YRC.Route master)
|
||||
-> App sub master -- ^ 404 page
|
||||
-> Handler sub master -- ^ 405 page
|
||||
-> (YRC.Route sub -> App sub master) -- ^ 405 page
|
||||
-> Text -- ^ method
|
||||
-> [Text]
|
||||
-> App sub master
|
||||
@ -99,7 +104,7 @@ class RunHandler sub master where
|
||||
:: Handler sub master
|
||||
-> master
|
||||
-> sub
|
||||
-> YRC.Route sub
|
||||
-> Maybe (YRC.Route sub)
|
||||
-> (YRC.Route sub -> YRC.Route master)
|
||||
-> App sub master
|
||||
|
||||
@ -113,7 +118,7 @@ do
|
||||
, Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
|
||||
]
|
||||
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
|
||||
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress
|
||||
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
|
||||
return
|
||||
[ rrinst
|
||||
, InstanceD
|
||||
@ -125,15 +130,15 @@ do
|
||||
]
|
||||
|
||||
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
|
||||
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
|
||||
dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
|
||||
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
|
||||
|
||||
{-
|
||||
@ -232,37 +237,37 @@ main = hspecX $ do
|
||||
|
||||
describe "RenderRoute instance" $ do
|
||||
it "renders root correctly" $ renderRoute RootR @?= ([], [])
|
||||
it "renders blog post correctly" $ renderRoute (BlogPostR "foo") @?= (["blog", "foo"], [])
|
||||
it "renders wiki correctly" $ renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
|
||||
it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
|
||||
@?= (["subsite", "foo", "bar"], [("baz", "bin")])
|
||||
it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], [])
|
||||
it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], [])
|
||||
it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")]))
|
||||
@?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")])
|
||||
it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c')
|
||||
@?= (["subparam", "6", "c"], [])
|
||||
@?= (map pack ["subparam", "6", "c"], [])
|
||||
|
||||
describe "thDispatch" $ do
|
||||
let disp = dispatcher MyApp MyApp id ("404" :: String, Nothing) "405"
|
||||
it "routes to root" $ disp "GET" [] @?= ("this is the root", Just RootR)
|
||||
it "POST root is 405" $ disp "POST" [] @?= ("405", Just RootR)
|
||||
it "invalid page is a 404" $ disp "GET" ["not-found"] @?= ("404", Nothing)
|
||||
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" [] @?= (pack "this is the root", Just RootR)
|
||||
it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)
|
||||
it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing)
|
||||
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"]
|
||||
@?= ("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"]
|
||||
@?= ("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"]
|
||||
@?= ("subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute (["baz"], []))
|
||||
@?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], []))
|
||||
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 = "this is the root"
|
||||
getRootR :: Text
|
||||
getRootR = pack "this is the root"
|
||||
|
||||
getBlogPostR :: Text -> String
|
||||
getBlogPostR t = "some blog post: " ++ unpack t
|
||||
|
||||
postBlogPostR :: Text -> String
|
||||
postBlogPostR t = "POST some blog post: " ++ unpack t
|
||||
postBlogPostR :: Text -> Text
|
||||
postBlogPostR t = pack $ "POST some blog post: " ++ unpack t
|
||||
|
||||
handleWikiR :: [Text] -> String
|
||||
handleWikiR ts = "the wiki: " ++ show ts
|
||||
|
||||
Loading…
Reference in New Issue
Block a user