yesod-core 1.4.29 → 1.4.30
raw patch · 3 files changed
+34/−34 lines, 3 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Yesod.Core: defaultMessageWidget :: Yesod site => Html -> HtmlUrl (Route site) -> WidgetT site IO ()
- Yesod.Core: class RenderRoute site => Yesod site where approot = ApprootRelative errorHandler = defaultErrorHandler defaultLayout w = do { p <- widgetToPageContent w; msgs <- getMessages; withUrlRenderer (\ _render_a1hFe -> do { id ((preEscapedText . pack) "<!DOCTYPE html>\n\ \<html><head><title>"); id (toHtml (pageTitle p)); id ((preEscapedText . pack) "</title>"); asHtmlUrl (pageHead p) _render_a1hFe; id ((preEscapedText . pack) "</head><body>"); mapM_ (\ (status_a1hFf, msg_a1hFg) -> do { id ((preEscapedText . pack) "<p class=\"message "); id (toHtml status_a1hFf); id ((preEscapedText . pack) "\">"); id (toHtml msg_a1hFg); id ((preEscapedText . pack) "</p>") }) msgs; asHtmlUrl (pageBody p) _render_a1hFe; id ((preEscapedText . pack) "</body></html>") }) } urlRenderOverride _ _ = Nothing urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route where addParams [] routeBldr = routeBldr addParams nonEmptyParams routeBldr = let routeBS = toByteString routeBldr qsSeparator = fromChar $ if elem '?' routeBS then '&' else '?' valueToMaybe t = if t == "" then Nothing else Just t queryText = map (id *** valueToMaybe) nonEmptyParams in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText isAuthorized _ _ = return Authorized isWriteRequest _ = do { wai <- waiRequest; return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] } authRoute _ = Nothing cleanPath _ s = if corrected == s then Right $ map dropDash s else Left corrected where corrected = filter (not . null) s dropDash t | all (== '-') t = drop 1 t | otherwise = t joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ encodeUtf8 x addDash t | all (== '-') t = cons '-' t | otherwise = t addStaticContent _ _ _ = return Nothing maximumContentLength _ _ = Just $ 2 * 1024 * 1024 makeLogger _ = defaultMakeLogger messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site jsLoader _ = BottomOfBody jsAttributes _ = [] makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 defaultKeyFile fileUpload _ (KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd shouldLog _ = defaultShouldLog shouldLogIO a b c = return (shouldLog a b c) yesodMiddleware = defaultYesodMiddleware yesodWithInternalState _ _ = bracket createInternalState closeInternalState
+ Yesod.Core: class RenderRoute site => Yesod site where approot = ApprootRelative errorHandler = defaultErrorHandler defaultLayout w = do { p <- widgetToPageContent w; msgs <- getMessages; withUrlRenderer (\ _render_a1hFf -> do { id ((preEscapedText . pack) "<!DOCTYPE html>\n\ \<html><head><title>"); id (toHtml (pageTitle p)); id ((preEscapedText . pack) "</title>"); asHtmlUrl (pageHead p) _render_a1hFf; id ((preEscapedText . pack) "</head><body>"); mapM_ (\ (status_a1hFg, msg_a1hFh) -> do { id ((preEscapedText . pack) "<p class=\"message "); id (toHtml status_a1hFg); id ((preEscapedText . pack) "\">"); id (toHtml msg_a1hFh); id ((preEscapedText . pack) "</p>") }) msgs; asHtmlUrl (pageBody p) _render_a1hFf; id ((preEscapedText . pack) "</body></html>") }) } urlRenderOverride _ _ = Nothing urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route where addParams [] routeBldr = routeBldr addParams nonEmptyParams routeBldr = let routeBS = toByteString routeBldr qsSeparator = fromChar $ if elem '?' routeBS then '&' else '?' valueToMaybe t = if t == "" then Nothing else Just t queryText = map (id *** valueToMaybe) nonEmptyParams in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText isAuthorized _ _ = return Authorized isWriteRequest _ = do { wai <- waiRequest; return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] } authRoute _ = Nothing cleanPath _ s = if corrected == s then Right $ map dropDash s else Left corrected where corrected = filter (not . null) s dropDash t | all (== '-') t = drop 1 t | otherwise = t joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ encodeUtf8 x addDash t | all (== '-') t = cons '-' t | otherwise = t addStaticContent _ _ _ = return Nothing maximumContentLength _ _ = Just $ 2 * 1024 * 1024 makeLogger _ = defaultMakeLogger messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site jsLoader _ = BottomOfBody jsAttributes _ = [] makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 defaultKeyFile fileUpload _ (KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd shouldLog _ = defaultShouldLog shouldLogIO a b c = return (shouldLog a b c) yesodMiddleware = defaultYesodMiddleware yesodWithInternalState _ _ = bracket createInternalState closeInternalState defaultMessageWidget title body = do { setTitle title; toWidget (\ _render_a1hFT -> do { id ((preEscapedText . pack) "<h1>"); id (toHtml title); id ((preEscapedText . pack) "</h1>\n"); asHtmlUrl body _render_a1hFT }) }
Files
- ChangeLog.md +4/−0
- Yesod/Core/Class/Yesod.hs +29/−33
- yesod-core.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.4.30++* Add `defaultMessageWidget`+ ## 1.4.29 * Exports some internals and fix version bounds [#1318](https://github.com/yesodweb/yesod/pull/1318)
Yesod/Core/Class/Yesod.hs view
@@ -319,6 +319,19 @@ yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a yesodWithInternalState _ _ = bracket createInternalState closeInternalState {-# INLINE yesodWithInternalState #-}++ -- | Convert a title and HTML snippet into a 'Widget'. Used+ -- primarily for wrapping up error messages for better display.+ --+ -- @since 1.4.30+ defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetT site IO ()+ defaultMessageWidget title body = do+ setTitle title+ toWidget+ [hamlet|+ <h1>#{title}+ ^{body}+ |] {-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-} -- | Default implementation of 'makeLogger'. Sends to stdout and@@ -636,11 +649,7 @@ provideRep $ defaultLayout $ do r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r- setTitle "Not Found"- toWidget [hamlet|- <h1>Not Found- <p>#{path'}- |]+ defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|] provideRep $ return $ object ["message" .= ("Not Found" :: Text)] -- For API requests.@@ -648,12 +657,9 @@ -- if you specify an authRoute the user will be redirected there and -- this page will not be shown. 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.- |]+ provideRep $ defaultLayout $ defaultMessageWidget+ "Not logged in"+ [hamlet|<p style="display:none;">Set the authRoute and the user will be redirected there.|] provideRep $ do -- 401 *MUST* include a WWW-Authenticate header@@ -670,20 +676,16 @@ return $ object $ ("message" .= ("Not logged in"::Text)):content defaultErrorHandler (PermissionDenied msg) = selectRep $ do- provideRep $ defaultLayout $ do- setTitle "Permission Denied"- toWidget [hamlet|- <h1>Permission denied- <p>#{msg}- |]+ provideRep $ defaultLayout $ defaultMessageWidget+ "Permission Denied"+ [hamlet|<p>#{msg}|] provideRep $ return $ object ["message" .= ("Permission Denied. " <> msg)] defaultErrorHandler (InvalidArgs ia) = selectRep $ do- provideRep $ defaultLayout $ do- setTitle "Invalid Arguments"- toWidget [hamlet|- <h1>Invalid Arguments+ provideRep $ defaultLayout $ defaultMessageWidget+ "Invalid Arguments"+ [hamlet| <ul> $forall msg <- ia <li>#{msg}@@ -692,20 +694,14 @@ 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}- |]+ provideRep $ defaultLayout $ defaultMessageWidget+ "Internal Server Error"+ [hamlet|<pre>#{e}|] provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e] 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- |]+ provideRep $ defaultLayout $ defaultMessageWidget+ "Method Not Supported"+ [hamlet|<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)
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.4.29+version: 1.4.30 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>