Merge remote-tracking branch 'origin/master' into rio

yesod-core/ChangeLog.md

@@ -4,6 +4,10 @@
 
 * Switch over to using `rio`
 
+## 1.6.13
+
+* Introduce `maxContentLengthIO`. [issue #1588](https://github.com/yesodweb/yesod/issues/1588) and [PR #1589](https://github.com/yesodweb/yesod/pull/1589)
+
 ## 1.6.12
 
 * Use at most one valid session cookie per request [#1581](https://github.com/yesodweb/yesod/pull/1581)

yesod-core/src/Yesod/Core/Class/Yesod.hs

@@ -189,6 +189,7 @@ class RenderRoute site => Yesod site where
     addStaticContent _ _ _ = return Nothing
 
     -- | Maximum allowed length of the request body, in bytes.
+    -- This method may be ignored if 'maximumContentLengthIO' is overridden.
     --
     -- If @Nothing@, no maximum is applied.
     --
@@ -196,6 +197,18 @@ class RenderRoute site => Yesod site where
     maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
     maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes
 
+    -- | Maximum allowed length of the request body, in bytes. This is similar
+    -- to 'maximumContentLength', but the result lives in @IO@. This allows
+    -- you to dynamically change the maximum file size based on some external
+    -- source like a database or an @IORef@.
+    --
+    -- The default implementation uses 'maximumContentLength'. Future version of yesod will
+    -- remove 'maximumContentLength' and use this method exclusively.
+    --
+    -- @since 1.6.13
+    maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
+    maximumContentLengthIO a b = pure $ maximumContentLength a b
+
     -- | Get the 'LogFunc' from the foundation type.
     --
     -- If this function returns a @Nothing@ (the default), the Yesod

yesod-core/src/Yesod/Core/Internal/Request.hs

@@ -71,7 +71,7 @@ tooLargeResponse maxLen bodyLen = W.responseLBS
         , (LS8.pack (show maxLen))
         , " bytes; your request body was "
         , (LS8.pack (show bodyLen))
-        , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` function on the Yesod typeclass."
+        , " bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass."
         ])
 
 parseWaiRequest :: W.Request

yesod-core/src/Yesod/Core/Internal/Run.hs

@@ -297,42 +297,44 @@ yesodRunner :: (ToTypedContent res, Yesod site)
             -> YesodRunnerEnv site
             -> Maybe (Route site)
             -> Application
-yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
-  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse (tooLargeResponse maxLen len)
+  mmaxLen <- maximumContentLengthIO yreSite route
-  | otherwise = do
+  case (mmaxLen, requestBodyLength req) of
-    let dontSaveSession _ = return []
+    (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)
-    (session, saveSession) <- liftIO $
+    _ -> do
-        maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
+      let dontSaveSession _ = return []
-    maxExpires <- yreGetMaxExpires
+      (session, saveSession) <- liftIO $
-    let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
+          maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
-    let yreq =
+      maxExpires <- yreGetMaxExpires
-            case mkYesodReq of
+      let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
-                Left yreq' -> yreq'
+      let yreq =
-                Right needGen -> needGen yreGen
+              case mkYesodReq of
-    let ra = resolveApproot yreSite req
+                  Left yreq' -> yreq'
-    let -- We set up two environments: the first one has a "safe" error handler
+                  Right needGen -> needGen yreGen
-        -- which will never throw an exception. The second one uses the
+      let ra = resolveApproot yreSite req
-        -- user-provided errorHandler function. If that errorHandler function
+      let -- We set up two environments: the first one has a "safe" error handler
-        -- errors out, it will use the safeEh below to recover.
+          -- which will never throw an exception. The second one uses the
-        rheSafe = RunHandlerEnv
+          -- user-provided errorHandler function. If that errorHandler function
-            { rheRender = yesodRender yreSite ra
+          -- errors out, it will use the safeEh below to recover.
-            , rheRoute = route
+          rheSafe = RunHandlerEnv
-            , rheRouteToMaster = id
+              { rheRender = yesodRender yreSite ra
-            , rheChild = yreSite
+              , rheRoute = route
-            , rheSite = yreSite
+              , rheRouteToMaster = id
-            , rheUpload = fileUpload yreSite
+              , rheChild = yreSite
-            , rheLogFunc = yreLogFunc
+              , rheSite = yreSite
-            , rheOnError = safeEh yreLogFunc
+              , rheUpload = fileUpload yreSite
-            , rheMaxExpires = maxExpires
+              , rheLogFunc = yreLogFunc
-            }
+              , rheOnError = safeEh yreLogFunc
-        rhe = rheSafe
+              , rheMaxExpires = maxExpires
-            { rheOnError = runHandler rheSafe . errorHandler
+              }
-            }
+          rhe = rheSafe
+              { rheOnError = runHandler rheSafe . errorHandler
+              }
 
-    yesodWithInternalState yreSite route $ \is -> do
+      yesodWithInternalState yreSite route $ \is -> do
-        yreq' <- yreq
+          yreq' <- yreq
-        yar <- runInternalState (runHandler rhe handler yreq') is
+          yar <- runInternalState (runHandler rhe handler yreq') is
-        yarToResponse yar saveSession yreq' req is sendResponse
+          yarToResponse yar saveSession yreq' req is sendResponse
   where
     mmaxLen = maximumContentLength yreSite route
     handler = yesodMiddleware handler'

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.12
+version:         1.6.13
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

yesod-persistent/Yesod/Persist/Core.hs

@@ -41,6 +41,15 @@ type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerFor site)
 
 class Monad (YesodDB site) => YesodPersist site where
     type YesodPersistBackend site
+    -- | Allows you to execute database actions within Yesod Handlers. For databases that support it, code inside the action will run as an atomic transaction.
+    --
+    --
+    -- ==== __Example Usage__
+    --
+    -- > userId <- runDB $ do
+    -- >   userId <- insert $ User "username" "email@example.com"
+    -- >   insert_ $ UserPreferences userId True
+    -- >   pure userId
     runDB :: YesodDB site a -> HandlerFor site a
 
 -- | Helper for creating 'runDB'.