Merge pull request #1083 from DaveCTurner/issue-1083

Thread leak when calling neverExpires

yesod-core/Yesod/Core/Dispatch.hs

@@ -59,6 +59,8 @@ import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
 import Safe (readMay)
 import System.Environment (getEnvironment)
+import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
+import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
 
 import Network.Wai.Middleware.Autohead
 import Network.Wai.Middleware.AcceptOverride
@@ -82,11 +84,13 @@ toWaiAppPlain site = do
     logger <- makeLogger site
     sb <- makeSessionBackend site
     gen <- MWC.createSystemRandom
+    getMaxExpires <- getGetMaxExpires
     return $ toWaiAppYre $ YesodRunnerEnv
             { yreLogger = logger
             , yreSite = site
             , yreSessionBackend = sb
             , yreGen = gen
+            , yreGetMaxExpires = getMaxExpires
             }
 
 toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application
@@ -139,11 +143,13 @@ toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
 toWaiAppLogger logger site = do
     sb <- makeSessionBackend site
     gen <- MWC.createSystemRandom
+    getMaxExpires <- getGetMaxExpires
     let yre = YesodRunnerEnv
                 { yreLogger = logger
                 , yreSite = site
                 , yreSessionBackend = sb
                 , yreGen = gen
+                , yreGetMaxExpires = getMaxExpires
                 }
     messageLoggerSource
         site
@@ -230,3 +236,9 @@ warpEnv site = do
             case readMay portS of
                 Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS
                 Just port -> warp port site
+
+getGetMaxExpires :: IO (IO Text)
+getGetMaxExpires = mkAutoUpdate defaultUpdateSettings
+  { updateAction = getCurrentMaxExpiresRFC1123
+  , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day
+  }

yesod-core/Yesod/Core/Handler.hs

@@ -733,7 +733,7 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
 -- is never (realistically) expired.
 neverExpires :: MonadHandler m => m ()
 neverExpires = do
-    askHandlerEnv >>= liftIO . rheGetMaxExpires >>= setHeader "Expires"
+    setHeader "Expires" . rheMaxExpires =<< askHandlerEnv
     cacheSeconds oneYear
   where
     oneYear :: Int

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

@@ -34,7 +34,6 @@ import qualified Data.Text                    as T
 import           Data.Text.Encoding           (encodeUtf8)
 import           Data.Text.Encoding           (decodeUtf8With)
 import           Data.Text.Encoding.Error     (lenientDecode)
-import           Data.Time                    (getCurrentTime, addUTCTime)
 import           Language.Haskell.TH.Syntax   (Loc, qLocation)
 import qualified Network.HTTP.Types           as H
 import           Network.Wai
@@ -48,11 +47,9 @@ import           Yesod.Core.Class.Yesod
 import           Yesod.Core.Types
 import           Yesod.Core.Internal.Request  (parseWaiRequest,
                                                tooLargeResponse)
-import           Yesod.Core.Internal.Util     (formatRFC1123)
+import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)
 import           Yesod.Routes.Class           (Route, renderRoute)
 import           Control.DeepSeq              (($!!))
-import           Control.Monad                (liftM)
-import           Control.AutoUpdate           (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
 
 returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap
 #if MIN_VERSION_bytestring(0, 10, 0)
@@ -199,7 +196,7 @@ runFakeHandler :: (Yesod site, MonadIO m) =>
                -> m (Either ErrorResponse a)
 runFakeHandler fakeSessionMap logger site handler = liftIO $ do
   ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
-  getMaxExpires <- getGetMaxExpires
+  maxExpires <- getCurrentMaxExpiresRFC1123
   let handler' = do liftIO . I.writeIORef ret . Right =<< handler
                     return ()
   let yapp = runHandler
@@ -210,7 +207,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
             , rheUpload = fileUpload site
             , rheLog = messageLoggerSource site $ logger site
             , rheOnError = errHandler
-            , rheGetMaxExpires = getMaxExpires
+            , rheMaxExpires = maxExpires
             }
         handler'
       errHandler err req = do
@@ -261,7 +258,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
     let dontSaveSession _ = return []
     (session, saveSession) <- liftIO $ do
         maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
-    getMaxExpires <- getGetMaxExpires
+    maxExpires <- yreGetMaxExpires
     let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
     let yreq =
             case mkYesodReq of
@@ -280,7 +277,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
             , rheUpload = fileUpload yreSite
             , rheLog = log'
             , rheOnError = safeEh log'
-            , rheGetMaxExpires = getMaxExpires
+            , rheMaxExpires = maxExpires
             }
         rhe = rheSafe
             { rheOnError = runHandler rheSafe . errorHandler
@@ -294,12 +291,6 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
     mmaxLen = maximumContentLength yreSite route
     handler = yesodMiddleware handler'
 
-getGetMaxExpires :: MonadIO m => m (IO Text)
-getGetMaxExpires = liftIO $ mkAutoUpdate defaultUpdateSettings
-  { updateAction = liftM (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime
-  , updateFreq = 60 * 60 * 1000000 -- Update once per hour
-  }
-
 yesodRender :: Yesod y
             => y
             -> ResolvedApproot

yesod-core/Yesod/Core/Internal/Util.hs

@@ -5,13 +5,16 @@ module Yesod.Core.Internal.Util
     , formatW3
     , formatRFC1123
     , formatRFC822
+    , getCurrentMaxExpiresRFC1123
     ) where
 
 import           Data.Int       (Int64)
 import           Data.Serialize (Get, Put, Serialize (..))
 import qualified Data.Text      as T
 import           Data.Time      (Day (ModifiedJulianDay, toModifiedJulianDay),
-                                 DiffTime, UTCTime (..), formatTime)
+                                 DiffTime, UTCTime (..), formatTime,
+                                 getCurrentTime, addUTCTime)
+import           Control.Monad  (liftM)
 
 #if MIN_VERSION_time(1,5,0)
 import           Data.Time      (defaultTimeLocale)
@@ -50,3 +53,9 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
 -- | Format as per RFC 822.
 formatRFC822 :: UTCTime -> T.Text
 formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
+
+{- | Get the time 365 days from now in RFC 1123 format. For use as an expiry
+date on a resource that never expires. See RFC 2616 section 14.21 for details.
+-}
+getCurrentMaxExpiresRFC1123 :: IO T.Text
+getCurrentMaxExpiresRFC1123 = liftM (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime

yesod-core/Yesod/Core/Types.hs

@@ -183,10 +183,10 @@ data RunHandlerEnv site = RunHandlerEnv
     , rheUpload   :: !(RequestBodyLength -> FileUpload)
     , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
     , rheOnError  :: !(ErrorResponse -> YesodApp)
-    , rheGetMaxExpires :: IO Text
       -- ^ How to respond when an error is thrown internally.
       --
       -- Since 1.2.0
+    , rheMaxExpires :: !Text
     }
 
 data HandlerData site parentRoute = HandlerData
@@ -202,6 +202,7 @@ data YesodRunnerEnv site = YesodRunnerEnv
     , yreSite           :: !site
     , yreSessionBackend :: !(Maybe SessionBackend)
     , yreGen            :: !MWC.GenIO
+    , yreGetMaxExpires  :: IO Text
     }
 
 data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv