aabb126d63
Move shakespeare specific stuff to Yesod.Shakespeare I have not bothered to make Yesod.Shakespeare compile yet The dependency chain is now Yesod.Core -> Yesod.Widget -> Yesod.Shakespeare
366 lines
12 KiB
Haskell
366 lines
12 KiB
Haskell
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
|
|
|