diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -10,7 +10,9 @@ , mkYesodSub -- ** More fine-grained , mkYesodData + , mkYesodSubData , mkYesodDispatch + , mkYesodSubDispatch -- ** Path pieces , SinglePiece (..) , MultiPiece (..) @@ -60,7 +62,7 @@ import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS -import Data.Char (isLower, isUpper) +import Data.Char (isUpper) import Data.Serialize import qualified Data.Serialize as Ser @@ -112,8 +114,15 @@ -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [Resource] -> Q [Dec] -mkYesodData name res = do - (x, _) <- mkYesodGeneral name [] [] False res +mkYesodData name res = mkYesodDataGeneral name [] False res + +mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec] +mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res + +mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> 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 let y = [ SigD rname $ ListT `AppT` ConT ''Resource @@ -125,6 +134,10 @@ mkYesodDispatch :: String -> [Resource] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False +mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec] +mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True + where (name':rest) = words name + mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument -> Cxt -- ^ classes @@ -149,7 +162,7 @@ render'' <- newName "render" let render = LetE [FunD render'' render'] $ VarE render'' - tmh <- [|toMasterHandler|] + tmh <- [|toMasterHandlerDyn|] modMaster <- [|fmap chooseRep|] dispatch' <- createDispatch modMaster tmh th dispatch'' <- newName "dispatch" @@ -170,15 +183,12 @@ isStatic StaticPiece{} = True isStatic _ = False -fromStatic :: Piece -> String -fromStatic (StaticPiece s) = s -fromStatic _ = error "fromStatic" - thResourceFromResource :: Type -> Resource -> Q THResource -thResourceFromResource _ (Resource n ps attribs) - | all (all isUpper) attribs = return (n, Simple ps attribs) -thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) - | all isStatic ps && any (any isLower) atts = do +thResourceFromResource _ (Resource n ps atts) + | all (all isUpper) atts = return (n, Simple ps atts) +thResourceFromResource master (Resource n ps [stype, toSubArg]) + -- static route to subsite + = do let stype' = ConT $ mkName stype gss <- [|getSubSite|] let inside = ConT ''Maybe `AppT` @@ -194,16 +204,31 @@ let render = render' `AppE` gss' dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] let dispatch = dispatch' `AppE` gss' + tmg <- mkToMasterArg ps toSubArg return (n, SubSite { ssType = ConT ''Route `AppT` stype' , ssParse = parse , ssRender = render , ssDispatch = dispatch - , ssToMasterArg = VarE $ mkName toSubArg - , ssPieces = map fromStatic ps + , ssToMasterArg = tmg + , ssPieces = ps }) + + thResourceFromResource _ (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 <- [| runSubsiteGetter|] + let xps = map VarP args + xes = map VarE args + e' = foldl (\x y -> x `AppE` y) f xes + e = rsg `AppE` e' + return $ LamE xps e sessionName :: String sessionName = "_SESSION" diff --git a/Yesod/Form.hs b/Yesod/Form.hs --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -187,8 +187,8 @@ ^widget^ %tr %td!colspan=2 - $nonce$ - %input!type=submit!value=$inputLabel$ + $nonce$ + %input!type=submit!value=$inputLabel$ |] return (res, widget') diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -28,7 +28,7 @@ import Database.Persist (PersistField) import Text.HTML.SanitizeXSS (sanitizeBalance) -import Blaze.ByteString.Builder.Char.Utf8 (writeChar) +import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (fromWrite4List, writeByteString) import Yesod.Internal (lbsToChars) @@ -117,13 +117,8 @@ Html . fromWrite4List writeHtmlEscapedChar . unTextarea where -- Taken from blaze-builder and modified with newline handling. - writeHtmlEscapedChar '<' = writeByteString "<" - writeHtmlEscapedChar '>' = writeByteString ">" - writeHtmlEscapedChar '&' = writeByteString "&" - writeHtmlEscapedChar '"' = writeByteString """ - writeHtmlEscapedChar '\'' = writeByteString "'" writeHtmlEscapedChar '\n' = writeByteString "
" - writeHtmlEscapedChar c = writeChar c + writeHtmlEscapedChar c = B.writeHtmlEscapedChar c textareaFieldProfile :: FieldProfile sub y Textarea textareaFieldProfile = FieldProfile diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -8,6 +8,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FunctionalDependencies #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -48,6 +49,7 @@ -- ** Short-circuit responses. , sendFile , sendResponse + , sendResponseStatus -- * Setting headers , setCookie , deleteCookie @@ -75,7 +77,9 @@ -- * Internal Yesod , runHandler , YesodApp (..) + , runSubsiteGetter , toMasterHandler + , toMasterHandlerDyn , toMasterHandlerMaybe , localNoCurrent , HandlerData @@ -110,6 +114,7 @@ import Control.Monad.Invert (MonadInvertIO (..)) import Control.Monad (liftM) import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as S8 #if TEST import Test.Framework (testGroup, Test) @@ -164,6 +169,29 @@ toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h +toMasterHandlerDyn :: (Route sub -> Route master) + -> GHandler sub' master sub + -> Route sub + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerDyn tm getSub route (GHandler h) = do + sub <- getSub + GHandler $ withReaderT (handlerSubData tm (const sub) route) h + +class SubsiteGetter g m s | g -> s where + runSubsiteGetter :: g -> m s + +instance (master ~ master' + ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where + runSubsiteGetter getter = do + y <- getYesod + return $ getter y + +instance (anySub ~ anySub' + ,master ~ master' + ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where + runSubsiteGetter = id + toMasterHandlerMaybe :: (Route sub -> Route master) -> (master -> sub) -> Maybe (Route sub) @@ -217,10 +245,11 @@ } data HandlerContents = - HCContent ChooseRep + HCContent W.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath | HCRedirect RedirectType String + | HCCreated String instance Failure ErrorResponse (GHandler sub master) where failure = GHandler . lift . throwMEither . HCError @@ -285,7 +314,7 @@ $ flip runReaderT hd $ unGHandler handler ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) - let contents = meither id (HCContent . chooseRep) contents' + let contents = meither id (HCContent W.status200 . chooseRep) contents' let handleError e = do (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession let hs' = headers hs @@ -293,9 +322,9 @@ let sendFile' ct fp = return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) case contents of - HCContent a -> do + HCContent status a -> do (ct, c) <- chooseRep a cts - return (W.status200, headers [], ct, c, finalSession) + return (status, headers [], ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers [] @@ -304,6 +333,11 @@ HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) + HCCreated loc -> do + let hs = Header "Location" loc : headers [] + return (W.Status 201 (S8.pack "Created"), hs, typePlain, + emptyContent, + finalSession) safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do @@ -395,9 +429,17 @@ sendFile :: ContentType -> FilePath -> GHandler sub master a sendFile ct = GHandler . lift . throwMEither . HCSendFile ct --- | Bypass remaining handler code and output the given content. +-- | Bypass remaining handler code and output the given content with a 200 +-- status code. sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = GHandler . lift . throwMEither . HCContent . chooseRep +sendResponse = GHandler . lift . throwMEither . HCContent W.status200 + . chooseRep + +-- | Bypass remaining handler code and output the given content with the given +-- status code. +sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a +sendResponseStatus s = GHandler . lift . throwMEither . HCContent s + . chooseRep -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -31,6 +31,9 @@ -- * Lookup files in filesystem , fileLookupDir , staticFiles + -- * Embed files + , mkEmbedFiles + , getStaticHandler -- * Hashing , base64md5 #if TEST @@ -44,6 +47,7 @@ import Yesod hiding (lift) import Data.List (intercalate) +import Language.Haskell.TH import Language.Haskell.TH.Syntax import Web.Routes @@ -104,6 +108,52 @@ if exists then return $ Just $ Left fp' else return Nothing + +-- | Lookup files in a specific directory, and embed them into the haskell source. +-- +-- A variation of fileLookupDir which allows subsites distributed via cabal to include +-- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler +-- for dispatching static content for a subsite. +mkEmbedFiles :: FilePath -> Q Exp +mkEmbedFiles d = do + fs <- qRunIO $ getFileList d + clauses <- mapM (mkClause . intercalate "/") fs + defC <- defaultClause + return $ static $ clauses ++ [defC] + where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f + f = mkName "f" + fun clauses = FunD f clauses + defaultClause = do + b <- [| return Nothing |] + return $ Clause [WildP] (NormalB b) [] + + mkClause path = do + content <- qRunIO $ readFile $ d ++ '/':path + let pat = LitP $ StringL path + foldAppE = foldl1 AppE + content' = return $ LitE $ StringL $ content + body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |] + return $ Clause [pat] body [] + +-- | Dispatch static route for a subsite +-- +-- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. +-- Instead of a subsite route: +-- /static StaticR Static getStatic +-- Use a normal route: +-- /static/*Strings StaticR GET +-- +-- Then, define getStaticR something like: +-- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR +-- */ end CPP comment +getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep +getStaticHandler static toSubR pieces = do + toMasterR <- getRouteToMaster + toMasterHandler (toMasterR . toSubR) toSub route handler + where route = StaticRoute pieces [] + toSub _ = static + staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) + handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" getStaticRoute :: [String] -> GHandler Static master (ContentType, Content) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -87,6 +87,8 @@ -- to deal with it directly, as the mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSiteFromSubSite _ = getSubSite -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -53,6 +53,6 @@ Buildable: False cpp-options: -DPRODUCTION main-is: fastcgi.hs - ghc-options: -Wall + ghc-options: -Wall -threaded extensions: TemplateHaskell, QuasiQuotes, TypeFamilies diff --git a/yesod.cabal b/yesod.cabal --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.4 +version: 0.6.5 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -33,9 +33,9 @@ , wai-extra >= 0.2.4 && < 0.3 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 - , text >= 0.5 && < 0.11 + , text >= 0.5 && < 0.12 , template-haskell >= 2.4 && < 2.6 - , web-routes-quasi >= 0.6 && < 0.7 + , web-routes-quasi >= 0.6.2 && < 0.7 , hamlet >= 0.5.1 && < 0.7 , blaze-builder >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3