diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 27c638ce..3c33ea8e 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -298,6 +298,7 @@ data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttribute newtype Title = Title { unTitle :: Html } type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder +type BuilderUrl url = (url -> [(Text, Text)] -> Text) -> TBuilder.Builder data HandlerContents = HCContent H.Status !TypedContent diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index 8194fad6..70acaf8e 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -20,11 +20,6 @@ module Yesod.Core.Widget ( -- * Datatype WidgetT(..) , PageContent (..) - -- * Special Hamlet quasiquoter/TH for Widgets - , whamlet - , whamletFile - , ihamletToRepHtml - , ihamletToHtml -- * Convert to Widget , ToWidget (..) , ToWidgetHead (..) @@ -33,7 +28,6 @@ module Yesod.Core.Widget -- * Creating -- ** Head of page , setTitle - , setTitleI -- ** CSS , addStylesheet , addStylesheetAttrs @@ -51,7 +45,6 @@ module Yesod.Core.Widget , widgetToParentWidget , handlerToWidget -- * Internal - , whamletFileWithSettings , asWidgetT -- * Formerly Yesod.Core.Types @@ -61,30 +54,16 @@ module Yesod.Core.Widget , Head(..) , Body(..) - -- * Formerly Yesod.Core.Class.Yesod - , jelper - , asyncHelper - , jsToHtml - -- * Formerly Yesod.Core.Class.Handler -- * Formerly Yesod.Core.Handler -- ** Streaming , sendChunkHtml - -- ** Redirecting - , redirectToPost - -- ** Errors - , permissionDeniedI - , invalidArgsI - , unauthorizedI -- ** Messages , setMessage - , setMessageI , getMessage -- ** Hamlet , hamletToRepHtml - -- * i18n - , getMessageRender -- * Formerly Yesod.Core.Json -- FIXME @@ -128,22 +107,16 @@ import Data.Monoid import Data.Semigroup (Semigroup) import qualified Data.Text as T import qualified Text.Blaze.Html.Renderer.Text as RenderText -import Text.Blaze.Html (preEscapedToMarkup, toHtml) +import Text.Blaze.Html (preEscapedToMarkup, toHtml, Html) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Text.Shakespeare.I18N (renderMessage) import Yesod.Routes.Class import Control.Monad.IO.Class (MonadIO, liftIO) -import Text.Shakespeare.I18N (RenderMessage) import Data.Text (Text) import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName) -import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText, toLazyText) import System.Log.FastLogger (toLogStr) import qualified Data.Text.Lazy as TL @@ -157,6 +130,17 @@ import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..) import Data.Map (Map, unionWith) import qualified Data.Aeson as J +-- templating types +class ToWidgetBuilder a where + toWidgetBuilder :: a -> Builder + +type Render url = url -> [(Text, Text)] -> Text +type Translate msg = msg -> Html +type HtmlUrl url = Render url -> Html +type HtmlUrlI18n msg url = Translate msg -> Render url -> Html + + + ------------------------------------ -- Original Yesod.Core.Widget ------------------------------------ @@ -168,18 +152,10 @@ class ToWidget site a where instance render ~ RY site => ToWidget site (render -> Html) where toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty -instance render ~ RY site => ToWidget site (render -> Css) where - toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x -instance ToWidget site Css where - toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance ToWidget site CssBuilder where toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty -instance render ~ RY site => ToWidget site (render -> Javascript) where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -instance ToWidget site Javascript where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where toWidget = liftWidgetT instance ToWidget site Html where @@ -196,10 +172,6 @@ class ToWidgetMedia site a where => Text -- ^ media value -> a -> m () -instance render ~ RY site => ToWidgetMedia site (render -> Css) where - toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x -instance ToWidgetMedia site Css where - toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty instance ToWidgetMedia site CssBuilder where @@ -210,10 +182,6 @@ class ToWidgetBody site a where instance render ~ RY site => ToWidgetBody site (render -> Html) where toWidgetBody = toWidget -instance render ~ RY site => ToWidgetBody site (render -> Javascript) where - toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j -instance ToWidgetBody site Javascript where - toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j instance ToWidgetBody site Html where toWidgetBody = toWidget @@ -222,33 +190,12 @@ class ToWidgetHead site a where instance render ~ RY site => ToWidgetHead site (render -> Html) where toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head -instance render ~ RY site => ToWidgetHead site (render -> Css) where - toWidgetHead = toWidget -instance ToWidgetHead site Css where - toWidgetHead = toWidget -instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where - toWidgetHead = toWidget -instance ToWidgetHead site CssBuilder where - toWidgetHead = toWidget -instance render ~ RY site => ToWidgetHead site (render -> Javascript) where - toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j -instance ToWidgetHead site Javascript where - toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j -instance ToWidgetHead site Html where - toWidgetHead = toWidgetHead . const -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: MonadWidget m => Html -> m () setTitle x = 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 :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () -setTitleI msg = do - mr <- getMessageRender - setTitle $ toHtml $ mr msg - -- | Link to the specified local stylesheet. addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m () addStylesheet = flip addStylesheetAttrs [] @@ -294,53 +241,6 @@ addScriptRemote = flip addScriptRemoteAttrs [] addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty -whamlet :: QuasiQuoter -whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings - -whamletFile :: FilePath -> Q Exp -whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings - -whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp -whamletFileWithSettings = NP.hamletFileWithSettings rules - -asWidgetT :: WidgetT site m () -> WidgetT site m () -asWidgetT = id - -rules :: Q NP.HamletRules -rules = do - ah <- [|asWidgetT . toWidget|] - let helper qg f = do - x <- newName "urender" - e <- f $ VarE x - let e' = LamE [VarP x] e - g <- qg - bind <- [|(>>=)|] - return $ InfixE (Just g) bind (Just e') - let ur f = do - let env = NP.Env - (Just $ helper [|getUrlRenderParams|]) - (Just $ helper [|liftM (toHtml .) getMessageRender|]) - f env - return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) - => HtmlUrlI18n message (Route (HandlerSite m)) - -> m Html -ihamletToRepHtml = ihamletToHtml -{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-} - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. --- --- Since 1.2.1 -ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) - => HtmlUrlI18n message (Route (HandlerSite m)) - -> m Html -ihamletToHtml ih = do - urender <- getUrlRenderParams - mrender <- getMessageRender - return $ ih (toHtml . mrender) urender - tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m () tell w = liftWidgetT $ WidgetT $ const $ return ((), w) @@ -396,7 +296,7 @@ data GWData a = GWData , gwdScripts :: !(UniqueList (Script a)) , gwdStylesheets :: !(UniqueList (Stylesheet a)) , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type - , gwdJavascript :: !(Maybe (JavascriptUrl a)) + , gwdJavascript :: !(Maybe (BuilderUrl a)) , gwdHead :: !(Head a) } instance Monoid (GWData a) where @@ -503,6 +403,10 @@ instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where mappend x y = x >> y instance (a ~ (), Monad m) => Semigroup (WidgetT site m a) +asWidgetT :: WidgetT site m () -> WidgetT site m () +asWidgetT = id + + -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: -- @@ -527,25 +431,13 @@ instance Semigroup (Body a) ------------------------------------ instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing -instance ToContent Css where - toContent = toContent . renderCss -instance ToContent Javascript where - toContent = toContent . toLazyText . unJavascript instance ToTypedContent Html where toTypedContent h = TypedContent typeHtml (toContent h) instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder -instance ToTypedContent Css where - toTypedContent = TypedContent typeCss . toContent -instance ToTypedContent Javascript where - toTypedContent = TypedContent typeJavascript . toContent instance HasContentType Html where getContentType _ = typeHtml -instance HasContentType Css where - getContentType _ = typeCss -instance HasContentType Javascript where - getContentType _ = typeJavascript ------------------------------------ -- Formerly Yesod.Core.Class.Handler @@ -593,15 +485,6 @@ msgKey = T.pack "_MSG" setMessage :: MonadHandler m => Html -> m () setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml --- | Sets a message in the user's session. --- --- See 'getMessage'. -setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) - => msg -> m () -setMessageI msg = do - mr <- getMessageRender - setMessage $ toHtml $ mr msg - -- | Gets the message in the user's session, if available, and then clears the -- variable. -- @@ -612,58 +495,11 @@ getMessage = do deleteSession msgKey return mmsg --- | Return a 403 permission denied page. -permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m) - => msg - -> m a -permissionDeniedI msg = do - mr <- getMessageRender - permissionDenied $ mr msg - --- | Return a 400 invalid arguments page. -invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a -invalidArgsI msg = do - mr <- getMessageRender - invalidArgs $ map mr msg - --- | 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 :: (MonadHandler m, RedirectUrl (HandlerSite m) url) - => url - -> m a -redirectToPost url = do - urlText <- toTextUrl url - withUrlRenderer [hamlet| -$newline never -$doctype 5 - - - - Redirecting... - <body onload="document.getElementById('form').submit()"> - <form id="form" method="post" action=#{urlText}> - <noscript> - <p>Javascript has been disabled; please click on the button below to be redirected. - <input type="submit" value="Continue"> -|] >>= sendResponse - - -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html hamletToRepHtml = withUrlRenderer {-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-} -getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) - => m (message -> Text) -getMessageRender = do - site <- getYesod - l <- reqLangs `liftM` getRequest - return $ renderMessage site l - -- | Type-specialized version of 'sendChunk' for @Html@s. -- -- Since 1.2.0 @@ -671,162 +507,6 @@ sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder) sendChunkHtml = sendChunk ------------------------------- --- from Yesod.Core.Class.Yesod ------------------------------- -type AddStaticContent site = Text -- ^ filename extension - -> Text -- ^ mime-type - -> L.ByteString -- ^ content - -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) - --- | Convert a widget to a 'PageContent'. --- not bound to the Yesod typeclass -{- widgetToPageContentUnbound - :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, Eq (Route site)) - => AddStaticContent site -> site -> ScriptLoadPosition site -> WidgetT site IO () - -> HandlerT site m (PageContent (Route site)) - -} -widgetToPageContentUnbound addStaticContent jsLoader w = do - master <- getYesod - hd <- HandlerT return - ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd - let title = maybe mempty unTitle mTitle - scripts = runUniqueList scripts' - stylesheets = runUniqueList stylesheets' - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - css <- forM (Map.toList style) $ \(mmedia, content) -> do - let rendered = toLazyText $ content render - x <- addStaticContent "css" "text/css; charset=utf-8" - $ encodeUtf8 rendered - return (mmedia, - case x of - Nothing -> Left $ preEscapedToMarkup rendered - Just y -> Right $ either id (uncurry render) y) - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ encodeUtf8 $ renderJavascriptUrl render s - return $ renderLoc x - - -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing - -- the asynchronous loader means your page doesn't have to wait for all the js to load - let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc - regularScriptLoad = [hamlet| - $newline never - $forall s <- scripts - ^{mkScriptTag s} - $maybe j <- jscript - $maybe s <- jsLoc - <script src="#{s}"> - $nothing - <script>^{jelper j} - |] - - headAll = [hamlet| - $newline never - \^{head'} - $forall s <- stylesheets - ^{mkLinkTag s} - $forall s <- css - $maybe t <- right $ snd s - $maybe media <- fst s - <link rel=stylesheet media=#{media} href=#{t}> - $nothing - <link rel=stylesheet href=#{t}> - $maybe content <- left $ snd s - $maybe media <- fst s - <style media=#{media}>#{content} - $nothing - <style>#{content} - $case jsLoader master - $of BottomOfBody - $of BottomOfHeadAsync asyncJsLoader - ^{asyncJsLoader asyncScripts mcomplete} - $of BottomOfHeadBlocking - ^{regularScriptLoad} - |] - let bodyScript = [hamlet| - $newline never - ^{body} - ^{regularScriptLoad} - |] - - return $ PageContent title headAll $ - case jsLoader master of - BottomOfBody -> bodyScript - _ -> body - where - renderLoc' render' (Local url) = render' url [] - renderLoc' _ (Remote s) = s - - addAttr x (y, z) = x H.! H.customAttribute (H.textTag y) (H.toValue z) - mkScriptTag (Script loc attrs) render' = - foldl' addAttr H.script (("src", renderLoc' render' loc) : attrs) $ return () - mkLinkTag (Stylesheet loc attrs) render' = - foldl' addAttr H.link - ( ("rel", "stylesheet") - : ("href", renderLoc' render' loc) - : attrs - ) - - runUniqueList :: Eq x => UniqueList x -> [x] - runUniqueList (UniqueList x) = nub $ x [] - -asyncHelper :: (url -> [x] -> Text) - -> [Script (url)] - -> Maybe (JavascriptUrl (url)) - -> Maybe Text - -> (Maybe (HtmlUrl url), [Text]) -asyncHelper render scripts jscript jsLoc = - (mcomplete, scripts'') - where - scripts' = map goScript scripts - scripts'' = - case jsLoc of - Just s -> scripts' ++ [s] - Nothing -> scripts' - goScript (Script (Local url) _) = render url [] - goScript (Script (Remote s) _) = s - mcomplete = - case jsLoc of - Just{} -> Nothing - Nothing -> - case jscript of - Nothing -> Nothing - Just j -> Just $ jelper j - -jsToHtml :: Javascript -> Html -jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b - -jelper :: JavascriptUrl url -> HtmlUrl url -jelper = fmap jsToHtml - -right :: Either a b -> Maybe b -right (Right x) = Just x -right _ = Nothing - -left :: Either a b -> Maybe a -left (Left x) = Just x -left _ = Nothing - - ------------------------------ --- originally from Yesod.Core ------------------------------ --- | Return an 'Unauthorized' value, with the given i18n message. -unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult -unauthorizedI msg = do - mr <- getMessageRender - return $ Unauthorized $ mr msg - ----------------------------- -- originally from Yesod.Core.Json ----------------------------- @@ -835,7 +515,7 @@ unauthorizedI msg = do -- ('defaultLayout'). -- -- /Since: 0.3.0/ -{- +{- FIXME defaultLayoutJson :: (Yesod site, J.ToJSON a) => WidgetT site IO () -- ^ HTML -> HandlerT site IO a -- ^ JSON diff --git a/yesod-core/Yesod/Shakespeare.hs b/yesod-core/Yesod/Shakespeare.hs new file mode 100644 index 00000000..fbdfea8c --- /dev/null +++ b/yesod-core/Yesod/Shakespeare.hs @@ -0,0 +1,365 @@ +module Yesod.Shakespeare ( + , whamlet + , whamletFile + -- * Special Hamlet quasiquoter/TH for Widgets + , ihamletToRepHtml + , ihamletToHtml + -- * Internal + , whamletFileWithSettings + -- * Creating + -- ** Head of page + , setTitleI + -- ** Errors + , permissionDeniedI + , invalidArgsI + , unauthorizedI + -- ** Messages + , setMessageI + -- * i18n + , getMessageRender + + -- * Formerly Yesod.Core.Class.Yesod + , jelper + , asyncHelper + , jsToHtml + -- * Formerly Yesod.Core.Handler + -- ** Redirecting + , redirectToPost + + -- * Shakespeare + -- ** Hamlet + , hamlet + , shamlet + , xhamlet + , HtmlUrl + -- ** Julius + , julius + , JavascriptUrl + , renderJavascriptUrl + -- ** Cassius/Lucius + , cassius + , lucius + , CssUrl + , renderCssUrl +) where + +import Yesod.Core.Widget +import Text.Shakespeare.I18N + +instance ToWidgetBuilder Javascript where + toWidgetBuilder = unJavascript + +whamlet :: QuasiQuoter +whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings + +whamletFile :: FilePath -> Q Exp +whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings + +whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp +whamletFileWithSettings = NP.hamletFileWithSettings rules + +rules :: Q NP.HamletRules +rules = do + ah <- [|asWidgetT . toWidget|] + let helper qg f = do + x <- newName "urender" + e <- f $ VarE x + let e' = LamE [VarP x] e + g <- qg + bind <- [|(>>=)|] + return $ InfixE (Just g) bind (Just e') + let ur f = do + let env = NP.Env + (Just $ helper [|getUrlRenderParams|]) + (Just $ helper [|liftM (toHtml .) getMessageRender|]) + f env + return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b + +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) + => HtmlUrlI18n message (Route (HandlerSite m)) + -> m Html +ihamletToRepHtml = ihamletToHtml +{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-} + +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +-- +-- Since 1.2.1 +ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) + => HtmlUrlI18n message (Route (HandlerSite m)) + -> m Html +ihamletToHtml ih = do + urender <- getUrlRenderParams + mrender <- getMessageRender + return $ ih (toHtml . mrender) urender + + +-- | 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 :: (MonadHandler m, RedirectUrl (HandlerSite m) url) + => url + -> m a +redirectToPost url = do + urlText <- toTextUrl url + withUrlRenderer [hamlet| +$newline never +$doctype 5 + +<html> + <head> + <title>Redirecting... + <body onload="document.getElementById('form').submit()"> + <form id="form" method="post" action=#{urlText}> + <noscript> + <p>Javascript has been disabled; please click on the button below to be redirected. + <input type="submit" value="Continue"> +|] >>= sendResponse + +------------------------------ +-- from Yesod.Core.Class.Yesod +------------------------------ +type AddStaticContent site = Text -- ^ filename extension + -> Text -- ^ mime-type + -> L.ByteString -- ^ content + -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) + +-- | Convert a widget to a 'PageContent'. +-- not bound to the Yesod typeclass +{- widgetToPageContentUnbound + :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, Eq (Route site)) + => AddStaticContent site -> site -> ScriptLoadPosition site -> WidgetT site IO () + -> HandlerT site m (PageContent (Route site)) + -} +widgetToPageContentUnbound addStaticContent jsLoader w = do + master <- getYesod + hd <- HandlerT return + ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd + let title = maybe mempty unTitle mTitle + scripts = runUniqueList scripts' + stylesheets = runUniqueList stylesheets' + + render <- getUrlRenderParams + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right (u, p)) -> Just $ render u p + css <- forM (Map.toList style) $ \(mmedia, content) -> do + let rendered = toLazyText $ content render + x <- addStaticContent "css" "text/css; charset=utf-8" + $ encodeUtf8 rendered + return (mmedia, + case x of + Nothing -> Left $ preEscapedToMarkup rendered + Just y -> Right $ either id (uncurry render) y) + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ encodeUtf8 $ renderJavascriptUrl render s + return $ renderLoc x + + -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing + -- the asynchronous loader means your page doesn't have to wait for all the js to load + let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc + regularScriptLoad = [hamlet| + $newline never + $forall s <- scripts + ^{mkScriptTag s} + $maybe j <- jscript + $maybe s <- jsLoc + <script src="#{s}"> + $nothing + <script>^{jelper j} + |] + + headAll = [hamlet| + $newline never + \^{head'} + $forall s <- stylesheets + ^{mkLinkTag s} + $forall s <- css + $maybe t <- right $ snd s + $maybe media <- fst s + <link rel=stylesheet media=#{media} href=#{t}> + $nothing + <link rel=stylesheet href=#{t}> + $maybe content <- left $ snd s + $maybe media <- fst s + <style media=#{media}>#{content} + $nothing + <style>#{content} + $case jsLoader master + $of BottomOfBody + $of BottomOfHeadAsync asyncJsLoader + ^{asyncJsLoader asyncScripts mcomplete} + $of BottomOfHeadBlocking + ^{regularScriptLoad} + |] + let bodyScript = [hamlet| + $newline never + ^{body} + ^{regularScriptLoad} + |] + + return $ PageContent title headAll $ + case jsLoader master of + BottomOfBody -> bodyScript + _ -> body + where + renderLoc' render' (Local url) = render' url [] + renderLoc' _ (Remote s) = s + + addAttr x (y, z) = x H.! H.customAttribute (H.textTag y) (H.toValue z) + mkScriptTag (Script loc attrs) render' = + foldl' addAttr H.script (("src", renderLoc' render' loc) : attrs) $ return () + mkLinkTag (Stylesheet loc attrs) render' = + foldl' addAttr H.link + ( ("rel", "stylesheet") + : ("href", renderLoc' render' loc) + : attrs + ) + + runUniqueList :: Eq x => UniqueList x -> [x] + runUniqueList (UniqueList x) = nub $ x [] + +asyncHelper :: (url -> [x] -> Text) + -> [Script (url)] + -> Maybe (JavascriptUrl (url)) + -> Maybe Text + -> (Maybe (HtmlUrl url), [Text]) +asyncHelper render scripts jscript jsLoc = + (mcomplete, scripts'') + where + scripts' = map goScript scripts + scripts'' = + case jsLoc of + Just s -> scripts' ++ [s] + Nothing -> scripts' + goScript (Script (Local url) _) = render url [] + goScript (Script (Remote s) _) = s + mcomplete = + case jsLoc of + Just{} -> Nothing + Nothing -> + case jscript of + Nothing -> Nothing + Just j -> Just $ jelper j + +jsToHtml :: Javascript -> Html +jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b + +jelper :: JavascriptUrl url -> HtmlUrl url +jelper = fmap jsToHtml + +right :: Either a b -> Maybe b +right (Right x) = Just x +right _ = Nothing + +left :: Either a b -> Maybe a +left (Left x) = Just x +left _ = Nothing + +------------------------------------ +-- Formerly Yesod.Core.Content +------------------------------------ +instance ToContent Css where + toContent = toContent . renderCss +instance ToContent Javascript where + toContent = toContent . toLazyText . unJavascript +instance HasContentType Css where + getContentType _ = typeCss +instance HasContentType Javascript where + getContentType _ = typeJavascript +instance ToTypedContent Css where + toTypedContent = TypedContent typeCss . toContent +instance ToTypedContent Javascript where + toTypedContent = TypedContent typeJavascript . toContent + +------------------------------------ +-- Formerly Yesod.Core.Widget +------------------------------------ +instance render ~ RY site => ToWidget site (render -> Css) where + toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x +instance ToWidget site Css where + toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x +instance render ~ RY site => ToWidget site (render -> Javascript) where + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty +instance ToWidget site Javascript where + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty +instance render ~ RY site => ToWidgetMedia site (render -> Css) where + toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x +instance ToWidgetMedia site Css where + toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x +instance render ~ RY site => ToWidgetHead site (render -> Css) where + toWidgetHead = toWidget +instance render ~ RY site => ToWidgetHead site (render -> Javascript) where + toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j +instance ToWidgetHead site Javascript where + toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j +instance render ~ RY site => ToWidgetBody site (render -> Javascript) where + toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j +instance ToWidgetBody site Javascript where + toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j +instance ToWidgetHead site Html where + toWidgetHead = toWidgetHead . const +instance ToWidgetHead site Css where + toWidgetHead = toWidget +instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where + toWidgetHead = toWidget +instance ToWidgetHead site CssBuilder where + toWidgetHead = toWidget + +-- | Set the page title. Calling 'setTitle' multiple times overrides previously +-- set values. +setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () +setTitleI msg = do + mr <- getMessageRender + setTitle $ toHtml $ mr msg + + +-- | Sets a message in the user's session. +-- +-- See 'getMessage'. +setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) + => msg -> m () +setMessageI msg = do + mr <- getMessageRender + setMessage $ toHtml $ mr msg + +-- | Return a 403 permission denied page. +permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m) + => msg + -> m a +permissionDeniedI msg = do + mr <- getMessageRender + permissionDenied $ mr msg + +-- | Return a 400 invalid arguments page. +invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a +invalidArgsI msg = do + mr <- getMessageRender + invalidArgs $ map mr msg + + +getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) + => m (message -> Text) +getMessageRender = do + site <- getYesod + l <- reqLangs `liftM` getRequest + return $ renderMessage site l + +----------------------------- +-- originally from Yesod.Core +----------------------------- +-- | Return an 'Unauthorized' value, with the given i18n message. +unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult +unauthorizedI msg = do + mr <- getMessageRender + return $ Unauthorized $ mr msg + diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 309b944b..66d8b96d 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -30,7 +30,6 @@ library , text >= 0.7 , template-haskell , path-pieces >= 0.1.2 && < 0.3 - , shakespeare >= 2.0 , blaze-builder >= 0.2.1.4 && < 0.5 , transformers >= 0.2.2 , mtl