yesod 0.6.4 → 0.6.5
raw patch · 8 files changed
+147/−33 lines, 8 filesdep ~textdep ~web-routes-quasi
Dependency ranges changed: text, web-routes-quasi
Files
- Yesod/Dispatch.hs +39/−14
- Yesod/Form.hs +2/−2
- Yesod/Form/Profiles.hs +2/−7
- Yesod/Handler.hs +48/−6
- Yesod/Helpers/Static.hs +50/−0
- Yesod/Yesod.hs +2/−0
- scaffold/cabal.cg +1/−1
- yesod.cabal +3/−3
Yesod/Dispatch.hs view
@@ -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"
Yesod/Form.hs view
@@ -187,8 +187,8 @@ ^widget^ %tr %td!colspan=2- $nonce$- %input!type=submit!value=$inputLabel$+ $nonce$+ %input!type=submit!value=$inputLabel$ |] return (res, widget')
Yesod/Form/Profiles.hs view
@@ -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 "<br>"- writeHtmlEscapedChar c = writeChar c+ writeHtmlEscapedChar c = B.writeHtmlEscapedChar c textareaFieldProfile :: FieldProfile sub y Textarea textareaFieldProfile = FieldProfile
Yesod/Handler.hs view
@@ -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
Yesod/Helpers/Static.hs view
@@ -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)
Yesod/Yesod.hs view
@@ -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.
scaffold/cabal.cg view
@@ -53,6 +53,6 @@ Buildable: False cpp-options: -DPRODUCTION main-is: fastcgi.hs- ghc-options: -Wall+ ghc-options: -Wall -threaded extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.6.4+version: 0.6.5 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -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