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 @@ -41,7 +41,7 @@ instance MonadResourceBase m => MonadHandler (HandlerT site m) where type HandlerSite (HandlerT site m) = site liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent -{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-} +{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-} instance MonadResourceBase m => MonadHandler (WidgetT site m) where type HandlerSite (WidgetT site m) = site diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs --- a/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module Yesod.Core.Class.Yesod where import Control.Monad.Logger (logErrorS) @@ -39,10 +40,16 @@ import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import System.IO (stdout) +#if MIN_VERSION_fast_logger(2, 0, 0) +import Network.Wai.Logger (ZonedDate, clockDateCacher) +import System.Log.FastLogger +import qualified GHC.IO.FD +#else +import System.Log.FastLogger.Date (ZonedDate) import System.Log.FastLogger (LogStr (..), Logger, loggerDate, loggerPutStr, mkLogger) -import System.Log.FastLogger.Date (ZonedDate) +#endif import Text.Blaze (customAttribute, textTag, toValue, (!)) import Text.Blaze (preEscapedToMarkup) @@ -209,7 +216,14 @@ -- -- Default: Sends to stdout and automatically flushes on each write. makeLogger :: site -> IO Logger +#if MIN_VERSION_fast_logger(2, 0, 0) + makeLogger _ = do + loggerSet <- newLoggerSet defaultBufSize GHC.IO.FD.stdout + (getter, _) <- clockDateCacher + return $! Logger loggerSet getter +#else makeLogger _ = mkLogger True stdout +#endif -- | Send a message to the @Logger@ provided by @getLogger@. -- @@ -523,11 +537,35 @@ Nothing -> Nothing Just j -> Just $ jelper j +#if MIN_VERSION_fast_logger(2, 0, 0) formatLogMessage :: IO ZonedDate -> Loc -> LogSource -> LogLevel -> LogStr -- ^ message + -> IO LogStr +formatLogMessage getdate loc src level msg = do + now <- getdate + return $ + toLogStr now `mappend` + " [" `mappend` + (case level of + LevelOther t -> toLogStr t + _ -> toLogStr $ drop 5 $ show level) `mappend` + (if T.null src + then mempty + else "#" `mappend` toLogStr src) `mappend` + "] " `mappend` + msg `mappend` + " @(" `mappend` + toLogStr (fileLocationToString loc) `mappend` + ")\n" +#else +formatLogMessage :: IO ZonedDate + -> Loc + -> LogSource + -> LogLevel + -> LogStr -- ^ message -> IO [LogStr] formatLogMessage getdate loc src level msg = do now <- getdate @@ -548,7 +586,7 @@ , LS $ fileLocationToString loc , LB ")\n" ] - +#endif -- | Customize the cookies used by the session backend. You may -- use this function on your definition of 'makeSessionBackend'. diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs --- a/Yesod/Core/Dispatch.hs +++ b/Yesod/Core/Dispatch.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} module Yesod.Core.Dispatch ( -- * Quasi-quoted routing parseRoutes @@ -146,6 +147,7 @@ warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings Network.Wai.Handler.Warp.defaultSettings { Network.Wai.Handler.Warp.settingsPort = port + {- FIXME , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat [ "Warp/" , Network.Wai.Handler.Warp.warpVersion @@ -153,6 +155,7 @@ , showVersion Paths_yesod_core.version , " (core)" ] + -} } -- | A default set of middlewares. @@ -161,7 +164,11 @@ mkDefaultMiddlewares :: Logger -> IO W.Middleware mkDefaultMiddlewares logger = do logWare <- mkRequestLogger def +#if MIN_VERSION_fast_logger(2, 0, 0) + { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger +#else { destination = Logger logger +#endif , outputFormat = Apache FromSocket } return $ logWare diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} @@ -194,6 +195,9 @@ import Blaze.ByteString.Builder (Builder) import Safe (headMay) import Data.CaseInsensitive (CI) +#if MIN_VERSION_wai(2, 0, 0) +import qualified System.PosixCompat.Files as PC +#endif get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState @@ -229,11 +233,19 @@ Just rbc -> return rbc Nothing -> do rr <- waiRequest +#if MIN_VERSION_wai(2, 0, 0) + rbc <- liftIO $ rbHelper upload rr +#else rbc <- liftResourceT $ rbHelper upload rr +#endif put x { ghsRBC = Just rbc } return rbc +#if MIN_VERSION_wai(2, 0, 0) +rbHelper :: FileUpload -> W.Request -> IO RequestBodyContents +#else rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents +#endif rbHelper upload = case upload of FileUploadMemory s -> rbHelper' s mkFileInfoLBS @@ -243,7 +255,11 @@ rbHelper' :: NWP.BackEnd x -> (Text -> Text -> x -> FileInfo) -> W.Request +#if MIN_VERSION_wai(2, 0, 0) + -> IO ([(Text, Text)], [(Text, FileInfo)]) +#else -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)]) +#endif rbHelper' backend mkFI req = (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req) where @@ -486,8 +502,17 @@ -> Integer -- ^ offset -> Integer -- ^ count -> m a -sendFilePart ct fp off count = +sendFilePart ct fp off count = do +#if MIN_VERSION_wai(2, 0, 0) + fs <- liftIO $ PC.getFileStatus fp + handlerError $ HCSendFile ct fp $ Just W.FilePart + { W.filePartOffset = off + , W.filePartByteCount = count + , W.filePartFileSize = fromIntegral $ PC.fileSize fs + } +#else handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count +#endif -- | Bypass remaining handler code and output the given content with a 200 -- status code. @@ -697,7 +722,7 @@ x <- get let i' = ghsIdent x + 1 put x { ghsIdent = i' } - return $ T.pack $ 'h' : show i' + return $ T.pack $ "hident" ++ show i' -- | Redirect to a POST resource. -- @@ -916,7 +941,7 @@ ]) reps -- match on the type for sub-type wildcards. - -- If the accept is text/* it should match a provided text/html + -- If the accept is text/ * it should match a provided text/html mainTypeMap = Map.fromList $ reverse $ map (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps @@ -972,7 +997,13 @@ rawRequestBody :: MonadHandler m => Source m S.ByteString rawRequestBody = do req <- lift waiRequest - transPipe liftResourceT $ W.requestBody req + transPipe +#if MIN_VERSION_wai(2, 0, 0) + liftIO +#else + liftResourceT +#endif + (W.requestBody req) -- | Stream the data from the file. Since Yesod 1.2, this has been generalized -- to work in any @MonadResource@. diff --git a/Yesod/Core/Internal/Response.hs b/Yesod/Core/Internal/Response.hs --- a/Yesod/Core/Internal/Response.hs +++ b/Yesod/Core/Internal/Response.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} @@ -12,6 +13,13 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Network.Wai +#if MIN_VERSION_wai(2, 0, 0) +import Data.Conduit (transPipe) +import Control.Monad.Trans.Resource (runInternalState, getInternalState, runResourceT, InternalState, closeInternalState) +import Control.Monad.Trans.Class (lift) +import Network.Wai.Internal +import Control.Exception (finally) +#endif import Prelude hiding (catch) import Web.Cookie (renderSetCookie) import Yesod.Core.Content @@ -26,13 +34,30 @@ import Yesod.Core.Internal.Request (tokenKey) import Data.Text.Encoding (encodeUtf8) -yarToResponse :: Monad m - => YesodResponse - -> (SessionMap -> m [Header]) -- ^ save session +yarToResponse :: YesodResponse + -> (SessionMap -> IO [Header]) -- ^ save session -> YesodRequest - -> m Response -yarToResponse (YRWai a) _ _ = return a -yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do + -> Request +#if MIN_VERSION_wai(2, 0, 0) + -> InternalState +#endif + -> IO Response +#if MIN_VERSION_wai(2, 0, 0) +yarToResponse (YRWai a) _ _ _ is = + case a of + ResponseSource s hs w -> return $ ResponseSource s hs $ \f -> + w f `finally` closeInternalState is + _ -> do + closeInternalState is + return a +#else +yarToResponse (YRWai a) _ _ _ = return a +#endif +yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req +#if MIN_VERSION_wai(2, 0, 0) + is +#endif + = do extraHeaders <- do let nsToken = maybe newSess @@ -43,6 +68,21 @@ let finalHeaders = extraHeaders ++ map headerToPair hs finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders + +#if MIN_VERSION_wai(2, 0, 0) + let go (ContentBuilder b mlen) = do + let hs' = maybe finalHeaders finalHeaders' mlen + closeInternalState is + return $ ResponseBuilder s hs' b + go (ContentFile fp p) = do + closeInternalState is + return $ ResponseFile s finalHeaders fp p + go (ContentSource body) = return $ ResponseSource s finalHeaders $ \f -> + f (transPipe (flip runInternalState is) body) `finally` + closeInternalState is + go (ContentDontEvaluate c') = go c' + go c +#else let go (ContentBuilder b mlen) = let hs' = maybe finalHeaders finalHeaders' mlen in ResponseBuilder s hs' b @@ -50,6 +90,7 @@ go (ContentSource body) = ResponseSource s finalHeaders body go (ContentDontEvaluate c') = go c' return $ go c +#endif where s | s' == defaultStatus = H.status200 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} @@ -9,13 +10,13 @@ import Yesod.Core.Internal.Response import Blaze.ByteString.Builder (toByteString) import Control.Applicative ((<$>)) -import Control.Exception (fromException) +import Control.Exception (fromException, bracketOnError) import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc) -import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState) +import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.IORef as I @@ -31,8 +32,13 @@ import Language.Haskell.TH.Syntax (Loc, qLocation) import qualified Network.HTTP.Types as H import Network.Wai +#if MIN_VERSION_wai(2, 0, 0) +import Network.Wai.Internal +#endif import Prelude hiding (catch) +#if !MIN_VERSION_fast_logger(2, 0, 0) import System.Log.FastLogger (Logger) +#endif import System.Log.FastLogger (LogStr, toLogStr) import System.Random (newStdGen) import Yesod.Core.Content @@ -179,14 +185,17 @@ typePlain (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) (reqSession req) - fakeWaiRequest = - Request + fakeWaiRequest = Request { requestMethod = "POST" , httpVersion = H.http11 , rawPathInfo = "/runFakeHandler/pathInfo" , rawQueryString = "" +#if MIN_VERSION_wai(2, 0, 0) + , requestHeaderHost = Nothing +#else , serverName = "runFakeHandler-serverName" , serverPort = 80 +#endif , requestHeaders = [] , isSecure = False , remoteHost = error "runFakeHandler-remoteHost" @@ -243,8 +252,14 @@ rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler } +#if MIN_VERSION_wai(2, 0, 0) + bracketOnError createInternalState closeInternalState $ \is -> do + yar <- runInternalState (runHandler rhe handler yreq) is + liftIO $ yarToResponse yar saveSession yreq req is +#else yar <- runHandler rhe handler yreq - liftIO $ yarToResponse yar saveSession yreq + liftIO $ yarToResponse yar saveSession yreq req +#endif where mmaxLen = maximumContentLength yreSite route handler = yesodMiddleware handler' diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs --- a/Yesod/Core/Types.hs +++ b/Yesod/Core/Types.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} module Yesod.Core.Types where import qualified Blaze.ByteString.Builder as BBuilder @@ -46,7 +47,12 @@ RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP +#if MIN_VERSION_fast_logger(2, 0, 0) +import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr) +import Network.Wai.Logger (DateCacheGetter) +#else import System.Log.FastLogger (LogStr, Logger, toLogStr) +#endif import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) @@ -445,3 +451,13 @@ renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) instance ParseRoute WaiSubsite where parseRoute (x, y) = Just $ WaiSubsiteRoute x y + +#if MIN_VERSION_fast_logger(2, 0, 0) +data Logger = Logger + { loggerSet :: !LoggerSet + , loggerDate :: !DateCacheGetter + } + +loggerPutStr :: Logger -> LogStr -> IO () +loggerPutStr (Logger ls _) = pushLogStr ls +#endif diff --git a/test/YesodCoreTest/Auth.hs b/test/YesodCoreTest/Auth.hs --- a/test/YesodCoreTest/Auth.hs +++ b/test/YesodCoreTest/Auth.hs @@ -8,6 +8,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T import Data.List (isSuffixOf) +import qualified Network.HTTP.Types as H data App = App @@ -51,6 +52,7 @@ , requestHeaders = if not $ isSuffixOf "json" path then [] else [("Accept", S8.pack "application/json")] + , httpVersion = H.http11 } f sres diff --git a/test/YesodCoreTest/Redirect.hs b/test/YesodCoreTest/Redirect.hs --- a/test/YesodCoreTest/Redirect.hs +++ b/test/YesodCoreTest/Redirect.hs @@ -45,7 +45,8 @@ it "303 redirect for regular, HTTP 1.1" $ app $ do res <- request defaultRequest { - pathInfo = ["rregular"] + pathInfo = ["rregular"], + httpVersion = H.http11 } assertStatus 303 res assertBodyContains "" res 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.2.5 +version: 1.2.6 license: MIT license-file: LICENSE author: Michael Snoyman @@ -26,8 +26,8 @@ build-depends: base >= 4.3 && < 5 , time >= 1.1.4 , yesod-routes >= 1.2 && < 1.3 - , wai >= 1.4 && < 1.5 - , wai-extra >= 1.3 && < 1.4 + , wai >= 1.4 + , wai-extra >= 1.3 , bytestring >= 0.9.1.4 , text >= 0.7 && < 0.12 , template-haskell @@ -55,9 +55,10 @@ , vector >= 0.9 && < 0.11 , aeson >= 0.5 , fast-logger >= 0.2 + , wai-logger >= 0.2 , monad-logger >= 0.3.1 && < 0.4 , conduit >= 0.5 - , resourcet >= 0.4.6 && < 0.5 + , resourcet >= 0.4.9 && < 0.5 , lifted-base >= 0.1.2 , attoparsec-conduit , blaze-html >= 0.5 @@ -65,6 +66,7 @@ , data-default , safe , warp >= 1.3.8 + , unix-compat exposed-modules: Yesod.Core Yesod.Core.Content