diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 3cf90d8b..3edf5cf3 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -67,7 +67,12 @@ import qualified Config as GHC import Data.Conduit.Network (HostPreference (HostIPv4), bindPort) import Network (withSocketsDo) +#if MIN_VERSION_http_conduit(2, 0, 0) +import Network.HTTP.Conduit (conduitManagerSettings, newManager) +import Data.Default (def) +#else import Network.HTTP.Conduit (def, newManager) +#endif import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), waiProxyToSettings, wpsTimeout, wpsOnExc) #if MIN_VERSION_http_reverse_proxy(0, 2, 0) @@ -121,7 +126,11 @@ cabalProgram opts | isCabalDev opts = "cabal-dev" -- 3001, give an appropriate message to the user. reverseProxy :: DevelOpts -> I.IORef Int -> IO () reverseProxy opts iappPort = do +#if MIN_VERSION_http_conduit(2, 0, 0) + manager <- newManager conduitManagerSettings +#else manager <- newManager def +#endif let loop = forever $ do run (develPort opts) $ waiProxyToSettings (const $ do diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 27110e13..85ae9d95 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -87,6 +87,7 @@ executable yesod , transformers , warp >= 1.3.7.5 , wai >= 1.4 + , data-default ghc-options: -Wall -threaded main-is: main.hs diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 335a15c8..48b08acf 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -146,6 +146,7 @@ warp :: YesodDispatch site => Int -> site -> IO () 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 +154,7 @@ warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings , showVersion Paths_yesod_core.version , " (core)" ] + -} } -- | A default set of middlewares. diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 205e1a66..8bd149f7 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -195,6 +195,9 @@ import Control.Failure (failure) 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 @@ -499,8 +502,17 @@ sendFilePart :: MonadHandler m -> 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. diff --git a/yesod-core/Yesod/Core/Internal/Response.hs b/yesod-core/Yesod/Core/Internal/Response.hs index c9151ed4..fce9e2e7 100644 --- a/yesod-core/Yesod/Core/Internal/Response.hs +++ b/yesod-core/Yesod/Core/Internal/Response.hs @@ -15,8 +15,10 @@ 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) +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) @@ -32,14 +34,30 @@ import qualified Data.Map as Map 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 -> Request - -> m Response +#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 -yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req = do +#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 @@ -50,17 +68,29 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req = do 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 go (ContentFile fp p) = ResponseFile s finalHeaders fp p -#if MIN_VERSION_wai(2, 0, 0) - go (ContentSource body) = ResponseSource s finalHeaders $ transPipe (flip runInternalState $ resourceInternalState req) body -#else go (ContentSource body) = ResponseSource s finalHeaders body -#endif go (ContentDontEvaluate c') = go c' return $ go c +#endif where s | s' == defaultStatus = H.status200 diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 615af0e2..ba65b3b1 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -10,13 +10,13 @@ module Yesod.Core.Internal.Run where 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, getInternalState) +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 @@ -165,16 +165,9 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () -#if MIN_VERSION_wai(2, 0, 0) - let yapp internalState = runHandler -#else let yapp = runHandler -#endif RunHandlerEnv - { rheRender = yesodRender site $ resolveApproot site $ fakeWaiRequest -#if MIN_VERSION_wai(2, 0, 0) - internalState -#endif + { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest , rheRoute = Nothing , rheSite = site , rheUpload = fileUpload site @@ -190,18 +183,13 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do typePlain (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) (reqSession req) - fakeWaiRequest -#if MIN_VERSION_wai(2, 0, 0) - internalState -#endif - = - Request + fakeWaiRequest = Request { requestMethod = "POST" , httpVersion = H.http11 , rawPathInfo = "/runFakeHandler/pathInfo" , rawQueryString = "" #if MIN_VERSION_wai(2, 0, 0) - , resourceInternalState = internalState + , requestHeaderHost = Nothing #else , serverName = "runFakeHandler-serverName" , serverPort = 80 @@ -215,30 +203,17 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , vault = mempty , requestBodyLength = KnownLength 0 } -#if MIN_VERSION_wai(2, 0, 0) - fakeRequest internalState = -#else fakeRequest = -#endif YesodRequest { reqGetParams = [] , reqCookies = [] , reqWaiRequest = fakeWaiRequest -#if MIN_VERSION_wai(2, 0, 0) - internalState -#endif , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) , reqAccept = [] , reqSession = fakeSessionMap } -#if MIN_VERSION_wai(2, 0, 0) - _ <- runResourceT $ do - is <- getInternalState - yapp is $ fakeRequest is -#else _ <- runResourceT $ yapp fakeRequest -#endif I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} @@ -275,12 +250,14 @@ yesodRunner handler' YesodRunnerEnv {..} route req rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler } - yar <- #if MIN_VERSION_wai(2, 0, 0) - flip runInternalState (resourceInternalState req) $ -#endif - runHandler rhe handler yreq + 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 req +#endif where mmaxLen = maximumContentLength yreSite route handler = yesodMiddleware handler' diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 10ee5dda..3b664099 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -65,6 +65,7 @@ library , data-default , safe , warp >= 1.3.8 + , unix-compat exposed-modules: Yesod.Core Yesod.Core.Content