From 533c2c2d15a372abe9df40cd3bb6d084b180a4d4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 19 Apr 2010 23:06:06 -0700 Subject: [PATCH] Continued work on subsites --- Yesod/Handler.hs | 65 +++++++++++++++++++++++------------------ Yesod/Helpers/Auth.hs | 2 +- Yesod/Helpers/Static.hs | 14 ++++++--- Yesod/Resource.hs | 39 +++++++++++++++---------- examples/static.hs | 2 +- 5 files changed, 71 insertions(+), 51 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1f15ea75..995e9fdc 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -31,9 +32,9 @@ module Yesod.Handler , runHandler , runHandler' , runHandlerSub + , runHandlerSub' , liftIO , YesodApp (..) - , YesodAppSub (..) , Routes -- * Special handlers , redirect @@ -84,8 +85,6 @@ newtype YesodApp = YesodApp -> IO Response } -data YesodAppSub master = YesodAppSub - ------ Handler monad newtype GHandler sub master a = Handler { unHandler :: HandlerData sub master @@ -146,41 +145,32 @@ getRouteMaster = do d <- getData return $ handlerToMaster d <$> handlerRoute d +runHandlerSub' :: HasReps c + => GHandler sub master c + -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String) + -> Routes sub + -> (Routes sub -> String) + -> YesodApp +runHandlerSub' handler arg route render = runHandlerSub handler arg (Just route) render + runHandlerSub :: HasReps c => GHandler sub master c - -> master - -> (master -> sub) - -> Routes sub + -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String) + -> Maybe (Routes sub) -> (Routes sub -> String) - -> YesodAppSub master -runHandlerSub = error "runHandlerSub" - -runHandler' :: HasReps c - => Handler yesod c - -> yesod - -> Routes yesod - -> (Routes yesod -> String) - -> YesodApp -runHandler' handler y route render = runHandler handler y (Just route) render - -runHandler :: HasReps c - => Handler yesod c - -> yesod - -> Maybe (Routes yesod) - -> (Routes yesod -> String) - -> YesodApp -runHandler handler y route render = YesodApp $ \eh rr cts -> do + -> YesodApp +runHandlerSub handler (ma, tosa, tomr, mrender) sroute _ = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch (unHandler handler $ HandlerData { handlerRequest = rr - , handlerSub = y - , handlerMaster = y - , handlerRoute = route - , handlerRender = render - , handlerToMaster = id + , handlerSub = tosa ma + , handlerMaster = ma + , handlerRoute = sroute + , handlerRender = mrender + , handlerToMaster = tomr }) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do @@ -202,6 +192,23 @@ runHandler handler y route render = YesodApp $ \eh rr cts -> do (ct, c) <- chooseRep a cts return $ Response W.Status200 headers ct c +runHandler' :: HasReps c + => Handler yesod c + -> yesod + -> Routes yesod + -> (Routes yesod -> String) + -> YesodApp +runHandler' handler y route render = runHandler handler y (Just route) render + +runHandler :: HasReps c + => Handler yesod c + -> yesod + -> Maybe (Routes yesod) + -> (Routes yesod -> String) + -> YesodApp +runHandler handler y route render = + runHandlerSub handler (y, id, id, render) route render + safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index c01693aa..bb6f6428 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -25,7 +25,7 @@ module Yesod.Helpers.Auth , displayName , redirectLogin , Auth (..) - , siteAuthRoutes + , siteAuth ) where import Web.Encodings diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 7651ca62..184ca175 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -21,7 +21,7 @@ module Yesod.Helpers.Static ( FileLookup , fileLookupDir - , siteStaticRoutes + , siteStatic , StaticRoutes , staticArgs , Static @@ -33,6 +33,7 @@ import Control.Monad import Yesod import Data.List (intercalate) import Network.Wai +import Web.Routes type FileLookup = FilePath -> IO (Maybe (Either FilePath Content)) @@ -42,10 +43,15 @@ staticArgs :: FileLookup -> Static staticArgs = Static -- FIXME bug in web-routes-quasi generates warning here -$(mkYesod "Static" [$parseRoutes| +$(mkYesodSub "Static" [$parseRoutes| /* StaticRoute GET |]) +siteStatic' :: Site StaticRoutes (String -> YesodApp + -> (master, master -> Static, StaticRoutes -> Routes master, Routes master -> String) + -> YesodApp) +siteStatic' = siteStatic + -- | A 'FileLookup' for files in a directory. Note that this function does not -- check if the requested path does unsafe things, eg expose hidden files. You -- should provide this checking elsewhere. @@ -60,7 +66,7 @@ fileLookupDir dir = Static $ \fp -> do then return $ Just $ Left fp' else return Nothing -getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)] +getStatic :: FileLookup -> [String] -> GHandler sub master [(ContentType, Content)] getStatic fl fp' = do when (any isUnsafe fp') notFound wai <- waiRequest @@ -76,7 +82,7 @@ getStatic fl fp' = do isUnsafe ('.':_) = True isUnsafe _ = False -getStaticRoute :: [String] -> Handler Static [(ContentType, Content)] +getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)] getStaticRoute fp = do Static fl <- getYesod getStatic fl fp diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index d65a1d81..bc520b56 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -6,7 +6,7 @@ module Yesod.Resource , mkYesodSub ) where -import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..)) +import Web.Routes.Quasi import Yesod.Handler import Language.Haskell.TH.Syntax import Yesod.Yesod @@ -15,24 +15,31 @@ mkYesod :: String -> [Resource] -> Q [Dec] mkYesod name res = do let name' = mkName name let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") - let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes" + let site = mkName $ "site" ++ name + let gsbod = NormalB $ VarE site let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] - decs <- createRoutes (name ++ "Routes") - (ConT ''YesodApp) - name' - "runHandler'" - res - return $ tySyn : yes : decs + CreateRoutesResult x y z <- createRoutes $ CreateRoutesSettings + { crRoutes = mkName $ name ++ "Routes" + , crApplication = ConT ''YesodApp + , crArgument = ConT $ mkName name + , crExplode = VarE $ mkName "runHandler'" + , crResources = res + , crSite = site + } + return [tySyn, yes, x, y, z] mkYesodSub :: String -> [Resource] -> Q [Dec] mkYesodSub name res = do let name' = mkName name - let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") - let yas = ConT ''YesodApp `AppT` VarT (mkName "master") - decs <- createRoutes (name ++ "Routes") - yas - name' - "runHandlerSub" - res - return $ tySyn : decs + let site = mkName $ "site" ++ name + let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes") + CreateRoutesResult x _ z <- createRoutes $ CreateRoutesSettings + { crRoutes = mkName $ name ++ "Routes" + , crApplication = ConT ''YesodApp + , crArgument = ConT $ mkName name + , crExplode = VarE $ mkName "runHandlerSub'" + , crResources = res + , crSite = site + } + return [tySyn, x, z] diff --git a/examples/static.hs b/examples/static.hs index bdc0557b..670d0a94 100644 --- a/examples/static.hs +++ b/examples/static.hs @@ -10,7 +10,7 @@ import Network.Wai.Handler.SimpleServer data StaticExample = StaticExample mkYesod "StaticExample" [$parseRoutes| -/ Root StaticRoutes siteStaticRoutes getStaticSite +/ Root StaticRoutes siteStatic getStaticSite |] instance Yesod StaticExample where