diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.16.1 + +* bugfix neverExpires leaked threads + ## 1.4.15 * mkYesod avoids using reify when it isn't necessary. This avoids needing to define the site type below the call to mkYesod. diff --git a/Yesod/Core/Class/Handler.hs b/Yesod/Core/Class/Handler.hs --- a/Yesod/Core/Class/Handler.hs +++ b/Yesod/Core/Class/Handler.hs @@ -11,12 +11,13 @@ ) where import Yesod.Core.Types -import Data.Monoid (mempty) import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase) import Control.Monad.Trans.Class (lift) -import Data.Monoid (Monoid) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (Monoid, mempty) +#endif import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Trans.Identity ( IdentityT) diff --git a/Yesod/Core/Content.hs b/Yesod/Core/Content.hs --- a/Yesod/Core/Content.hs +++ b/Yesod/Core/Content.hs @@ -56,8 +56,9 @@ import Control.Monad (liftM) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) - +#endif import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput) @@ -76,6 +77,7 @@ import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript) +import Data.Word8 (_semicolon, _slash) -- | Zero-length enumerator. emptyContent :: Content @@ -224,18 +226,15 @@ -- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- character encoding for HTML data. This function would return \"text/html\". simpleContentType :: ContentType -> ContentType -simpleContentType = fst . B.breakByte 59 -- 59 == ; +simpleContentType = fst . B.break (== _semicolon) -- Give just the media types as a pair. -- For example, \"text/html; charset=utf-8\" returns ("text", "html") contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString) -contentTypeTypes ct = (main, fst $ B.breakByte semicolon (tailEmpty sub)) +contentTypeTypes ct = (main, fst $ B.break (== _semicolon) (tailEmpty sub)) where tailEmpty x = if B.null x then "" else B.tail x - (main, sub) = B.breakByte slash ct - slash = 47 - semicolon = 59 - + (main, sub) = B.break (== _slash) ct instance HasContentType a => HasContentType (DontFullyEvaluate a) where getContentType = getContentType . liftM unDontFullyEvaluate diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs --- a/Yesod/Core/Dispatch.hs +++ b/Yesod/Core/Dispatch.hs @@ -45,7 +45,9 @@ import Data.ByteString.Lazy.Char8 () import Data.Text (Text) +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mappend) +#endif import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Blaze.ByteString.Builder @@ -57,6 +59,8 @@ 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 @@ -80,11 +84,13 @@ 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 @@ -137,11 +143,13 @@ 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 @@ -228,3 +236,9 @@ 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 + } diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -178,7 +178,12 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, mkFileInfoLBS, mkFileInfoSource) -import Control.Applicative ((<$>), (<|>)) + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +import Data.Monoid (mempty, mappend) +#endif +import Control.Applicative ((<|>)) import Control.Exception (evaluate, SomeException) import Control.Exception.Lifted (handle) @@ -208,7 +213,7 @@ import Control.Arrow ((***)) import qualified Data.ByteString.Char8 as S8 -import Data.Monoid (Endo (..), mappend, mempty) +import Data.Monoid (Endo (..)) import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) @@ -728,7 +733,7 @@ -- is never (realistically) expired. neverExpires :: MonadHandler m => m () neverExpires = do - askHandlerEnv >>= liftIO . rheGetMaxExpires >>= setHeader "Expires" + setHeader "Expires" . rheMaxExpires =<< askHandlerEnv cacheSeconds oneYear where oneYear :: Int diff --git a/Yesod/Core/Internal/LiteApp.hs b/Yesod/Core/Internal/LiteApp.hs --- a/Yesod/Core/Internal/LiteApp.hs +++ b/Yesod/Core/Internal/LiteApp.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-} module Yesod.Core.Internal.LiteApp where -import Yesod.Routes.Class +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid +#endif +import Yesod.Routes.Class import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Types diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs --- a/Yesod/Core/Internal/Run.hs +++ b/Yesod/Core/Internal/Run.hs @@ -7,9 +7,12 @@ {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Internal.Run where + +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mempty) +#endif import Yesod.Core.Internal.Response import Blaze.ByteString.Builder (toByteString) -import Control.Applicative ((<$>)) import Control.Exception (fromException, evaluate) import qualified Control.Exception as E import Control.Exception.Lifted (catch) @@ -25,13 +28,12 @@ import qualified Data.Map as Map import Data.Maybe (isJust) import Data.Maybe (fromMaybe) -import Data.Monoid (appEndo, mempty) +import Data.Monoid (appEndo) import Data.Text (Text) 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 @@ -40,17 +42,14 @@ import Prelude hiding (catch) #endif import System.Log.FastLogger (LogStr, toLogStr) -import System.Random (newStdGen) import Yesod.Core.Content 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 (($!!), NFData) -import Control.Monad (liftM) -import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) +import Control.DeepSeq (($!!)) returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap #if MIN_VERSION_bytestring(0, 10, 0) @@ -197,7 +196,7 @@ -> 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 @@ -208,7 +207,7 @@ , rheUpload = fileUpload site , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler - , rheGetMaxExpires = getMaxExpires + , rheMaxExpires = maxExpires } handler' errHandler err req = do @@ -259,11 +258,11 @@ 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 - Left yreq -> yreq + Left yreq' -> yreq' Right needGen -> needGen yreGen let ra = resolveApproot yreSite req let log' = messageLoggerSource yreSite yreLogger @@ -278,7 +277,7 @@ , rheUpload = fileUpload yreSite , rheLog = log' , rheOnError = safeEh log' - , rheGetMaxExpires = getMaxExpires + , rheMaxExpires = maxExpires } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler @@ -291,12 +290,6 @@ where 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 diff --git a/Yesod/Core/Internal/Util.hs b/Yesod/Core/Internal/Util.hs --- a/Yesod/Core/Internal/Util.hs +++ b/Yesod/Core/Internal/Util.hs @@ -5,13 +5,16 @@ , 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 @@ -- | 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 diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs --- a/Yesod/Core/Types.hs +++ b/Yesod/Core/Types.hs @@ -10,8 +10,11 @@ import qualified Blaze.ByteString.Builder as BBuilder import qualified Blaze.ByteString.Builder.Char.Utf8 +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative (..)) import Control.Applicative ((<$>)) +import Data.Monoid (Monoid (..)) +#endif import Control.Arrow (first) import Control.Exception (Exception) import Control.Monad (liftM, ap) @@ -29,8 +32,7 @@ import Data.IORef (IORef) import Data.Map (Map, unionWith) import qualified Data.Map as Map -import Data.Monoid (Endo (..), Last (..), - Monoid (..)) +import Data.Monoid (Endo (..), Last (..)) import Data.Serialize (Serialize (..), putByteString) import Data.String (IsString (fromString)) @@ -181,10 +183,10 @@ , 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 @@ -200,6 +202,7 @@ , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) , yreGen :: !MWC.GenIO + , yreGetMaxExpires :: IO Text } data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv diff --git a/Yesod/Core/Unsafe.hs b/Yesod/Core/Unsafe.hs --- a/Yesod/Core/Unsafe.hs +++ b/Yesod/Core/Unsafe.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | This is designed to be used as -- -- > qualified import Yesod.Core.Unsafe as Unsafe @@ -9,7 +10,9 @@ import Yesod.Core.Types import Yesod.Core.Class.Yesod +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty, mappend) +#endif import Control.Monad.IO.Class (MonadIO) -- | designed to be used as diff --git a/Yesod/Routes/TH/RenderRoute.hs b/Yesod/Routes/TH/RenderRoute.hs --- a/Yesod/Routes/TH/RenderRoute.hs +++ b/Yesod/Routes/TH/RenderRoute.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, CPP #-} module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance @@ -14,7 +14,9 @@ import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat) +#endif -- | Generate the constructors of a route data type. mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec]) diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.15 +version: 1.4.15.1 license: MIT license-file: LICENSE author: Michael Snoyman