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*$'
- "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'

View file

@ -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

View file

@ -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

View file

@ -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