diff --git a/Yesod/Core.hs b/Yesod/Core.hs index e098aadf..8de5e7e9 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -17,7 +17,6 @@ module Yesod.Core -- * Utitlities , maybeAuthorized , widgetToPageContent - , redirectToPost -- * Defaults , defaultErrorHandler -- * Data types @@ -46,6 +45,7 @@ import qualified Web.ClientSession as CS import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State hiding (get, put) @@ -77,10 +77,7 @@ import qualified Data.Text.Encoding #define HAMLET $hamlet #endif -{- FIXME -class YesodDispatcher y where - dispatchSubsite :: y -> Key -> [String] -> Maybe Application --} +-- FIXME ditch the whole Site thing and just have render and dispatch? -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -88,6 +85,7 @@ class Eq (Route y) => YesodSite y where getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) getSite' _ = getSite + dispatchToSubsite :: y -> Maybe CS.Key -> [String] -> Maybe W.Application type Method = String @@ -95,6 +93,8 @@ type Method = String -- to deal with it directly, as mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + dispatchSubsite :: y -> Maybe CS.Key -> [String] -> (y -> s) -> W.Application + dispatchSubsite _ _ _ _ _ = return $ W.responseLBS W.status200 [("Content-Type", "text/plain")] $ L8.pack "FIXME" -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. @@ -156,8 +156,6 @@ class Eq (Route a) => Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - -- - -- FIXME make this a part of the Yesod middlewares isAuthorized :: Route a -> Bool -- ^ is this a write request? -> GHandler s a AuthResult @@ -485,6 +483,21 @@ $maybe j <- jscript |] return $ PageContent title head'' body +yesodVersion :: String +yesodVersion = showVersion Paths_yesod_core.version + +yesodRender :: (Yesod y, YesodSite y) + => y + -> Route y + -> [(String, String)] + -> String +yesodRender y u qs = + S8.unpack $ fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') + (urlRenderOverride y u) + where + (ps, qs') = formatPathSegments (getSite' y) u + #if TEST coreTestSuite :: Test coreTestSuite = testGroup "Yesod.Yesod" @@ -535,43 +548,3 @@ caseUtf8JoinPath :: Assertion caseUtf8JoinPath = do "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] #endif - --- | Redirect to a POST resource. --- --- This is not technically a redirect; instead, it returns an HTML page with a --- POST form, and some Javascript to automatically submit the form. This can be --- useful when you need to post a plain link somewhere that needs to cause --- changes on the server. -redirectToPost :: Route master -> GHandler sub master a -redirectToPost dest = hamletToRepHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -\ - - - - Redirecting... - <body onload="document.getElementById('form').submit()"> - <form id="form" method="post" action="@{dest}"> - <noscript> - <p>Javascript has been disabled; please click on the button below to be redirected. - <input type="submit" value="Continue"> -|] >>= sendResponse - -yesodVersion :: String -yesodVersion = showVersion Paths_yesod_core.version - -yesodRender :: (Yesod y, YesodSite y) - => y - -> Route y - -> [(String, String)] - -> String -yesodRender y u qs = - S8.unpack $ fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) - where - (ps, qs') = formatPathSegments (getSite' y) u diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c397f8e3..79b4cb5f 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -70,7 +70,7 @@ import System.Random (randomR, newStdGen) import qualified Data.Map as Map -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Data.Enumerator (($$), run_, Iteratee) import Control.Monad.IO.Class (liftIO) @@ -144,7 +144,8 @@ mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' - th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites + th' <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites + let th = map fst th' w' <- createRoutes th let routesName = mkName $ name ++ "Route" let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] @@ -170,18 +171,58 @@ mkYesodGeneral name args clazzes isSub res = do if isSub then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") + subsiteClauses <- catMaybes <$> mapM sc th' + nothing <- [|Nothing|] + let otherMethods = + if isSub + then [] + else [ FunD (mkName "dispatchToSubsite") + (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) + ] let y = InstanceD ctx ytyp - [ FunD (mkName yfunc) [Clause [] (NormalB site') []] - ] + $ FunD (mkName yfunc) [Clause [] (NormalB site') []] + : otherMethods return ([w, x], [y]) + where + sc ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + master <- newName "master" + mkey <- newName "mkey" + just <- [|Just|] + (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE $ mkName toSub) + ds <- [|dispatchSubsite|] + let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest + fmap' <- [|(<$>)|] + let body = InfixE (Just body') fmap' $ Just tma' + return $ Just $ Clause + [ VarP master + , VarP mkey + , pat' + ] (NormalB body) [] + sc _ = return Nothing + mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp) + mkPat' (MultiPiece _:_) _ = error "MultiPiece not allowed as part of a subsite" + mkPat' (StaticPiece s:rest) tma = do + (x, tma, rest') <- mkPat' rest tma + let sp = LitP $ StringL s + return (InfixP sp (mkName ":") x, tma, rest') + mkPat' (SinglePiece s:rest) tma = do + fsp <- [|either (const Nothing) Just . fromSinglePiece|] + v <- newName $ "var" ++ s + be <- [|(<*>)|] + let tma' = InfixE (Just tma) be $ Just $ fsp `AppE` VarE v + (x, tma'', rest) <- mkPat' rest tma' + return (InfixP (VarP v) (mkName ":") x, tma'', rest) + mkPat' [] parse = do + rest <- newName "rest" + return (VarP rest, parse, VarE rest) isStatic :: Piece -> Bool isStatic StaticPiece{} = True isStatic _ = False -thResourceFromResource :: Type -> Resource -> Q THResource +thResourceFromResource :: Type -> Resource -> Q (THResource, Maybe String) thResourceFromResource _ (Resource n ps atts) - | all (all isUpper) atts = return (n, Simple ps atts) + | all (all isUpper) atts = return ((n, Simple ps atts), Nothing) thResourceFromResource master (Resource n ps [stype, toSubArg]) -- static route to subsite = do @@ -201,14 +242,14 @@ thResourceFromResource master (Resource n ps [stype, toSubArg]) dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] let dispatch = dispatch' `AppE` gss' tmg <- mkToMasterArg ps toSubArg - return (n, SubSite + return ((n, SubSite { ssType = ConT ''Route `AppT` stype' , ssParse = parse , ssRender = render , ssDispatch = dispatch , ssToMasterArg = tmg , ssPieces = ps - }) + }), Just toSubArg) thResourceFromResource _ (Resource n _ _) = @@ -244,8 +285,6 @@ toWaiAppPlain a = do key' <- encryptKey a return $ toWaiApp' a key' -dispatchPieces _ _ _ = Nothing -- FIXME - toWaiApp' :: (Yesod y, YesodSite y) => y -> Maybe Key @@ -256,7 +295,7 @@ toWaiApp' y key' env = do "":x -> x x -> x liftIO $ print (W.pathInfo env, segments) - case dispatchPieces y key' segments of + case dispatchToSubsite y key' segments of Nothing -> case cleanPath y segments of Nothing -> normalDispatch y key' segments env diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index cdfd8b02..e6d94dbb 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -10,6 +10,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -43,6 +44,7 @@ module Yesod.Handler , redirect , redirectParams , redirectString + , redirectToPost -- ** Errors , notFound , badMethod @@ -78,6 +80,10 @@ module Yesod.Handler -- ** Messages , setMessage , getMessage + -- * Helpers for specific content + -- ** Hamlet + , hamletToContent + , hamletToRepHtml -- ** Misc , newIdent -- * Internal Yesod @@ -734,3 +740,39 @@ newIdent = GHandler $ lift $ lift $ lift $ do let i' = ghsIdent x + 1 put x { ghsIdent = i' } return $ "h" ++ show i' + +-- | Redirect to a POST resource. +-- +-- This is not technically a redirect; instead, it returns an HTML page with a +-- POST form, and some Javascript to automatically submit the form. This can be +-- useful when you need to post a plain link somewhere that needs to cause +-- changes on the server. +redirectToPost :: Route master -> GHandler sub master a +redirectToPost dest = hamletToRepHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +\<!DOCTYPE html> + +<html> + <head> + <title>Redirecting... + <body onload="document.getElementById('form').submit()"> + <form id="form" method="post" action="@{dest}"> + <noscript> + <p>Javascript has been disabled; please click on the button below to be redirected. + <input type="submit" value="Continue"> +|] >>= sendResponse + +-- | Converts the given Hamlet template into 'Content', which can be used in a +-- Yesod 'Response'. +hamletToContent :: Hamlet (Route master) -> GHandler sub master Content +hamletToContent h = do + render <- getUrlRenderParams + return $ toContent $ h render + +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml +hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index ac217178..ae4736c9 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -33,10 +33,6 @@ module Yesod.Widget , addScriptEither -- * Utilities , extractBody - -- * Helpers for specific content - -- ** Hamlet - , hamletToContent - , hamletToRepHtml ) where import Data.Monoid @@ -46,14 +42,11 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Yesod.Handler - ( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod - , getUrlRenderParams - ) + (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans (lift)) import Yesod.Internal -import Yesod.Content (RepHtml (RepHtml), Content, toContent) import Control.Monad (liftM) import Control.Monad.IO.Peel (MonadPeelIO) @@ -204,16 +197,3 @@ data PageContent url = PageContent , pageHead :: Hamlet url , pageBody :: Hamlet url } - --- FIXME these ideally belong somewhere else, I'm just not sure where - --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ h render - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent