WAI 2.0 updates

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

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

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.

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.

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
+yarToResponse :: YesodResponse
-              => YesodResponse
+              -> (SessionMap -> IO [Header]) -- ^ save session
-              -> (SessionMap -> m [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

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
+            { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
-#if MIN_VERSION_wai(2, 0, 0)
-                            internalState
-#endif
             , 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
+      fakeWaiRequest = Request
-#if MIN_VERSION_wai(2, 0, 0)
-       internalState
-#endif
-        =
-        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) $
+    bracketOnError createInternalState closeInternalState $ \is -> do
-#endif
+        yar <- runInternalState (runHandler rhe handler yreq) is
-        runHandler rhe handler yreq
+        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'

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