packages feed

yesod-core 1.4.30 → 1.4.31

raw patch · 5 files changed

+34/−6 lines, 5 filesdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

+ Yesod.Core.Json: parseCheckJsonBody :: (MonadHandler m, FromJSON a) => m (Result a)
+ Yesod.Core.Json: requireCheckJsonBody :: (MonadHandler m, FromJSON a) => m a
- 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 }) }
+ Yesod.Core: class RenderRoute site => Yesod site where approot = ApprootRelative errorHandler = defaultErrorHandler defaultLayout w = do { p <- widgetToPageContent w; msgs <- getMessages; withUrlRenderer (\ _render_a1hSZ -> do { id ((preEscapedText . pack) "<!DOCTYPE html>\n\ \<html><head><title>"); id (toHtml (pageTitle p)); id ((preEscapedText . pack) "</title>"); asHtmlUrl (pageHead p) _render_a1hSZ; id ((preEscapedText . pack) "</head><body>"); mapM_ (\ (status_a1hT0, msg_a1hT1) -> do { id ((preEscapedText . pack) "<p class=\"message "); id (toHtml status_a1hT0); id ((preEscapedText . pack) "\">"); id (toHtml msg_a1hT1); id ((preEscapedText . pack) "</p>") }) msgs; asHtmlUrl (pageBody p) _render_a1hSZ; 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_a1hTD -> do { id ((preEscapedText . pack) "<h1>"); id (toHtml title); id ((preEscapedText . pack) "</h1>\n"); asHtmlUrl body _render_a1hTD }) }

Files

ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.4.31++* Add `parseCheckJsonBody` and `requireCheckJsonBody`+ ## 1.4.30  * Add `defaultMessageWidget`
Yesod/Core.hs view
@@ -18,7 +18,7 @@     , Approot (..)     , FileUpload (..)     , ErrorResponse (..)-      -- * Utitlities+      -- * Utilities     , maybeAuthorized     , widgetToPageContent       -- * Defaults
Yesod/Core/Json.hs view
@@ -13,8 +13,10 @@        -- * Convert to a JSON value     , parseJsonBody+    , parseCheckJsonBody     , parseJsonBody_     , requireJsonBody+    , requireCheckJsonBody        -- * Produce JSON values     , J.Value (..)@@ -33,7 +35,7 @@     , acceptsJson     ) where -import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)+import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader) import Control.Monad.Trans.Writer (Writer) import Data.Monoid (Endo) import Yesod.Core.Content (TypedContent)@@ -121,6 +123,15 @@         Left e -> J.Error $ show e         Right value -> J.fromJSON value +-- | Same as 'parseJsonBody', but ensures that the mime type indicates+-- JSON content.+parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseCheckJsonBody = do+    mct <- lookupHeader "content-type"+    case fmap (B8.takeWhile (/= ';')) mct of+        Just "application/json" -> parseJsonBody+        _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct+ -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a@@ -132,6 +143,15 @@ requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a requireJsonBody = do     ra <- parseJsonBody+    case ra of+        J.Error s -> invalidArgs [pack s]+        J.Success a -> return a++-- | Same as 'requireJsonBody', but ensures that the mime type+-- indicates JSON content.+requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireCheckJsonBody = do+    ra <- parseCheckJsonBody     case ra of         J.Error s -> invalidArgs [pack s]         J.Success a -> return a
Yesod/Routes/TH/RenderRoute.hs view
@@ -46,7 +46,9 @@      mkRouteCon (ResourceParent name _check pieces children) = do         (cons, decs) <- mkRouteCons children-#if MIN_VERSION_template_haskell(2,11,0)+#if MIN_VERSION_template_haskell(2,12,0)+        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])+#elif MIN_VERSION_template_haskell(2,11,0)         dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq] #else         let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]@@ -153,7 +155,9 @@ mkRenderRouteInstance' cxt typ ress = do     cls <- mkRenderRouteClauses ress     (cons, decs) <- mkRouteCons ress-#if MIN_VERSION_template_haskell(2,11,0)+#if MIN_VERSION_template_haskell(2,12,0)+    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes)+#elif MIN_VERSION_template_haskell(2,11,0)     did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes #else     let did = DataInstD [] ''Route [typ] cons clazzes
yesod-core.cabal view
@@ -1,5 +1,5 @@ name:            yesod-core-version:         1.4.30+version:         1.4.31 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -47,7 +47,7 @@                    , case-insensitive      >= 0.2                    , parsec                >= 2        && < 3.2                    , directory             >= 1-                   , vector                >= 0.9      && < 0.12+                   , vector                >= 0.9      && < 0.13                    , aeson                 >= 0.5                    , fast-logger           >= 2.2                    , wai-logger            >= 0.2