From 77600e661b2a183e476f861d1eb5da901f86b4da Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 8 Feb 2018 11:01:28 +0200 Subject: [PATCH] Support resourcet-1.2 --- .travis.yml | 4 ++-- cabal.project | 6 ++++- servant-server/servant-server.cabal | 2 +- .../Server/Internal/RoutingApplication.hs | 22 +++++++++++++------ 4 files changed, 23 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index 49e4e539..7a5ead9c 100644 --- a/.travis.yml +++ b/.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' diff --git a/cabal.project b/cabal.project index 81d28995..d5d51915 100644 --- a/cabal.project +++ b/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 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 743ffff2..7dd291a8 100644 --- a/servant-server/servant-server.cabal +++ b/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 diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 564f1908..8a01894d 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/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