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

Big code cleanup

Browse Source
This commit is contained in:
Michael Snoyman 2011-01-28 11:15:58 +02:00
parent c571aac930
commit af30b44ef2
4 changed files with 94 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Yesod/Core.hs
View File

@ -91,7 +91,8 @@ class Yesod master => YesodDispatch a master where
-> (Route a -> Route master) -> (Route a -> Route master)
-> Maybe W.Application -> Maybe W.Application
yesodRunner :: a yesodRunner :: Yesod master
=> a
-> master -> master
-> (Route a -> Route master) -> (Route a -> Route master)
-> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
@ -275,7 +276,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
Just url' -> do Just url' -> do
setUltDest' setUltDest'
redirect RedirectTemporary url' redirect RedirectTemporary url'
Unauthorized s -> permissionDenied s Unauthorized s' -> permissionDenied s'
handler handler
let sessionMap = Map.fromList let sessionMap = Map.fromList
$ filter (\(x, _) -> x /= nonceKey) session' $ filter (\(x, _) -> x /= nonceKey) session'

312
Yesod/Dispatch.hs
View File

@ -25,12 +25,10 @@ module Yesod.Dispatch
#endif #endif
) where ) where
import Prelude hiding (exp)
import Yesod.Core import Yesod.Core
import Yesod.Handler import Yesod.Handler
import Yesod.Request
import Yesod.Internal
import Web.Routes.Quasi import Web.Routes.Quasi
import Web.Routes.Quasi.Parse import Web.Routes.Quasi.Parse
import Web.Routes.Quasi.TH import Web.Routes.Quasi.TH
@ -42,36 +40,14 @@ import Network.Wai.Middleware.Gzip
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as S import qualified Data.ByteString as S
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
import Blaze.ByteString.Builder (toLazyByteString)
import Control.Concurrent.MVar
import Control.Arrow ((***))
import Data.Time
import Control.Monad import Control.Monad
import Data.Maybe
import Web.ClientSession import Web.ClientSession
import qualified Web.ClientSession as CS
import Data.Char (isUpper, toLower) import Data.Char (isUpper, toLower)
import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie)
import Data.Serialize
import qualified Data.Serialize as Ser
import Network.Wai.Parse hiding (FileInfo)
import qualified Network.Wai.Parse as NWP
import Data.String (fromString)
import Web.Routes (decodePathInfo) import Web.Routes (decodePathInfo)
import Control.Arrow (first)
import System.Random (randomR, newStdGen)
import qualified Data.Map as Map
import Control.Applicative ((<$>), (<*>))
import Data.Enumerator (($$), run_, Iteratee)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.List (foldl') import Data.List (foldl')
@ -145,49 +121,35 @@ mkYesodGeneral name args clazzes isSub res = do
let name' = mkName name let name' = mkName name
args' = map mkName args args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT args' arg = foldl AppT (ConT name') $ map VarT args'
th' <- mapM (thResourceFromResource arg) res th' <- mapM thResourceFromResource res
let th = map fst th' let th = map fst th'
w' <- createRoutes th w' <- createRoutes th
let routesName = mkName $ name ++ "Route" let routesName = mkName $ name ++ "Route"
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
let x = TySynInstD ''Route [arg] $ ConT routesName let x = TySynInstD ''Route [arg] $ ConT routesName
render' <- createRender th render <- createRender th
render'' <- newName "render"
let render = LetE [FunD render'' render'] $ VarE render''
let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName) let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)
[ FunD (mkName "renderRoute") render' [ FunD (mkName "renderRoute") render
] ]
tmh <- [|toMasterHandlerDyn|] let sortedRes = filter (not . isSubSite) th ++ filter isSubSite th
modMaster <- [|fmap chooseRep|]
dispatch' <- createDispatch modMaster tmh th
dispatch'' <- newName "dispatch"
let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch''
{- FIXME
let (ctx, ytyp, yfunc) =
if isSub
then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")
else ([], ConT ''YesodSite `AppT` arg, "getSite")
-}
let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th'
yd <- mkYesodDispatch' sortedRes yd <- mkYesodDispatch' sortedRes
nothing <- [|Nothing|]
let master = mkName "master" let master = mkName "master"
let ctx = ClassP (mkName "Yesod") [VarT master] : clazzes let ctx = if isSub
let mkYSS = InstanceD ctx (ConT ''YesodDispatch `AppT` arg `AppT` VarT master) then ClassP (mkName "Yesod") [VarT master] : clazzes
[ FunD (mkName "yesodDispatch") [yd] else []
] let ytyp = if isSub
mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg `AppT` arg) [FunD (mkName "yesodDispatch") [yd]] then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp else ConT ''YesodDispatch `AppT` arg `AppT` arg
$ FunD (mkName yfunc) [Clause [] (NormalB site') []] let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
: otherMethods -}
return ([w, x, x'], [y]) return ([w, x, x'], [y])
isSubSite ((_, SubSite{}), _) = True isSubSite :: (String, Pieces) -> Bool
isSubSite (_, SubSite{}) = True
isSubSite _ = False isSubSite _ = False
mkYesodDispatch' :: [(String, Pieces)] -> Q Clause
mkYesodDispatch' sortedRes = do mkYesodDispatch' sortedRes = do
sub <- newName "sub" sub <- newName "sub"
master <- newName "master" master <- newName "master"
@ -195,22 +157,21 @@ mkYesodDispatch' sortedRes = do
segments <- newName "segments" segments <- newName "segments"
toMasterRoute <- newName "toMasterRoute" toMasterRoute <- newName "toMasterRoute"
nothing <- [|Nothing|] nothing <- [|Nothing|]
body <- foldM (go master sub toMasterRoute mkey segments) nothing sortedRes body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing sortedRes
return $ Clause return $ Clause
[VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
(NormalB body) (NormalB body)
[] []
where where
go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do go master sub toMasterRoute mkey segments onFail (constr, SubSite { ssPieces = pieces }) = do
test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, toSub) test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr)
just <- [|Just|]
app <- newName "app" app <- newName "app"
return $ CaseE test return $ CaseE test
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
] ]
go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do go master sub toMasterRoute mkey segments onFail (constr, Simple pieces methods) = do
test <- mkSimpleExp segments pieces id (master, sub, toMasterRoute, mkey, constr, methods) test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)
just <- [|Just|] just <- [|Just|]
app <- newName "app" app <- newName "app"
return $ CaseE test return $ CaseE test
@ -218,6 +179,11 @@ mkYesodDispatch' sortedRes = do
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
] ]
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 mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
just <- [|Just|] just <- [|Just|]
nothing <- [|Nothing|] nothing <- [|Nothing|]
@ -229,21 +195,21 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
yr <- [|yesodRunner|] yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|] cr <- [|fmap chooseRep|]
let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
let runHandlerVars h = runHandler $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] let runHandlerVars h = runHandler' $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars []
runHandler h = NormalB $ yr `AppE` VarE sub runHandler' h = NormalB $ yr `AppE` sub
`AppE` VarE master `AppE` VarE master
`AppE` VarE toMasterRoute `AppE` toMasterRoute
`AppE` VarE mkey `AppE` VarE mkey
`AppE` (just `AppE` url) `AppE` (just `AppE` url)
`AppE` h `AppE` h
`AppE` VarE req `AppE` VarE req
let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) []
let clauses = let clauses =
case methods of case methods of
[] -> [Clause [] (runHandlerVars $ "handle" ++ constr) []] [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []]
_ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++
[Match WildP (runHandler badMethod') []]) []] [Match WildP (runHandler' badMethod') []]) []]
let exp = CaseE (VarE segments) let exp = CaseE segments
[ Match [ Match
(ConP (mkName "[]") []) (ConP (mkName "[]") [])
(NormalB $ just `AppE` VarE onSuccess) (NormalB $ just `AppE` VarE onSuccess)
@ -256,9 +222,9 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
return exp return exp
mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments" srest <- newName "segments"
innerExp <- mkSimpleExp srest pieces frontVars x innerExp <- mkSimpleExp (VarE srest) pieces frontVars x
nothing <- [|Nothing|] nothing <- [|Nothing|]
let exp = CaseE (VarE segments) let exp = CaseE segments
[ Match [ Match
(InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) (InfixP (LitP $ StringL s) (mkName ":") (VarP srest))
(NormalB innerExp) (NormalB innerExp)
@ -266,10 +232,10 @@ mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
, Match WildP (NormalB nothing) [] , Match WildP (NormalB nothing) []
] ]
return exp return exp
mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
srest <- newName "segments" srest <- newName "segments"
next' <- newName "next'" next' <- newName "next'"
innerExp <- mkSimpleExp srest pieces (frontVars . (:) (VarE next')) x innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|] nothing <- [|Nothing|]
next <- newName "next" next <- newName "next"
fsp <- [|fromSinglePiece|] fsp <- [|fromSinglePiece|]
@ -283,7 +249,7 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do
(NormalB innerExp) (NormalB innerExp)
[] []
] ]
let exp = CaseE (VarE segments) let exp = CaseE segments
[ Match [ Match
(InfixP (VarP next) (mkName ":") (VarP srest)) (InfixP (VarP next) (mkName ":") (VarP srest))
(NormalB exp') (NormalB exp')
@ -291,19 +257,42 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do
, Match WildP (NormalB nothing) [] , Match WildP (NormalB nothing) []
] ]
return exp return exp
mkSimpleExp segments [MultiPiece _] frontVars x = do
next' <- newName "next'"
srest <- [|[]|]
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
fmp <- [|fromMultiPiece|]
let exp = CaseE (fmp `AppE` segments)
[ Match
(ConP (mkName "Left") [WildP])
(NormalB nothing)
[]
, Match
(ConP (mkName "Right") [VarP next'])
(NormalB innerExp)
[]
]
return exp
mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"
mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do mkSubsiteExp :: Name -- ^ segments
-> [Piece]
-> ([Exp] -> [Exp]) -- ^ variables already parsed
-> (Name, Exp, Exp, Name, String) -- ^ master, sub, toMasterRoute, mkey, constructor
-> Q Exp
mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr) = do
yd <- [|yesodDispatch|] yd <- [|yesodDispatch|]
let con = foldl' AppE (ConE $ mkName constr) $ frontVars [] dot <- [|(.)|]
let s' = VarE (mkName toSub) `AppE` VarE master let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []
let s = foldl' AppE s' $ frontVars [] let app = yd `AppE` sub
let app = yd `AppE` s
`AppE` VarE mkey `AppE` VarE mkey
`AppE` VarE segments `AppE` VarE segments
`AppE` VarE master `AppE` VarE master
`AppE` con `AppE` con
just <- [|Just|] just <- [|Just|]
return $ just `AppE` app return $ just `AppE` app
mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece"
mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments" srest <- newName "segments"
innerExp <- mkSubsiteExp srest pieces frontVars x innerExp <- mkSubsiteExp srest pieces frontVars x
@ -316,7 +305,7 @@ mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
, Match WildP (NormalB nothing) [] , Match WildP (NormalB nothing) []
] ]
return exp return exp
mkSubsiteExp segments (SinglePiece s:pieces) frontVars x = do mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
srest <- newName "segments" srest <- newName "segments"
next' <- newName "next'" next' <- newName "next'"
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
@ -342,154 +331,27 @@ mkSubsiteExp segments (SinglePiece s:pieces) frontVars x = do
] ]
return exp return exp
{- thResourceFromResource :: Resource -> Q (THResource, Maybe String)
mkPat' (SinglePiece s:rest) url = do thResourceFromResource (Resource n ps atts)
fsp <- [|either (const Nothing) Just . fromSinglePiece|]
v <- newName $ "var" ++ s
be <- [|(<*>)|]
let url' = InfixE (Just url) be $ Just $ fsp `AppE` VarE v
(x, rest, url'') <- mkPat' rest url'
return (InfixP (VarP v) (mkName ":") x, rest, url'')
mkPat' [] url = do
rest <- newName "rest"
return (VarP rest, VarE rest, url)
-}
mkDispatchLocal ((constr, Simple pieces methods), Nothing) = do
master <- newName "master"
mkey <- newName "mkey"
req <- newName "req"
just <- [|Just|]
(pat', rest, url) <- mkPat' pieces $ just `AppE` (ConE $ mkName constr)
goodParse <- (`AppE` url) <$> [|isJust|]
tma'' <- (`AppE` url) <$> [|fromJust|]
nothing <- [|Nothing|]
let body = if null methods
then VarE $ mkName $ "handle" ++ constr
else CaseE (VarE req) $ map mkMatch methods ++ [Match WildP (NormalB nothing) []]
return $ Just $ Clause
[ VarP master
, VarP mkey
, pat'
] (GuardedB [(NormalG goodParse, body)]) [] -- FIXME
where
singleToMApp :: GHandler s m c -> Maybe W.Application
singleToMApp = undefined
multiToMApp = undefined
-- FIXME requires OverloadedStrings
mkMatch method = Match (LitP $ StringL method) (NormalB $ VarE $ mkName $ map toLower method ++ constr) []
mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp)
mkPat' (StaticPiece s:rest) url = do
(x, rest', url') <- mkPat' rest url
let sp = LitP $ StringL s
return (InfixP sp (mkName ":") x, rest', url')
mkPat' (SinglePiece s:rest) url = do
fsp <- [|either (const Nothing) Just . fromSinglePiece|]
v <- newName $ "var" ++ s
be <- [|(<*>)|]
let url' = InfixE (Just url) be $ Just $ fsp `AppE` VarE v
(x, rest, url'') <- mkPat' rest url'
return (InfixP (VarP v) (mkName ":") x, rest, url'')
mkPat' [] url = do
rest <- newName "rest"
return (VarP rest, VarE rest, url)
mkDispatchLocal _ = return Nothing
mkDispatchToSubsite ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
master <- newName "master"
mkey <- newName "mkey"
just <- [|Just|]
(pat', tma', rest, toMaster)
<- mkPat' pieces
(ConE $ mkName constr)
$ just `AppE` (VarE (mkName toSub) `AppE` VarE master)
ds <- error "FIXME" -- [|dispatchSubsite|]
goodParse <- (`AppE` tma') <$> [|isJust|]
tma'' <- (`AppE` tma') <$> [|fromJust|]
let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster
fmap' <- [|(<$>)|]
let body = InfixE (Just body') fmap' $ Just tma'
return $ Just $ Clause
[ VarP master
, VarP mkey
, pat'
] (GuardedB [(NormalG goodParse, body)]) []
where
mkPat' :: [Piece] -> Exp -> Exp -> Q (Pat, Exp, Exp, Exp)
mkPat' (MultiPiece _:_) _ _ = error "MultiPiece not allowed as part of a subsite"
mkPat' (StaticPiece s:rest) toMaster tma = do
(x, tma', rest', toMaster') <- mkPat' rest toMaster tma
let sp = LitP $ StringL s
return (InfixP sp (mkName ":") x, tma', rest', toMaster')
mkPat' (SinglePiece s:rest) toMaster tma = do
fsp <- [|either (const Nothing) Just . fromSinglePiece|]
v <- newName $ "var" ++ s
be <- [|(<*>)|]
let tma' = InfixE (Just tma) be $ Just $ fsp `AppE` VarE v
let toMaster' = toMaster `AppE` VarE v
(x, tma'', rest, toMaster'') <- mkPat' rest toMaster' tma'
return (InfixP (VarP v) (mkName ":") x, tma'', rest, toMaster'')
mkPat' [] toMaster parse = do
rest <- newName "rest"
return (VarP rest, parse, VarE rest, toMaster)
mkDispatchToSubsite _ = return Nothing
isStatic :: Piece -> Bool
isStatic StaticPiece{} = True
isStatic _ = False
thResourceFromResource :: Type -> Resource -> Q (THResource, Maybe String)
thResourceFromResource _ (Resource n ps atts)
| all (all isUpper) atts = return ((n, Simple ps atts), Nothing) | all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
thResourceFromResource master (Resource n ps [stype, toSubArg]) thResourceFromResource (Resource n ps [stype, toSubArg]) = do
-- static route to subsite let stype' = ConT $ mkName stype
= do parse <- [|error "ssParse"|]
let stype' = ConT $ mkName stype dispatch <- [|error "ssDispatch"|]
{- render <- [|renderRoute|]
gss <- [|error "FIXME getSubSite"|] tmg <- [|error "ssToMasterArg"|]
let inside = ConT ''Maybe `AppT` return ((n, SubSite
(ConT ''GHandler `AppT` stype' `AppT` master `AppT` { ssType = ConT ''Route `AppT` stype'
ConT ''ChooseRep) , ssParse = parse
let typ = ConT ''Site `AppT` , ssRender = render
(ConT ''Route `AppT` stype') `AppT` , ssDispatch = dispatch
(ArrowT `AppT` ConT ''String `AppT` inside) , ssToMasterArg = tmg
let gss' = gss `SigE` typ , ssPieces = ps
parse' <- [|parsePathSegments|] }), Just toSubArg)
let parse = parse' `AppE` gss'
render' <- [|formatPathSegments|]
let render = render' `AppE` gss'
dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]
let dispatch = dispatch' `AppE` gss'
-}
parse <- [|error "ssParse"|]
dispatch <- [|error "ssDispatch"|]
render <- [|renderRoute|]
tmg <- mkToMasterArg ps toSubArg
return ((n, SubSite
{ ssType = ConT ''Route `AppT` stype'
, ssParse = parse
, ssRender = render
, ssDispatch = dispatch
, ssToMasterArg = tmg
, ssPieces = ps
}), Just toSubArg)
thResourceFromResource (Resource n _ _) =
thResourceFromResource _ (Resource n _ _) =
error $ "Invalid attributes for resource: " ++ n error $ "Invalid attributes for resource: " ++ n
mkToMasterArg :: [Piece] -> String -> Q Exp
mkToMasterArg ps fname = do
let nargs = length $ filter (not.isStatic) ps
f = VarE $ mkName fname
args <- sequence $ take nargs $ repeat $ newName "x"
rsg <- [|error "runSubsiteGetter"|]
let xps = map VarP args
xes = map VarE args
e' = foldl (\x y -> x `AppE` y) f xes
e = rsg `AppE` e'
return $ rsg -- FIXME LamE xps e
-- | 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 three -- handler. This is the same as 'toWaiAppPlain', except it includes three
-- middlewares: GZIP compression, JSON-P and path cleaning. This is the -- middlewares: GZIP compression, JSON-P and path cleaning. This is the

3
helloworld.hs
View File

@ -11,6 +11,7 @@ data Subsite = Subsite String
mkYesodSub "Subsite" [] [$parseRoutes| mkYesodSub "Subsite" [] [$parseRoutes|
/ SubRootR GET / SubRootR GET
/multi/*Strings SubMultiR
|] |]
getSubRootR :: GHandler Subsite m RepPlain getSubRootR :: GHandler Subsite m RepPlain
@ -20,6 +21,8 @@ getSubRootR = do
render <- getUrlRender render <- getUrlRender
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR) return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR)
handleSubMultiR = return . RepPlain . toContent . show
data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
mkYesod "HelloWorld" [$parseRoutes| mkYesod "HelloWorld" [$parseRoutes|
/ RootR GET / RootR GET

2
yesod-core.cabal
View File

@ -58,7 +58,7 @@ library
Yesod.Internal.Session Yesod.Internal.Session
Yesod.Internal.Request Yesod.Internal.Request
Paths_yesod_core Paths_yesod_core
ghc-options: -Wall ghc-options: -Wall -Werror
executable runtests executable runtests
if flag(ghc7) if flag(ghc7)