yesod-core 0.8.1 → 0.8.2
raw patch · 8 files changed
+333/−35 lines, 8 filesdep +directorydep +parsecdep ~hamlet
Dependencies added: directory, parsec
Dependency ranges changed: hamlet
Files
- Yesod/Core.hs +2/−0
- Yesod/Dispatch.hs +5/−1
- Yesod/Handler.hs +44/−5
- Yesod/Internal/Core.hs +2/−5
- Yesod/Internal/Dispatch.hs +0/−1
- Yesod/Message.hs +250/−0
- Yesod/Widget.hs +26/−22
- yesod-core.cabal +4/−1
Yesod/Core.hs view
@@ -31,6 +31,7 @@ , module Yesod.Handler , module Yesod.Request , module Yesod.Widget+ , module Yesod.Message ) where import Yesod.Internal.Core@@ -39,6 +40,7 @@ import Yesod.Handler import Yesod.Request import Yesod.Widget+import Yesod.Message import Language.Haskell.TH.Syntax import Data.Text (Text)
Yesod/Dispatch.hs view
@@ -16,6 +16,7 @@ , SinglePiece (..) , MultiPiece (..) , Strings+ , Texts -- * Convert to WAI , toWaiApp , toWaiAppPlain@@ -27,7 +28,7 @@ import Yesod.Handler import Yesod.Internal.Dispatch -import Web.Routes.Quasi (SinglePiece, MultiPiece, Strings)+import Web.Routes.Quasi (SinglePiece (..), MultiPiece (..), Strings) import Web.Routes.Quasi.Parse (Resource (..), parseRoutes, parseRoutesFile) import Web.Routes.Quasi.TH (THResource, Pieces (..), createRoutes, createRender) import Language.Haskell.TH.Syntax@@ -40,6 +41,9 @@ import Web.ClientSession import Data.Char (isUpper)+import Data.Text (Text)++type Texts = [Text] -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
Yesod/Handler.hs view
@@ -50,7 +50,9 @@ , notFound , badMethod , permissionDenied+ , permissionDeniedI , invalidArgs+ , invalidArgsI -- ** Short-circuit responses. , sendFile , sendFilePart@@ -79,8 +81,10 @@ , setUltDestString , setUltDest' , redirectUltDest+ , clearUltDest -- ** Messages , setMessage+ , setMessageI , getMessage -- * Helpers for specific content -- ** Hamlet@@ -89,6 +93,8 @@ -- ** Misc , newIdent , liftIOHandler+ -- * i18n+ , getMessageRender -- * Internal Yesod , runHandler , YesodApp (..)@@ -129,7 +135,6 @@ import Control.Failure (Failure (failure)) import Text.Hamlet-import Text.Blaze (preEscapedText) import qualified Text.Blaze.Renderer.Text import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8With)@@ -155,6 +160,7 @@ import Data.CaseInsensitive (CI) import Blaze.ByteString.Builder (toByteString) import Data.Text (Text)+import Yesod.Message (RenderMessage (..)) -- | The type-safe URLs associated with a site argument. type family Route a@@ -487,12 +493,16 @@ redirectUltDest :: Monad mo => RedirectType -> Route master -- ^ default destination if nothing in session- -> GGHandler sub master mo ()+ -> GGHandler sub master mo a redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey maybe (redirect rt def) (redirectText rt) mdest +-- | Remove a previously set ultimate destination. See 'setUltDest'.+clearUltDest :: Monad mo => GGHandler sub master mo ()+clearUltDest = deleteSession ultDestKey+ msgKey :: Text msgKey = "_MSG" @@ -502,6 +512,14 @@ setMessage :: Monad mo => Html -> GGHandler sub master mo () setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml +-- | Sets a message in the user's session.+--+-- See 'getMessage'.+setMessageI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler sub y mo ()+setMessageI msg = do+ mr <- getMessageRender+ setMessage $ toHtml $ mr msg+ -- | Gets the message in the user's session, if available, and then clears the -- variable. --@@ -570,10 +588,22 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a permissionDenied = failure . PermissionDenied +-- | Return a 403 permission denied page.+permissionDeniedI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler s y mo a+permissionDeniedI msg = do+ mr <- getMessageRender+ permissionDenied $ mr msg+ -- | Return a 400 invalid arguments page. invalidArgs :: Failure ErrorResponse m => [Text] -> m a invalidArgs = failure . InvalidArgs +-- | Return a 400 invalid arguments page.+invalidArgsI :: (RenderMessage y msg, Monad mo) => [msg] -> GGHandler s y mo a+invalidArgsI msg = do+ mr <- getMessageRender+ invalidArgs $ map mr msg+ ------- Headers -- | Set the cookie on the client. setCookie :: Monad mo@@ -748,7 +778,10 @@ { setCookieName = key , setCookieValue = value , setCookiePath = Just cp- , setCookieExpires = Just $ getExpires minutes+ , setCookieExpires =+ if minutes == 0+ then Nothing+ else Just $ getExpires minutes , setCookieDomain = Nothing }) headerToPair cp _ (DeleteCookie key) =@@ -758,12 +791,12 @@ headerToPair _ _ (Header key value) = (key, value) -- | Get a unique identifier.-newIdent :: Monad mo => GGHandler sub master mo String+newIdent :: Monad mo => GGHandler sub master mo String -- FIXME use Text newIdent = GHandler $ lift $ lift $ lift $ do x <- get let i' = ghsIdent x + 1 put x { ghsIdent = i' }- return $ "h" ++ show i'+ return $ 'h' : show i' liftIOHandler :: MonadIO mo => GGHandler sub master IO a@@ -846,3 +879,9 @@ -- | Get the request\'s 'W.Request' value. waiRequest :: Monad mo => GGHandler sub master mo W.Request waiRequest = reqWaiRequest `liftM` getRequest++getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text)+getMessageRender = do+ m <- getYesod+ l <- reqLangs `liftM` getRequest+ return $ renderMessage m l
Yesod/Internal/Core.hs view
@@ -50,7 +50,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius-import Text.Blaze (preEscapedLazyText, (!), customAttribute, textTag, toValue)+import Text.Blaze ((!), customAttribute, textTag, toValue) import qualified Text.Blaze.Html5 as TBH import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8)@@ -484,10 +484,7 @@ let title = maybe mempty unTitle mTitle let scripts = runUniqueList scripts' let stylesheets = runUniqueList stylesheets'- let cssToHtml = preEscapedLazyText . renderCss- celper :: Cassius url -> Hamlet url- celper = fmap cssToHtml- jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b+ let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b jelper :: Julius url -> Hamlet url jelper = fmap jsToHtml
Yesod/Internal/Dispatch.hs view
@@ -156,7 +156,6 @@ let caseExp = rm `AppE` VarE req yr <- [|yesodRunner|] cr <- [|fmap chooseRep|]- pack <- [|Data.Text.pack|] eq <- [|(==)|] let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
+ Yesod/Message.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Yesod.Message+ ( mkMessage+ , RenderMessage (..)+ , ToMessage (..)+ ) where++import Language.Haskell.TH.Syntax+import Data.Text (Text, pack, unpack)+import System.Directory+import Data.Maybe (catMaybes)+import Data.List (isSuffixOf, sortBy, foldl')+import qualified Data.ByteString as S+import Data.Text.Encoding (decodeUtf8)+import Data.Char (isSpace, toLower, toUpper)+import Data.Ord (comparing)+import Text.Shakespeare (Deref (..), Ident (..), parseHash, derefToExp)+import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))+import Control.Arrow ((***))+import Data.Monoid (mempty, mappend)++class ToMessage a where+ toMessage :: a -> Text+instance ToMessage Text where+ toMessage = id+instance ToMessage String where+ toMessage = Data.Text.pack++class RenderMessage master message where+ renderMessage :: master+ -> [Text] -- ^ languages+ -> message+ -> Text++instance RenderMessage master Text where+ renderMessage _ _ = id++type Lang = Text++mkMessage :: String+ -> FilePath+ -> Lang+ -> Q [Dec]+mkMessage dt folder lang = do+ files <- qRunIO $ getDirectoryContents folder+ contents <- qRunIO $ fmap catMaybes $ mapM (loadLang folder) files+ sdef <-+ case lookup lang contents of+ Nothing -> error $ "Did not find main language file: " ++ unpack lang+ Just def -> toSDefs def+ mapM_ (checkDef sdef) $ map snd contents+ let dt' = ConT $ mkName dt+ let mname = mkName $ dt ++ "Message"+ c1 <- fmap concat $ mapM (toClauses dt) contents+ c2 <- mapM (sToClause dt) sdef+ c3 <- defClause+ return+ [ DataD [] mname [] (map (toCon dt) sdef) []+ , InstanceD+ []+ (ConT ''RenderMessage `AppT` dt' `AppT` ConT mname)+ [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]+ ]+ ]++toClauses :: String -> (Lang, [Def]) -> Q [Clause]+toClauses dt (lang, defs) =+ mapM go defs+ where+ go def = do+ a <- newName "lang"+ (pat, bod) <- mkBody dt (constr def) (map fst $ vars def) (content def)+ guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]+ return $ Clause+ [WildP, ConP (mkName ":") [VarP a, WildP], pat]+ (GuardedB [(guard, bod)])+ []++mkBody :: String -- ^ datatype+ -> String -- ^ constructor+ -> [String] -- ^ variable names+ -> [Content]+ -> Q (Pat, Exp)+mkBody dt cs vs ct = do+ vp <- mapM go vs+ let pat = RecP (mkName $ "Msg" ++ cs) (map (varName dt *** VarP) vp)+ let ct' = map (fixVars vp) ct+ pack' <- [|Data.Text.pack|]+ tomsg <- [|toMessage|]+ let ct'' = map (toH pack' tomsg) ct'+ mapp <- [|mappend|]+ let app a b = InfixE (Just a) mapp (Just b)+ e <-+ case ct'' of+ [] -> [|mempty|]+ [x] -> return x+ (x:xs) -> return $ foldl' app x xs+ return (pat, e)+ where+ toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)+ toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d+ go x = do+ let y = mkName $ '_' : x+ return (x, y)+ fixVars vp (Var d) = Var $ fixDeref vp d+ fixVars _ (Raw s) = Raw s+ fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i+ fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)+ fixDeref _ d = d+ fixIdent vp i =+ case lookup i vp of+ Nothing -> i+ Just y -> nameBase y++sToClause :: String -> SDef -> Q Clause+sToClause dt sdef = do+ (pat, bod) <- mkBody dt (sconstr sdef) (map fst $ svars sdef) (scontent sdef)+ return $ Clause+ [WildP, ConP (mkName "[]") [], pat]+ (NormalB bod)+ []++defClause :: Q Clause+defClause = do+ a <- newName "sub"+ c <- newName "langs"+ d <- newName "msg"+ rm <- [|renderMessage|]+ return $ Clause+ [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]+ (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)+ []++toCon :: String -> SDef -> Con+toCon dt (SDef c vs _) =+ RecC (mkName $ "Msg" ++ c) $ map go vs+ where+ go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)++varName :: String -> String -> Name+varName a y =+ mkName $ concat [lower a, "Message", upper y]+ where+ lower (x:xs) = toLower x : xs+ lower [] = []+ upper (x:xs) = toUpper x : xs+ upper [] = []++checkDef :: [SDef] -> [Def] -> Q ()+checkDef x y =+ go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)+ where+ go _ [] = return ()+ go [] (b:_) = error $ "Extra message constructor: " ++ constr b+ go (a:as) (b:bs)+ | sconstr a < constr b = go as (b:bs)+ | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b+ | otherwise = do+ go' (svars a) (vars b)+ go as bs+ go' ((an, at):as) ((bn, mbt):bs)+ | an /= bn = error "Mismatched variable names"+ | otherwise =+ case mbt of+ Nothing -> go' as bs+ Just bt+ | at == bt -> go' as bs+ | otherwise -> error "Mismatched variable types"+ go' [] [] = return ()+ go' _ _ = error "Mistmached variable count"++toSDefs :: [Def] -> Q [SDef]+toSDefs = mapM toSDef++toSDef :: Def -> Q SDef+toSDef d = do+ vars' <- mapM go $ vars d+ return $ SDef (constr d) vars' (content d)+ where+ go (a, Just b) = return (a, b)+ go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)++data SDef = SDef+ { sconstr :: String+ , svars :: [(String, String)]+ , scontent :: [Content]+ }++data Def = Def+ { constr :: String+ , vars :: [(String, Maybe String)]+ , content :: [Content]+ }++loadLang :: FilePath -> FilePath -> IO (Maybe (Lang, [Def]))+loadLang folder file = do+ let file' = folder ++ '/' : file+ e <- doesFileExist file'+ if e && ".msg" `isSuffixOf` file+ then do+ let lang = pack $ reverse $ drop 4 $ reverse file+ bs <- S.readFile file'+ let s = unpack $ decodeUtf8 bs+ defs <- fmap catMaybes $ mapM parseDef $ lines s+ return $ Just (lang, defs)+ else return Nothing++parseDef :: String -> IO (Maybe Def)+parseDef "" = return Nothing+parseDef ('#':_) = return Nothing+parseDef s =+ case end of+ ':':end' -> do+ content' <- fmap compress $ parseContent $ dropWhile isSpace end'+ case words begin of+ [] -> error $ "Missing constructor: " ++ s+ (w:ws) -> return $ Just Def+ { constr = w+ , vars = map parseVar ws+ , content = content'+ }+ _ -> error $ "Missing colon: " ++ s+ where+ (begin, end) = break (== ':') s++data Content = Var Deref | Raw String++compress :: [Content] -> [Content]+compress [] = []+compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest+compress (x:y) = x : compress y++parseContent :: String -> IO [Content]+parseContent s =+ either (error . show) return $ parse go s s+ where+ go = do+ x <- many go'+ eof+ return x+ go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)++parseVar :: String -> (String, Maybe String)+parseVar s =+ case break (== '@') s of+ (x, '@':y) -> (x, Just y)+ _ -> (s, Nothing)
Yesod/Widget.hs view
@@ -11,13 +11,13 @@ , GGWidget (..) , PageContent (..) -- * Special Hamlet quasiquoter/TH for Widgets- , YesodMessage (..)- , getMessageRender , whamlet , whamletFile+ , ihamletToRepHtml -- * Creating -- ** Head of page , setTitle+ , setTitleI , addHamletHead , addHtmlHead -- ** Body@@ -55,7 +55,11 @@ import Text.Lucius (Lucius) import Text.Julius import Yesod.Handler- (Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)+ (Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod+ , getMessageRender+ )+import Yesod.Message (RenderMessage)+import Yesod.Content (RepHtml (..), toContent) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans (lift))@@ -65,8 +69,7 @@ import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)-import Yesod.Handler (getUrlRenderParams, getYesodSub)-import Yesod.Request (languages)+import Yesod.Handler (getUrlRenderParams) import Control.Monad.IO.Control (MonadControlIO) import qualified Text.Hamlet.NonPoly as NP@@ -115,6 +118,13 @@ setTitle :: Monad m => Html -> GGWidget master m () setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty +-- | Set the page title. Calling 'setTitle' multiple times overrides previously+-- set values.+setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) ()+setTitleI msg = do+ mr <- lift getMessageRender+ setTitle $ toHtml $ mr msg+ -- | Add a 'Hamlet' to the head tag. addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m () addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head@@ -217,21 +227,6 @@ , pageBody :: Hamlet url } -class YesodMessage sub master where- type Message sub master- renderMessage :: sub- -> master- -> [Text] -- ^ languages- -> Message sub master- -> Html--getMessageRender :: (Monad mo, YesodMessage s m) => GGHandler s m mo (Message s m -> Html)-getMessageRender = do- s <- getYesodSub- m <- getYesod- l <- languages- return $ renderMessage s m l- whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings @@ -251,6 +246,15 @@ let ur f = do let env = NP.Env (Just $ helper [|lift getUrlRenderParams|])- (Just $ helper [|lift getMessageRender|])+ (Just $ helper [|liftM (toHtml .) $ lift getMessageRender|]) f env- return $ NP.HamletRules ah ur+ return $ NP.HamletRules ah ur $ \_ b -> return b++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+ihamletToRepHtml :: (Monad mo, RenderMessage master message)+ => NP.IHamlet message (Route master)+ -> GGHandler sub master mo RepHtml+ihamletToRepHtml ih = do+ urender <- getUrlRenderParams+ mrender <- getMessageRender+ return $ RepHtml $ toContent $ ih (toHtml . mrender) urender
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.8.1+version: 0.8.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -49,12 +49,15 @@ , blaze-html >= 0.4 && < 0.5 , http-types >= 0.6 && < 0.7 , case-insensitive >= 0.2 && < 0.3+ , parsec >= 2 && < 3.2+ , directory >= 1 && < 1.2 exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch Yesod.Handler Yesod.Request Yesod.Widget+ Yesod.Message other-modules: Yesod.Internal Yesod.Internal.Core Yesod.Internal.Session