Merge pull request #900 from phadej/resourcet-1.2

Support resourcet-1.2

Author: phadej

.travis.yml

@@ -71,7 +71,7 @@ install:
   - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
   - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/basic-auth\" \"doc/cookbook/https\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/file-upload\"\\n' > cabal.project"
   - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
-  - "echo 'allow-newer: servant-js:servant-foreign, servant-auth-server:http-types, servant-multipart:lens' >> cabal.project"
+  - "echo 'allow-newer: servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet' >> cabal.project"
   - cat cabal.project
   - if [ -f "servant/configure.ac" ]; then
       (cd "servant" && autoreconf -i);
@@ -149,7 +149,7 @@ script:
   - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
   - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-https-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-file-upload-*/*.cabal\\n' > cabal.project"
   - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
-  - "echo 'allow-newer: servant-js:servant-foreign, servant-auth-server:http-types, servant-multipart:lens' >> cabal.project"
+  - "echo 'allow-newer: servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet' >> cabal.project"
   - cat cabal.project
   - echo -en 'travis_fold:end:unpack\\r'
 

cabal.project

@@ -7,7 +7,11 @@ packages: servant/
   doc/tutorial/
   doc/cookbook/*/*.cabal
 
-allow-newer: servant-js:servant-foreign, servant-auth-server:http-types, servant-multipart:lens
+allow-newer:
+  servant-js:servant-foreign,
+  servant-auth-server:http-types,
+  servant-multipart:lens,
+  servant-multipart:resourcet
 
 constraints:
   -- see https://github.com/haskell-infra/hackage-trustees/issues/119

servant-server/servant-server.cabal

@@ -90,7 +90,7 @@ library
     , split               >= 0.2.3.2  && < 0.3
     , string-conversions  >= 0.4.0.1  && < 0.5
     , system-filepath     >= 0.4      && < 0.5
-    , resourcet           >= 1.1.10   && < 1.2
+    , resourcet           >= 1.1.9    && < 1.3
     , tagged              >= 0.8.5    && < 0.9
     , transformers-base   >= 0.4.4    && < 0.5
     , transformers-compat >= 0.5.1    && < 0.6

servant-server/src/Servant/Server/Internal/RoutingApplication.hs

@@ -13,11 +13,11 @@ module Servant.Server.Internal.RoutingApplication where
 import           Control.Monad                      (ap, liftM)
 import           Control.Monad.Base                 (MonadBase (..))
 import           Control.Monad.Catch                (MonadThrow (..))
-import           Control.Monad.Reader               (MonadReader (..), ReaderT, runReaderT)
+import           Control.Monad.Reader               (MonadReader (..), ReaderT (..), runReaderT)
 import           Control.Monad.Trans                (MonadIO (..), MonadTrans (..))
 import           Control.Monad.Trans.Control        (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
                                                      defaultLiftBaseWith, defaultRestoreM)
-import           Control.Monad.Trans.Resource       (MonadResource (..), ResourceT, runResourceT, transResourceT)
+import           Control.Monad.Trans.Resource       (MonadResource (..), ResourceT, runResourceT, transResourceT, withInternalState, runInternalState)
 import           Network.Wai                        (Application, Request, Response, ResponseReceived)
 import           Prelude                            ()
 import           Prelude.Compat
@@ -84,7 +84,6 @@ instance MonadTransControl RouteResultT where
 instance MonadThrow m => MonadThrow (RouteResultT m) where
     throwM = lift . throwM
 
-
 toApplication :: RoutingApplication -> Application
 toApplication ra request respond = ra request routingRespond
  where
@@ -194,18 +193,27 @@ newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (R
   deriving
     ( Functor, Applicative, Monad
     , MonadIO, MonadReader Request
-    , MonadBase IO
     , MonadThrow
     , MonadResource
     )
 
+instance MonadBase IO DelayedIO where
+    liftBase = liftIO
+
 liftRouteResult :: RouteResult a -> DelayedIO a
 liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
 
 instance MonadBaseControl IO DelayedIO where
-    type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
-    liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
-    restoreM       = DelayedIO . restoreM
+    -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
+    -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
+    -- restoreM       = DelayedIO . restoreM
+
+    type StM DelayedIO a = RouteResult a
+    liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->
+        liftBaseWith $ \runInBase -> f $ \x ->
+            runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)
+    restoreM      = DelayedIO . lift . withInternalState . const . restoreM
+
 
 runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
 runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req