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

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 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