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

import Yesod.Core.Widget into Yesod.Core.Class.Yesod

Browse Source
This commit is contained in:
Greg Weber 2015-05-20 00:07:47 -07:00
parent 478c147c6b
commit f3e8e778f1
9 changed files with 433 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,11 +21,9 @@ module Yesod.Core
, ErrorResponse (..)
-- * Utitlities
, maybeAuthorized
-- FIXME: API breakage
-- , widgetToPageContent
, widgetToPageContent
-- * Defaults
-- FIXME: API breakage
-- , defaultErrorHandler
, defaultErrorHandler
, defaultYesodMiddleware
, authorizationCheck
-- * Data types

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

@ -10,8 +10,6 @@ module Yesod.Core.Class.Handler
) where
import Yesod.Core.Types
import Data.Monoid (mempty)
import Control.Monad (liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
import Control.Monad.Trans.Class (lift)

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

@ -5,6 +5,7 @@
{-# LANGUAGE CPP #-}
module Yesod.Core.Class.Yesod where
import Control.Monad (mplus)
import Control.Monad.Logger (logErrorS)
import Yesod.Core.Content
import Yesod.Core.Handler
@ -15,11 +16,12 @@ import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Control.Arrow ((***), second)
import Control.Exception (bracket)
import Control.Monad (forM, when, void)
import Control.Monad (when, void)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
LogSource)
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Aeson (object, (.=))
@ -30,8 +32,6 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Word (Word64)
import Language.Haskell.TH.Syntax (Loc (..))
import Network.HTTP.Types (encodePath)
@ -41,9 +41,6 @@ import Network.Wai.Parse (lbsBackEnd,
tempFileBackEnd)
import Network.Wai.Logger (ZonedDate, clockDateCacher)
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 qualified Web.ClientSession as CS
@ -51,7 +48,10 @@ import Web.Cookie (parseCookies)
import Web.Cookie (SetCookie (..))
import Yesod.Core.Types
import Yesod.Core.Internal.Session
import Control.Monad.Trans.Class (lift)
-- for jsLoader and defaultErrorHandler
import Yesod.Core.Widget (WidgetT, toWidget, setTitle, PageContent(..), ScriptLoadPosition(BottomOfBody), getMessage, widgetToPageContentUnbound)
import qualified Data.Foldable
-- | Define settings for a Yesod applications. All methods have intelligent
@ -77,28 +77,11 @@ 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
withUrlRenderer [hamlet|
$newline never
$doctype 5
<html>
<head>
<title>#{pageTitle p}
^{pageHead p}
<body>
$maybe msg <- mmsg
<p .message>#{msg}
^{pageBody p}
|]
-}
defaultLayout = defaultDefaultLayout
-- | 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
@ -236,9 +219,8 @@ class RenderRoute site => Yesod site where
-- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
--
-- Or write your own async js loader.
-- FIXME: the type
-- jsLoader :: site -> ScriptLoadPosition site
-- jsLoader _ = BottomOfBody
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
@ -375,7 +357,75 @@ authorizationCheck = do
void $ notAuthenticated
Unauthorized s' -> permissionDenied s'
{- FIXME
-- templating types
type Render url = url -> [(Text, Text)] -> Text
type HtmlUrl url = Render url -> Html
maybeH :: Monad m => Maybe a -> (a -> m ()) -> Maybe (m ()) -> m ()
maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm
widgetToPageContent
:: (Yesod site, Eq (Route site))
=> WidgetT site IO ()
-> HandlerT site IO (PageContent (Route site))
widgetToPageContent = widgetToPageContentUnbound addStaticContent jsLoader
-- | 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
defaultDefaultLayout :: Yesod site => WidgetT site IO () -> HandlerT site IO Html
defaultDefaultLayout w = do
p <- widgetToPageContent w
mmsg <- getMessage
withUrlRenderer $ htmlTemplate p mmsg
where
asHtmlUrl :: HtmlUrl url -> HtmlUrl url
asHtmlUrl = id
-- equivalent to
-- [hamlet|
-- $newline never
-- $doctype 5
-- <html>
-- <head>
-- <title>#{pageTitle p}
-- ^{pageHead p}
-- <body>
-- $maybe msg <- mmsg
-- <p .message>#{msg}
-- ^{pageBody p}
-- |]
htmlTemplate p mmsg = \_render_afYl -> do
TBH.preEscapedText $ T.pack "<!DOCTYPE html>\n<html><head><title>"
TBH.toHtml (pageTitle p)
TBH.preEscapedText $ T.pack "</title>"
asHtmlUrl (pageHead p) _render_afYl
TBH.preEscapedText $ T.pack "</head><body>"
maybeH
mmsg
(\ msg_afYm
-> do { id ((TBH.preEscapedText . T.pack) "<p class=\"message\">");
id (TBH.toHtml msg_afYm);
id ((TBH.preEscapedText . T.pack) "</p>") })
Nothing
asHtmlUrl (pageBody p) _render_afYl
(TBH.preEscapedText . T.pack) "</body></html>"
-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
defaultErrorHandler NotFound = selectRep $ do
@ -383,11 +433,19 @@ defaultErrorHandler NotFound = selectRep $ do
r <- waiRequest
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
setTitle "Not Found"
toWidget [hamlet|
<h1>Not Found
<p>#{path'}
|]
toWidget $ htmlTemplate path'
provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
where
-- equivalent to
--
-- [hamlet|
-- <h1>Not Found
-- <p>#{path'}
-- |]
htmlTemplate path' = \_renderer -> do
TBH.preEscapedText $ T.pack "<h1>Not Found</h1>\n<p>"
TBH.toHtml path'
TBH.preEscapedText $ T.pack "</p>"
-- For API requests.
-- For a user with a browser,
@ -396,10 +454,7 @@ defaultErrorHandler NotFound = selectRep $ do
defaultErrorHandler NotAuthenticated = selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Not logged in"
toWidget [hamlet|
<h1>Not logged in
<p style="display:none;">Set the authRoute and the user will be redirected there.
|]
toWidget htmlTemplate
provideRep $ do
-- 401 *MUST* include a WWW-Authenticate header
@ -417,48 +472,97 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
case authRoute site of
Nothing -> []
Just url -> ["authentication_url" .= rend url]
where
-- equivalent to
-- [hamlet|
-- <h1>Not logged in
-- <p style="display:none;">Set the authRoute and the user will be redirected there.
-- |]
htmlTemplate = \_renderer -> TBH.preEscapedText $ T.pack
"<h1>Not logged in</h1>\n<p style=\"display:none;\">Set the authRoute and the user will be redirected there.</p>"
defaultErrorHandler (PermissionDenied msg) = selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Permission Denied"
toWidget [hamlet|
<h1>Permission denied
<p>#{msg}
|]
toWidget htmlTemplate
provideRep $
return $ object $ [
"message" .= ("Permission Denied. " <> msg)
]
where
-- equivalent to
--
-- [hamlet|
-- <h1>Permission denied
-- <p>#{msg}
-- |]
htmlTemplate = \_renderer -> do
TBH.preEscapedText $ T.pack "<h1>Permission denied</h1>\n<p>"
TBH.toHtml msg
TBH.preEscapedText $ T.pack "</p>"
defaultErrorHandler (InvalidArgs ia) = selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Invalid Arguments"
toWidget [hamlet|
<h1>Invalid Arguments
<ul>
$forall msg <- ia
<li>#{msg}
|]
toWidget htmlTemplate
provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
where
-- equivalent to
-- [hamlet|
-- <h1>Invalid Arguments
-- <ul>
-- $forall msg <- ia
-- <li>#{msg}
-- |]
htmlTemplate = \_renderer -> do
(TBH.preEscapedText . T.pack) "<h1>Invalid Arguments</h1>\n<ul>"
Data.Foldable.mapM_
(\ msg_afNn
-> do { (TBH.preEscapedText . T.pack) "<li>";
TBH.toHtml msg_afNn;
(TBH.preEscapedText . T.pack) "</li>" })
ia;
(TBH.preEscapedText . T.pack) "</ul>"
defaultErrorHandler (InternalError e) = do
$logErrorS "yesod-core" e
selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Internal Server Error"
toWidget [hamlet|
<h1>Internal Server Error
<pre>#{e}
|]
toWidget htmlTemplate
provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
where
-- equivalent to
-- [hamlet|
-- <h1>Internal Server Error
-- <pre>#{e}
-- |]
htmlTemplate = \_renderer -> do
(TBH.preEscapedText . T.pack) "<h1>Internal Server Error</h1>\n<pre>"
TBH.toHtml e
(TBH.preEscapedText . T.pack) "</pre>"
defaultErrorHandler (BadMethod m) = selectRep $ do
provideRep $ defaultLayout $ do
setTitle"Bad Method"
toWidget [hamlet|
<h1>Method Not Supported
<p>Method <code>#{S8.unpack m}</code> not supported
|]
toWidget $ htmlTemplate
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
-}
where
-- equivalent to
--
-- [hamlet|
-- <h1>Method Not Supported
-- <p>Method <code>#{S8.unpack m}</code> not supported
-- |]
htmlTemplate = \ _render -> do
TBH.preEscapedText $ T.pack
"<h1>Method Not Supported</h1>\n<p>Method <code>"
TBH.toHtml (S8.unpack m)
TBH.preEscapedText $ T.pack "</code> not supported</p>"
formatLogMessage :: IO ZonedDate
-> Loc

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

@ -22,6 +22,7 @@ import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
import Yesod.Core.Widget (WidgetT)
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@ -55,9 +56,8 @@ masterTypeSyns :: Type -> [Dec]
masterTypeSyns site =
[ TySynD (mkName "Handler") []
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
-- FIXME
-- , TySynD (mkName "Widget") []
-- $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
, TySynD (mkName "Widget") []
$ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
]
mkYesodGeneral :: String -- ^ foundation type

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

@ -47,6 +47,12 @@ module Yesod.Core.Widget
, asWidgetT
, tellWidget
-- * Formerly Yesod.Core.Class.Yesod
, jelper
, asyncHelper
, jsToHtml
, widgetToPageContentUnbound
-- * Formerly Yesod.Core.Types
, ScriptLoadPosition(..)
, BottomOfHeadAsync
@ -66,7 +72,6 @@ module Yesod.Core.Widget
, hamletToRepHtml
-- * Formerly Yesod.Core.Json
-- FIXME
-- , defaultLayoutJson
-- * Formerly Yesod.Core
@ -74,7 +79,7 @@ module Yesod.Core.Widget
) where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
import Control.Monad (liftM, ap, forM, mplus)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadCatch (..))
import Control.Monad.Catch (MonadMask (..))
@ -98,6 +103,7 @@ 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 Blaze.ByteString.Builder (Builder)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush (Chunk), Producer, ConduitM)
import Data.Conduit.Internal (Pipe(..))
import Data.Conduit.Lazy (MonadActive, monadActive)
@ -110,6 +116,7 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Yesod.Routes.Class
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Text (Text)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import System.Log.FastLogger (toLogStr)
@ -117,9 +124,17 @@ import qualified Data.Text.Lazy as TL
import Yesod.Core.Types
import Yesod.Core.Class.Handler
import Yesod.Core.Handler (setSession, lookupSession, deleteSession, withUrlRenderer, sendChunk)
import Yesod.Core.Handler (setSession, lookupSession, deleteSession, withUrlRenderer, sendChunk, getUrlRenderParams, getYesod)
import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), ToFlushBuilder(..), typeHtml)
import Data.List (foldl', nub)
import Data.Map (Map, unionWith)
import Data.Text.Lazy.Builder (toLazyText)
import qualified Data.Text.Lazy.Builder as TLB
import Data.Text.Lazy.Encoding (encodeUtf8)
import qualified Data.Foldable
import qualified Data.Text
import qualified Text.Blaze.Html5 as TBH
import qualified Text.Blaze.Html5 as H
-- templating types
type Render url = url -> [(Text, Text)] -> Text
@ -489,20 +504,242 @@ sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
sendChunkHtml = sendChunk
-----------------------------
-- 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/
{- FIXME
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
-}
maybeH :: Monad m => Maybe a -> (a -> m ()) -> Maybe (m ()) -> m ()
maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm
type AddStaticContent site m = Text -- ^ filename extension
-> Text -- ^ mime-type
-> L.ByteString -- ^ content
-> HandlerT site m (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 m
-> (site -> ScriptLoadPosition site)
-> WidgetT site m ()
-> 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 $ toLazyText $ s render
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
scriptLoad = regularScriptLoad scripts jscript jsLoc
headAll = headContent head' stylesheets css master asyncScripts mcomplete scriptLoad
let bodyScript = bodyScriptLoad body scriptLoad
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 []
-- equivalent to
--
-- [hamlet|
-- $newline never
-- ^{body}
-- ^{scriptLoad}
-- |]
bodyScriptLoad body scriptLoad = \renderer -> do
asHtmlUrl body renderer
asHtmlUrl scriptLoad renderer
-- equivalent to
--
-- [hamlet|
-- $newline never
-- $forall s <- scripts
-- ^{mkScriptTag s}
-- $maybe j <- jscript
-- $maybe s <- jsLoc
-- <script src="#{s}">
-- $nothing
-- <script>^{jelper j}
-- |]
regularScriptLoad scripts jscript jsLoc = \_render_ahpp -> do
{ Data.Foldable.mapM_
(\ s_ahpq -> asHtmlUrl (mkScriptTag s_ahpq) _render_ahpp) scripts;
maybeH
jscript
(\ j_ahpr
-> maybeH
jsLoc
(\ s_ahps
-> do { id ((H.preEscapedText . Data.Text.pack) "<script src=\"");
id (TBH.toHtml s_ahps);
id ((H.preEscapedText . Data.Text.pack) "\"></script>") })
(Just
(do { id ((H.preEscapedText . Data.Text.pack) "<script>");
asHtmlUrl (jelper j_ahpr) _render_ahpp;
id ((H.preEscapedText . Data.Text.pack) "</script>") })))
Nothing }
-- equivalent to
--
-- [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
-- ^{scriptLoad}
-- |]
headContent head' stylesheets css master asyncScripts mcomplete scriptLoad = \_render_ahmq -> do
{ asHtmlUrl head' _render_ahmq;
Data.Foldable.mapM_
(\ s_ahmr -> asHtmlUrl (mkLinkTag s_ahmr) _render_ahmq)
stylesheets;
Data.Foldable.mapM_
(\ s_ahms
-> do { maybeH
(right (snd s_ahms))
(\ t_ahmt
-> maybeH
(fst s_ahms)
(\ media_ahmu
-> do { id
((H.preEscapedText . Data.Text.pack)
"<link rel=\"stylesheet\" media=\"");
id (TBH.toHtml media_ahmu);
id
((H.preEscapedText . Data.Text.pack)
"\" href=\"");
id (TBH.toHtml t_ahmt);
id ((H.preEscapedText . Data.Text.pack) "\">") })
(Just
(do { id
((H.preEscapedText . Data.Text.pack)
"<link rel=\"stylesheet\" href=\"");
id (TBH.toHtml t_ahmt);
id ((H.preEscapedText . Data.Text.pack) "\">") })))
Nothing;
maybeH
(left (snd s_ahms))
(\ content_ahmv
-> maybeH
(fst s_ahms)
(\ media_ahmw
-> do { id
((H.preEscapedText . Data.Text.pack)
"<style media=\"");
id (TBH.toHtml media_ahmw);
id ((H.preEscapedText . Data.Text.pack) "\">");
id (TBH.toHtml content_ahmv);
id
((H.preEscapedText . Data.Text.pack)
"</style>") })
(Just
(do { id ((H.preEscapedText . Data.Text.pack) "<style>");
id (TBH.toHtml content_ahmv);
id
((H.preEscapedText . Data.Text.pack)
"</style>") })))
Nothing })
css;
case jsLoader master of
BottomOfBody -> return ()
BottomOfHeadAsync asyncJsLoader_ahmx -> asHtmlUrl (asyncJsLoader_ahmx asyncScripts mcomplete) _render_ahmq
BottomOfHeadBlocking -> asHtmlUrl scriptLoad _render_ahmq
}
asyncHelper :: (url -> [x] -> Text)
-> [Script (url)]
-> Maybe (BuilderUrl 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 :: TLB.Builder -> Html
jsToHtml b = preEscapedToMarkup $ toLazyText b
jelper :: (Render url -> TLB.Builder) -> 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
asHtmlUrl :: HtmlUrl url -> HtmlUrl url
asHtmlUrl = id

160
yesod-core/Yesod/Shakespeare.hs
View File

@ -24,10 +24,6 @@ module Yesod.Shakespeare (
-- * i18n
, getMessageRender
-- * Formerly Yesod.Core.Class.Yesod
, jelper
, asyncHelper
, jsToHtml
-- * Formerly Yesod.Core.Handler
-- ** Redirecting
, redirectToPost
@ -51,8 +47,9 @@ module Yesod.Shakespeare (
, module Text.Shakespeare.I18N
) where
import Control.Monad.IO.Class (MonadIO)
import Control.Monad (liftM, forM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Class (lift)
import Text.Shakespeare.I18N
import qualified Data.ByteString.Lazy as L
import Data.List (foldl', nub)
@ -63,7 +60,6 @@ import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP)
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (fromLazyText, toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Monoid (Last(..), mempty)
import qualified Data.Map as Map
@ -80,6 +76,11 @@ import Yesod.Core.Handler (getUrlRenderParams, toTextUrl, invalidArgs, permissio
import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), typeJavascript, typeCss)
import Yesod.Routes.Class (Route)
-- for hamlet expansion
import qualified Data.Foldable
import qualified Data.Text
import Text.Hamlet (asHtmlUrl)
type Translate msg = msg -> Html
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
type Render url = url -> [(Text, Text)] -> Text
@ -158,153 +159,6 @@ $doctype 5
<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 mJS' (Head head')) <- lift $ unWidgetT w hd
let jscript = fmap (\x -> Javascript . x) mJS'
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
------------------------------------

2
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -3,9 +3,9 @@
{-# LANGUAGE ViewPatterns #-}
module YesodCoreTest.ErrorHandling
( errorHandlingTest
, Widget
) where
import Yesod.Core
import Yesod.Shakespeare (whamlet)
import Yesod.Core.Widget
import Test.Hspec
import Network.Wai

1
yesod-core/test/YesodCoreTest/JsLoader.hs
View File

@ -8,6 +8,7 @@ import YesodCoreTest.JsLoaderSites.Bottom (B(..))
import Test.Hspec
import Yesod.Core
import Yesod.Core.Widget
import Network.Wai.Test
data H = H

2
yesod-core/yesod-core.cabal
View File

@ -104,7 +104,7 @@ library
Yesod.Routes.TH.ParseRoute
Yesod.Routes.TH.RouteAttrs
ghc-options: -Wall
ghc-options: -Wall -ddump-splices -ddump-to-file
-- Following line added due to: https://github.com/yesodweb/yesod/issues/545
-- This looks like a GHC bug
extensions: MultiParamTypeClasses