diff --git a/Yesod/Core.hs b/Yesod/Core.hs --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -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) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -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. diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -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 diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -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 diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -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 []) diff --git a/Yesod/Message.hs b/Yesod/Message.hs new file mode 100644 --- /dev/null +++ b/Yesod/Message.hs @@ -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) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -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 diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.8.1 +version: 0.8.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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