haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove shakespeare dependency from Yesod.Core

Browse Source
This commit is contained in:
Greg Weber 2015-05-18 19:36:18 -07:00
parent fd9610a6a0
commit c45a2c45df
10 changed files with 591 additions and 492 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
yesod-core/Yesod/Core.hs
View File

@ -21,14 +21,15 @@ module Yesod.Core
, ErrorResponse (..)
-- * Utitlities
, maybeAuthorized
, widgetToPageContent
-- FIXME: API breakage
-- , widgetToPageContent
-- * Defaults
, defaultErrorHandler
-- FIXME: API breakage
-- , defaultErrorHandler
, defaultYesodMiddleware
, authorizationCheck
-- * Data types
, AuthResult (..)
, unauthorizedI
-- * Logging
, defaultMakeLogger
, defaultMessageLoggerSource
@ -58,13 +59,11 @@ module Yesod.Core
, loadClientSession
, Header(..)
-- * JS loaders
, ScriptLoadPosition (..)
, BottomOfHeadAsync
-- * Subsites
, MonadHandler (..)
, MonadWidget (..)
, getRouteToParent
, defaultLayoutSub
-- FIXME
-- , defaultLayoutSub
-- * Misc
, yesodVersion
, yesodRender
@ -77,9 +76,7 @@ module Yesod.Core
, module Yesod.Core.Content
, module Yesod.Core.Dispatch
, module Yesod.Core.Handler
, module Yesod.Core.Widget
, module Yesod.Core.Json
, module Text.Shakespeare.I18N
, module Yesod.Core.Internal.Util
, module Text.Blaze.Html
, MonadTrans (..)
@ -93,31 +90,30 @@ module Yesod.Core
-- * Utilities
, showIntegral
, readIntegral
-- FIXME: API breakage
-- * Shakespeare
-- ** Hamlet
, hamlet
, shamlet
, xhamlet
, HtmlUrl
-- , hamlet
-- , shamlet
-- , xhamlet
-- , HtmlUrl
-- ** Julius
, julius
, JavascriptUrl
, renderJavascriptUrl
-- , julius
-- , JavascriptUrl
-- , renderJavascriptUrl
-- ** Cassius/Lucius
, cassius
, lucius
, CssUrl
, renderCssUrl
-- , cassius
-- , lucius
-- , CssUrl
-- , renderCssUrl
) where
import Yesod.Core.Content
import Yesod.Core.Dispatch
import Yesod.Core.Handler
import Yesod.Core.Class.Handler
import Yesod.Core.Widget
import Yesod.Core.Json
import Yesod.Core.Types
import Text.Shakespeare.I18N
import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
@ -139,10 +135,6 @@ import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..))
import Yesod.Core.Internal.LiteApp
import Text.Hamlet
import Text.Cassius
import Text.Lucius
import Text.Julius
import Network.Wai (Application)
runFakeHandler :: (Yesod site, MonadIO m) =>
@ -154,12 +146,6 @@ runFakeHandler :: (Yesod site, MonadIO m) =>
runFakeHandler = Yesod.Core.Internal.Run.runFakeHandler
{-# DEPRECATED runFakeHandler "import runFakeHandler from Yesod.Core.Unsafe" #-}
-- | 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
yesodVersion :: String
yesodVersion = showVersion Paths_yesod_core.version
@ -178,10 +164,12 @@ maybeAuthorized r isWrite = do
getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)
getRouteToParent = HandlerT $ return . handlerToParent
{-
defaultLayoutSub :: Yesod parent
=> WidgetT child IO ()
-> HandlerT child (HandlerT parent IO) Html
defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout
-}
showIntegral :: Integral a => a -> String
showIntegral x = show (fromIntegral x :: Integer)

29
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -7,7 +7,6 @@
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Class.Handler
( MonadHandler (..)
, MonadWidget (..)
) where
import Yesod.Core.Types
@ -43,11 +42,6 @@ instance MonadResourceBase m => MonadHandler (HandlerT site m) where
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
GO(IdentityT)
@ -65,26 +59,3 @@ GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO
#undef GOX
class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where
liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ReaderT r)
GO(StateT s)
GOX(Monoid w, WriterT w)
GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO
#undef GOX

154
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -23,8 +23,6 @@ import Control.Monad.Trans.Resource (InternalState, createIntern
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Aeson (object, (.=))
import Data.List (foldl')
import Data.List (nub)
import qualified Data.Map as Map
import Data.Monoid
import Data.Text (Text)
@ -45,17 +43,16 @@ import System.Log.FastLogger
import Text.Blaze (customAttribute, textTag,
toValue, (!))
import Text.Blaze (preEscapedToMarkup)
import Text.Blaze.Html (Html)
import qualified Text.Blaze.Html5 as TBH
import Text.Hamlet
import Text.Julius
import qualified Web.ClientSession as CS
import Web.Cookie (parseCookies)
import Web.Cookie (SetCookie (..))
import Yesod.Core.Types
import Yesod.Core.Internal.Session
import Yesod.Core.Widget
import Control.Monad.Trans.Class (lift)
-- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required.
class RenderRoute site => Yesod site where
@ -79,10 +76,12 @@ class RenderRoute site => Yesod site where
--
-- Default value: 'defaultErrorHandler'.
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
errorHandler = defaultErrorHandler
-- errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page.
{- FIXME
defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
widgetToPageContent = widgetToPageContentUnbound addStaticContent jsLoader
defaultLayout w = do
p <- widgetToPageContent w
mmsg <- getMessage
@ -98,6 +97,7 @@ class RenderRoute site => Yesod site where
<p .message>#{msg}
^{pageBody p}
|]
-}
-- | Override the rendering function for a particular URL. One use case for
-- this is to offload static hosting to a different domain name to avoid
@ -229,8 +229,9 @@ class RenderRoute site => Yesod site where
-- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
--
-- Or write your own async js loader.
jsLoader :: site -> ScriptLoadPosition site
jsLoader _ = BottomOfBody
-- FIXME: the type
-- jsLoader :: site -> ScriptLoadPosition site
-- jsLoader _ = BottomOfBody
-- | Create a session backend. Returning 'Nothing' disables
-- sessions. If you'd like to change the way that the session
@ -411,104 +412,7 @@ authorizationCheck = do
void $ notAuthenticated
Unauthorized s' -> permissionDenied s'
-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: (Eq (Route site), Yesod site)
=> WidgetT site IO ()
-> HandlerT site IO (PageContent (Route site))
widgetToPageContent 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 ! customAttribute (textTag y) (toValue z)
mkScriptTag (Script loc attrs) render' =
foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
mkLinkTag (Stylesheet loc attrs) render' =
foldl' addAttr TBH.link
( ("rel", "stylesheet")
: ("href", renderLoc' render' loc)
: attrs
)
runUniqueList :: Eq x => UniqueList x -> [x]
runUniqueList (UniqueList x) = nub $ x []
{- FIXME
-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
defaultErrorHandler NotFound = selectRep $ do
@ -591,29 +495,7 @@ defaultErrorHandler (BadMethod m) = selectRep $ do
<p>Method <code>#{S8.unpack m}</code> not supported
|]
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
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
-}
-- | Default formatting for log messages.
--
@ -704,20 +586,6 @@ envClientSessionBackend minutes name = do
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
return $ clientSessionBackend key getCachedDate
jsToHtml :: Javascript -> Html
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
jelper :: JavascriptUrl url -> HtmlUrl url
jelper = fmap jsToHtml
left :: Either a b -> Maybe a
left (Left x) = Just x
left _ = Nothing
right :: Either a b -> Maybe b
right (Right x) = Just x
right _ = Nothing
clientSessionBackend :: CS.Key -- ^ The encryption key
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
-> SessionBackend

29
yesod-core/Yesod/Core/Content.hs
View File

@ -58,8 +58,6 @@ import Control.Monad (liftM)
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Data.Monoid (mempty)
import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource))
@ -74,8 +72,6 @@ import Data.Aeson.Encode (fromValue)
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
import Data.Text.Lazy.Builder (toLazyText)
import Yesod.Core.Types
import Text.Lucius (Css, renderCss)
import Text.Julius (Javascript, unJavascript)
-- | Zero-length enumerator.
emptyContent :: Content
@ -106,8 +102,6 @@ instance ToContent Text where
toContent = toContent . Blaze.fromLazyText
instance ToContent String where
toContent = toContent . Blaze.fromString
instance ToContent Html where
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
instance ToContent () where
toContent () = toContent B.empty
instance ToContent (ContentType, Content) where
@ -115,11 +109,6 @@ instance ToContent (ContentType, Content) where
instance ToContent TypedContent where
toContent (TypedContent _ c) = c
instance ToContent Css where
toContent = toContent . renderCss
instance ToContent Javascript where
toContent = toContent . toLazyText . unJavascript
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)
@ -145,8 +134,6 @@ instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromTex
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString
instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString
instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder
repJson :: ToContent a => a -> RepJson
repJson = RepJson . toContent
@ -255,21 +242,12 @@ instance ToContent J.Value where
instance HasContentType J.Value where
getContentType _ = typeJson
instance HasContentType Html where
getContentType _ = typeHtml
instance HasContentType Text where
getContentType _ = typePlain
instance HasContentType T.Text where
getContentType _ = typePlain
instance HasContentType Css where
getContentType _ = typeCss
instance HasContentType Javascript where
getContentType _ = typeJavascript
-- | Any type which can be converted to 'TypedContent'.
--
-- Since 1.2.0
@ -290,8 +268,6 @@ instance ToTypedContent RepXml where
toTypedContent (RepXml c) = TypedContent typeXml c
instance ToTypedContent J.Value where
toTypedContent v = TypedContent typeJson (toContent v)
instance ToTypedContent Html where
toTypedContent h = TypedContent typeHtml (toContent h)
instance ToTypedContent T.Text where
toTypedContent t = TypedContent typePlain (toContent t)
instance ToTypedContent [Char] where
@ -302,8 +278,3 @@ instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
toTypedContent (DontFullyEvaluate a) =
let TypedContent ct c = toTypedContent a
in TypedContent ct (ContentDontEvaluate c)
instance ToTypedContent Css where
toTypedContent = TypedContent typeCss . toContent
instance ToTypedContent Javascript where
toTypedContent = TypedContent typeJavascript . toContent

101
yesod-core/Yesod/Core/Handler.hs
View File

@ -4,7 +4,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
@ -72,21 +71,17 @@ module Yesod.Core.Handler
, sendChunkLBS
, sendChunkText
, sendChunkLazyText
, sendChunkHtml
-- ** Redirecting
, RedirectUrl (..)
, redirect
, redirectWith
, redirectToPost
, Fragment(..)
-- ** Errors
, notFound
, badMethod
, notAuthenticated
, permissionDenied
, permissionDeniedI
, invalidArgs
, invalidArgsI
-- ** Short-circuit responses.
, sendFile
, sendFilePart
@ -132,13 +127,8 @@ module Yesod.Core.Handler
, setUltDestReferer
, redirectUltDest
, clearUltDest
-- ** Messages
, setMessage
, setMessageI
, getMessage
-- * Helpers for specific content
-- ** Hamlet
, hamletToRepHtml
, giveUrlRenderer
, withUrlRenderer
-- ** Misc
@ -146,8 +136,6 @@ module Yesod.Core.Handler
-- * Lifting
, handlerToIO
, forkHandler
-- * i18n
, getMessageRender
-- * Per-request caching
, cached
, cachedBy
@ -178,8 +166,6 @@ import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html.Renderer.Text as RenderText
import Text.Hamlet (Html, HtmlUrl, hamlet)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
@ -190,11 +176,9 @@ import qualified Data.ByteString.Char8 as S8
import Data.Monoid (Endo (..), mappend, mempty)
import Data.Text (Text)
import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..))
import Web.Cookie (SetCookie (..))
import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToMarkup, toHtml)
import qualified Data.IORef.Lifted as I
import Data.Maybe (listToMaybe, mapMaybe)
@ -482,34 +466,6 @@ redirectUltDest def = do
clearUltDest :: MonadHandler m => m ()
clearUltDest = deleteSession ultDestKey
msgKey :: Text
msgKey = "_MSG"
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
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.
--
-- See 'setMessage'.
getMessage :: MonadHandler m => m (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey
deleteSession msgKey
return mmsg
-- | Bypass remaining handler code and output the given file.
--
-- For some backends, this is more efficient than reading in the file to
@ -624,24 +580,10 @@ notAuthenticated = hcError NotAuthenticated
permissionDenied :: MonadHandler m => Text -> m a
permissionDenied = hcError . PermissionDenied
-- | 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.
invalidArgs :: MonadHandler m => [Text] -> m a
invalidArgs = hcError . InvalidArgs
-- | 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
------- Headers
-- | Set the cookie on the client.
@ -838,36 +780,6 @@ newIdent = do
put x { ghsIdent = i' }
return $ T.pack $ "hident" ++ show i'
-- | 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
-- | 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" #-}
-- | Deprecated synonym for 'withUrlRenderer'.
--
-- Since 1.2.0
@ -892,13 +804,6 @@ withUrlRenderer f = do
waiRequest :: MonadHandler m => m W.Request
waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
=> m (message -> Text)
getMessageRender = do
env <- askHandlerEnv
l <- reqLangs `liftM` getRequest
return $ renderMessage (rheSite env) l
-- | Use a per-request cache to avoid performing the same action multiple times.
-- Values are stored by their type, the result of typeOf from Typeable.
-- Therefore, you should use different newtype wrappers at each cache site.
@ -1234,12 +1139,6 @@ sendChunkText = sendChunk
sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)
sendChunkLazyText = sendChunk
-- | Type-specialized version of 'sendChunk' for @Html@s.
--
-- Since 1.2.0
sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
sendChunkHtml = sendChunk
-- | Converts a child handler to a parent handler
--
-- Exported since 1.4.11

1
yesod-core/Yesod/Core/Internal/LiteApp.hs
View File

@ -7,6 +7,7 @@ import Data.Monoid
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
import Yesod.Core.Types
import Yesod.Core.Widget (WidgetT)
import Yesod.Core.Content
import Data.Text (Text)
import Web.PathPieces

5
yesod-core/Yesod/Core/Internal/TH.hs
View File

@ -55,8 +55,9 @@ masterTypeSyns :: Type -> [Dec]
masterTypeSyns site =
[ TySynD (mkName "Handler") []
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
, TySynD (mkName "Widget") []
$ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
-- FIXME
-- , TySynD (mkName "Widget") []
-- $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
]
mkYesodGeneral :: String -- ^ foundation type

19
yesod-core/Yesod/Core/Json.hs
View File

@ -3,8 +3,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Core.Json
( -- * Convert from a JSON value
defaultLayoutJson
, jsonToRepJson
jsonToRepJson
, returnJson
, provideJson
@ -32,9 +31,8 @@ import Control.Monad.Trans.Writer (Writer)
import Data.Monoid (Endo)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Types (reqAccept)
import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Class.Yesod (Yesod)
import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
import Yesod.Routes.Class
import qualified Data.Aeson as J
import qualified Data.Aeson.Parser as JP
@ -48,19 +46,6 @@ import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad (liftM)
-- | Provide both an HTML and JSON representation for a piece of
-- data, using the default layout for the HTML output
-- ('defaultLayout').
--
-- /Since: 0.3.0/
defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> WidgetT site IO () -- ^ HTML
-> HandlerT site IO a -- ^ JSON
-> HandlerT site IO TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
provideRep $ fmap J.toJSON json
-- | Wraps a data type in a 'RepJson'. The data type must
-- support conversion to JSON via 'J.ToJSON'.
--

136
yesod-core/Yesod/Core/Types.hs
View File

@ -27,10 +27,9 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, Source)
import Data.IORef (IORef)
import Data.Map (Map, unionWith)
import qualified Data.Map as Map
import Data.Monoid (Endo (..), Last (..),
Monoid (..))
import Data.Map (Map)
import Data.Monoid (Endo (..), Monoid (..))
import Data.Serialize (Serialize (..),
putByteString)
import Data.String (IsString (fromString))
@ -49,8 +48,6 @@ import System.Log.FastLogger (LogStr, LoggerSet, toLogStr
import qualified System.Random.MWC as MWC
import Network.Wai.Logger (DateCacheGetter)
import Text.Blaze.Html (Html)
import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl)
import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime)
import Control.Monad.Trans.Class (MonadTrans (..))
@ -159,16 +156,6 @@ type ResolvedApproot = Text
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
deriving (Eq, Show, Read)
data ScriptLoadPosition master
= BottomOfBody
| BottomOfHeadBlocking
| BottomOfHeadAsync (BottomOfHeadAsync master)
type BottomOfHeadAsync master
= [Text] -- ^ urls to load asynchronously
-> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
-> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
type Texts = [Text]
-- | Wrap up a normal WAI application as a Yesod subsite.
@ -239,18 +226,6 @@ data GHState = GHState
-- the 'HandlerT' monad and template haskell code should hide it away.
type YesodApp = YesodRequest -> ResourceT IO YesodResponse
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- better error messages.
newtype WidgetT site m a = WidgetT
{ unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
}
instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
mempty = return ()
mappend x y = x >> y
instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
type RY master = Route master -> [(Text, Text)] -> Text
-- | Newtype wrapper allowing injection of arbitrary content into CSS.
@ -262,16 +237,6 @@ type RY master = Route master -> [(Text, Text)] -> Text
-- Since: 1.1.3
newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
-- | Content for a web page. By providing this datatype, we can easily create
-- generic site templates, which would have the type signature:
--
-- > PageContent url -> HtmlUrl url
data PageContent url = PageContent
{ pageTitle :: Html
, pageHead :: HtmlUrl url
, pageBody :: HtmlUrl url
}
data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
| ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
| ContentFile !FilePath !(Maybe FilePart)
@ -332,37 +297,8 @@ data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttribute
deriving (Show, Eq)
newtype Title = Title { unTitle :: Html }
newtype Head url = Head (HtmlUrl url)
deriving Monoid
instance Semigroup (Head a)
newtype Body url = Body (HtmlUrl url)
deriving Monoid
instance Semigroup (Body a)
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
data GWData a = GWData
{ gwdBody :: !(Body a)
, gwdTitle :: !(Last Title)
, gwdScripts :: !(UniqueList (Script a))
, gwdStylesheets :: !(UniqueList (Stylesheet a))
, gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
, gwdJavascript :: !(Maybe (JavascriptUrl a))
, gwdHead :: !(Head a)
}
instance Monoid (GWData a) where
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
mappend (GWData a1 a2 a3 a4 a5 a6 a7)
(GWData b1 b2 b3 b4 b5 b6 b7) = GWData
(a1 `mappend` b1)
(a2 `mappend` b2)
(a3 `mappend` b3)
(a4 `mappend` b4)
(unionWith mappend a5 b5)
(a6 `mappend` b6)
(a7 `mappend` b7)
instance Semigroup (GWData a)
data HandlerContents =
HCContent H.Status !TypedContent
| HCError ErrorResponse
@ -383,51 +319,6 @@ instance Show HandlerContents where
show (HCWaiApp _) = "HCWaiApp"
instance Exception HandlerContents
-- Instances for WidgetT
instance Monad m => Functor (WidgetT site m) where
fmap = liftM
instance Monad m => Applicative (WidgetT site m) where
pure = return
(<*>) = ap
instance Monad m => Monad (WidgetT site m) where
return a = WidgetT $ const $ return (a, mempty)
WidgetT x >>= f = WidgetT $ \r -> do
(a, wa) <- x r
(b, wb) <- unWidgetT (f a) r
return (b, wa `mappend` wb)
instance MonadIO m => MonadIO (WidgetT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . const . liftBase . fmap (, mempty)
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
#if MIN_VERSION_monad_control(1,0,0)
type StM (WidgetT site m) a = StM m (a, GWData (Route site))
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ runInBase . flip unWidgetT reader')
restoreM = WidgetT . const . restoreM
#else
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . flip unWidgetT reader')
restoreM (StW base) = WidgetT $ const $ restoreM base
#endif
instance Monad m => MonadReader site (WidgetT site m) where
ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
local f (WidgetT g) = WidgetT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
instance MonadTrans (WidgetT site) where
lift = WidgetT . const . liftM (, mempty)
instance MonadThrow m => MonadThrow (WidgetT site m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (HandlerT site m) where
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
instance MonadMask m => MonadMask (HandlerT site m) where
@ -436,29 +327,6 @@ instance MonadMask m => MonadMask (HandlerT site m) where
uninterruptibleMask a =
HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b)
instance MonadCatch m => MonadCatch (WidgetT site m) where
catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
instance MonadMask m => MonadMask (WidgetT site m) where
mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
uninterruptibleMask a =
WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where
monadLoggerLog a b c d = WidgetT $ \hd ->
liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)
#if MIN_VERSION_monad_logger(0, 3, 10)
instance MonadIO m => MonadLoggerIO (WidgetT site m) where
askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty)
#endif
instance MonadActive m => MonadActive (WidgetT site m) where
monadActive = lift monadActive
instance MonadActive m => MonadActive (HandlerT site m) where
monadActive = lift monadActive

557
yesod-core/Yesod/Core/Widget.hs
View File

@ -1,3 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
@ -6,6 +9,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
@ -13,7 +18,7 @@
-- generator, allowing you to create truly modular HTML components.
module Yesod.Core.Widget
( -- * Datatype
WidgetT
WidgetT(..)
, PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets
, whamlet
@ -48,31 +53,113 @@ module Yesod.Core.Widget
-- * Internal
, whamletFileWithSettings
, asWidgetT
-- * Formerly Yesod.Core.Types
, ScriptLoadPosition(..)
, BottomOfHeadAsync
, GWData(..)
, 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
-- , defaultLayoutJson
-- * Formerly Yesod.Core
, MonadWidget (..)
) where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap, forM)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadCatch (..))
import Control.Monad.Catch (MonadMask (..))
import Control.Monad.Logger (MonadLogger (..))
#if MIN_VERSION_monad_logger(0, 3, 10)
import Control.Monad.Logger (MonadLoggerIO (..))
#endif
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResourceBase, MonadResource (..), runInternalState, MonadThrow (..))
import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List ( ListT )
import Control.Monad.Trans.Maybe ( MaybeT )
import Control.Monad.Trans.Error ( ErrorT, Error)
import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.State ( StateT )
import Control.Monad.Trans.Writer ( WriterT )
import Control.Monad.Trans.RWS ( RWST )
import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder (Builder)
import Data.Conduit (Flush (Chunk), Producer, ConduitM)
import Data.Conduit.Internal (Pipe(..))
import Data.Conduit.Lazy (MonadActive, monadActive)
import Data.List (foldl', nub)
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 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 Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM)
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)
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
import Data.Text.Lazy.Builder (fromLazyText, toLazyText)
import System.Log.FastLogger (toLogStr)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (encodeUtf8)
import Yesod.Core.Types
import Yesod.Core.Class.Handler
import Yesod.Core.Class.Yesod (Yesod)
import Yesod.Core.Handler (getUrlRenderParams, toTextUrl, invalidArgs, permissionDenied, setSession, lookupSession, deleteSession, RedirectUrl, withUrlRenderer, sendChunk, getRequest, getYesod, sendResponse, selectRep, provideRep)
import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), ToFlushBuilder(..), typeJavascript, typeHtml, typeCss)
import Data.Map (Map, unionWith)
import qualified Data.Aeson as J
------------------------------------
-- Original Yesod.Core.Widget
------------------------------------
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
@ -297,3 +384,463 @@ liftGWD tp gwd = GWData
fixCss f = f . fixRender
fixJS f = f . fixRender
------------------------------------
-- Formerly Yesod.Core.Types
------------------------------------
data GWData a = GWData
{ gwdBody :: !(Body a)
, gwdTitle :: !(Last Title)
, gwdScripts :: !(UniqueList (Script a))
, gwdStylesheets :: !(UniqueList (Stylesheet a))
, gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
, gwdJavascript :: !(Maybe (JavascriptUrl a))
, gwdHead :: !(Head a)
}
instance Monoid (GWData a) where
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
mappend (GWData a1 a2 a3 a4 a5 a6 a7)
(GWData b1 b2 b3 b4 b5 b6 b7) = GWData
(a1 `mappend` b1)
(a2 `mappend` b2)
(a3 `mappend` b3)
(a4 `mappend` b4)
(unionWith mappend a5 b5)
(a6 `mappend` b6)
(a7 `mappend` b7)
instance Semigroup (GWData a)
-- Instances for WidgetT
instance Monad m => Functor (WidgetT site m) where
fmap = liftM
instance Monad m => Applicative (WidgetT site m) where
pure = return
(<*>) = ap
instance Monad m => Monad (WidgetT site m) where
return a = WidgetT $ const $ return (a, mempty)
WidgetT x >>= f = WidgetT $ \r -> do
(a, wa) <- x r
(b, wb) <- unWidgetT (f a) r
return (b, wa `mappend` wb)
instance MonadIO m => MonadIO (WidgetT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . const . liftBase . fmap (, mempty)
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
#if MIN_VERSION_monad_control(1,0,0)
type StM (WidgetT site m) a = StM m (a, GWData (Route site))
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ runInBase . flip unWidgetT reader')
restoreM = WidgetT . const . restoreM
#else
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . flip unWidgetT reader')
restoreM (StW base) = WidgetT $ const $ restoreM base
#endif
instance Monad m => MonadReader site (WidgetT site m) where
ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
local f (WidgetT g) = WidgetT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
instance MonadTrans (WidgetT site) where
lift = WidgetT . const . liftM (, mempty)
instance MonadThrow m => MonadThrow (WidgetT site m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (WidgetT site m) where
catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
instance MonadMask m => MonadMask (WidgetT site m) where
mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
uninterruptibleMask a =
WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where
monadLoggerLog a b c d = WidgetT $ \hd ->
liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)
#if MIN_VERSION_monad_logger(0, 3, 10)
instance MonadIO m => MonadLoggerIO (WidgetT site m) where
askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty)
#endif
instance MonadActive m => MonadActive (WidgetT site m) where
monadActive = lift monadActive
data ScriptLoadPosition master
= BottomOfBody
| BottomOfHeadBlocking
| BottomOfHeadAsync (BottomOfHeadAsync master)
type BottomOfHeadAsync master
= [Text] -- ^ urls to load asynchronously
-> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
-> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- better error messages.
newtype WidgetT site m a = WidgetT
{ unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
}
instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
mempty = return ()
mappend x y = x >> y
instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
-- | Content for a web page. By providing this datatype, we can easily create
-- generic site templates, which would have the type signature:
--
-- > PageContent url -> HtmlUrl url
data PageContent url = PageContent
{ pageTitle :: Html
, pageHead :: HtmlUrl url
, pageBody :: HtmlUrl url
}
newtype Head url = Head (HtmlUrl url)
deriving Monoid
instance Semigroup (Head a)
newtype Body url = Body (HtmlUrl url)
deriving Monoid
instance Semigroup (Body a)
------------------------------------
-- Formerly Yesod.Core.Content
------------------------------------
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
------------------------------------
replaceToParent :: HandlerData site route -> HandlerData site ()
replaceToParent hd = hd { handlerToParent = const () }
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where
liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ReaderT r)
GO(StateT s)
GOX(Monoid w, WriterT w)
GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO
#undef GOX
------------------------------------
-- Formerly Yesod.Core.Handler
------------------------------------
msgKey :: Text
msgKey = T.pack "_MSG"
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
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.
--
-- See 'setMessage'.
getMessage :: MonadHandler m => m (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey
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
<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
-- | 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
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
-----------------------------
-- | Provide both an HTML and JSON representation for a piece of
-- data, using the default layout for the HTML output
-- ('defaultLayout').
--
-- /Since: 0.3.0/
{-
defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> WidgetT site IO () -- ^ HTML
-> HandlerT site IO a -- ^ JSON
-> HandlerT site IO TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
provideRep $ fmap J.toJSON json
-}