From f3e8e778f199a42b6e3cd7b69ffbd2733f00c1b1 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Wed, 20 May 2015 00:07:47 -0700 Subject: [PATCH] import Yesod.Core.Widget into Yesod.Core.Class.Yesod --- yesod-core/Yesod/Core.hs | 6 +- yesod-core/Yesod/Core/Class/Handler.hs | 2 - yesod-core/Yesod/Core/Class/Yesod.hs | 218 ++++++++++---- yesod-core/Yesod/Core/Internal/TH.hs | 6 +- yesod-core/Yesod/Core/Widget.hs | 277 ++++++++++++++++-- yesod-core/Yesod/Shakespeare.hs | 160 +--------- .../test/YesodCoreTest/ErrorHandling.hs | 2 +- yesod-core/test/YesodCoreTest/JsLoader.hs | 1 + yesod-core/yesod-core.cabal | 2 +- 9 files changed, 433 insertions(+), 241 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 652575fb..ae043f24 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index d6e66f61..0f22be5b 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index 0f5d0473..0364020c 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -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 - - - #{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 "" + asHtmlUrl (pageHead p) _render_afYl + TBH.preEscapedText $ T.pack "" + maybeH + mmsg + (\ msg_afYm + -> do { id ((TBH.preEscapedText . T.pack) "

"); + id (TBH.toHtml msg_afYm); + id ((TBH.preEscapedText . T.pack) "

") }) + Nothing + asHtmlUrl (pageBody p) _render_afYl + (TBH.preEscapedText . T.pack) "" + + -- | 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| -

Not Found -

#{path'} - |] + toWidget $ htmlTemplate path' provideRep $ return $ object ["message" .= ("Not Found" :: Text)] + where + -- equivalent to + -- + -- [hamlet| + --

Not Found + --

#{path'} + -- |] + htmlTemplate path' = \_renderer -> do + TBH.preEscapedText $ T.pack "

Not Found

\n

" + TBH.toHtml path' + TBH.preEscapedText $ T.pack "

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

Not logged in -

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

Not logged in + --

Set the authRoute and the user will be redirected there. + -- |] + htmlTemplate = \_renderer -> TBH.preEscapedText $ T.pack + "

Not logged in

\n

Set the authRoute and the user will be redirected there.

" + defaultErrorHandler (PermissionDenied msg) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Permission Denied" - toWidget [hamlet| -

Permission denied -

#{msg} - |] + toWidget htmlTemplate provideRep $ return $ object $ [ "message" .= ("Permission Denied. " <> msg) ] + where + -- equivalent to + -- + -- [hamlet| + --

Permission denied + --

#{msg} + -- |] + htmlTemplate = \_renderer -> do + TBH.preEscapedText $ T.pack "

Permission denied

\n

" + TBH.toHtml msg + TBH.preEscapedText $ T.pack "

" + defaultErrorHandler (InvalidArgs ia) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Invalid Arguments" - toWidget [hamlet| -

Invalid Arguments -