Support resourcet-1.2

This commit is contained in:
Oleg Grenrus 2018-02-08 11:01:28 +02:00
parent f5ffdc7fbd
commit 77600e661b
4 changed files with 23 additions and 11 deletions

View file

@ -71,7 +71,7 @@ install:
- grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - 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" - "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 '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 - cat cabal.project
- if [ -f "servant/configure.ac" ]; then - if [ -f "servant/configure.ac" ]; then
(cd "servant" && autoreconf -i); (cd "servant" && autoreconf -i);
@ -149,7 +149,7 @@ script:
- find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - 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" - "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 '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 - cat cabal.project
- echo -en 'travis_fold:end:unpack\\r' - echo -en 'travis_fold:end:unpack\\r'

View file

@ -7,7 +7,11 @@ packages: servant/
doc/tutorial/ doc/tutorial/
doc/cookbook/*/*.cabal 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: constraints:
-- see https://github.com/haskell-infra/hackage-trustees/issues/119 -- see https://github.com/haskell-infra/hackage-trustees/issues/119

View file

@ -90,7 +90,7 @@ library
, split >= 0.2.3.2 && < 0.3 , split >= 0.2.3.2 && < 0.3
, string-conversions >= 0.4.0.1 && < 0.5 , string-conversions >= 0.4.0.1 && < 0.5
, system-filepath >= 0.4 && < 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 , tagged >= 0.8.5 && < 0.9
, transformers-base >= 0.4.4 && < 0.5 , transformers-base >= 0.4.4 && < 0.5
, transformers-compat >= 0.5.1 && < 0.6 , transformers-compat >= 0.5.1 && < 0.6

View file

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