Merge pull request #1589 from geekingfrog/maximumContentLengthIO

maximumContentLengthIO

yesod-core/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-core
 
+## 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

@@ -195,6 +195,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.
     --
@@ -202,6 +203,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
+
     -- | Creates a @Logger@ to use for log messages.
     --
     -- Note that a common technique (endorsed by the scaffolding) is to create

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

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