eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #675 from phadej/resourcet

Browse source 
Use resourcet for resource managment
This commit is contained in:
Oleg Grenrus 2017-01-19 10:27:07 +02:00 committed by GitHub
commit 8c3291355b
4 changed files with 199 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
servant-server/servant-server.cabal
View file

@ -69,6 +69,7 @@ library
, string-conversions >= 0.3 && < 0.5
, system-filepath >= 0.4 && < 0.5
, filepath >= 1 && < 1.5
, resourcet >= 1.1.6 && <1.2
, text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6
, transformers-base >= 0.4.4 && < 0.5
@ -127,19 +128,20 @@ test-suite spec
, hspec == 2.*
, hspec-wai >= 0.8 && <0.9
, http-types
, mtl
, network >= 2.6
, QuickCheck
, parsec
, QuickCheck
, resourcet
, safe
, servant
, servant-server
, string-conversions
, should-not-typecheck == 2.1.*
, string-conversions
, temporary
, text
, transformers
, transformers-compat
, mtl
, wai
, wai-extra
, warp

9
servant-server/src/Servant/Server/Internal.hs
View file

@ -23,8 +23,8 @@ module Servant.Server.Internal
, module Servant.Server.Internal.ServantErr
) where
import Control.Exception (finally)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
@ -400,13 +400,12 @@ instance HasServer Raw context where
type ServerT Raw m = Application
route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
-- note: a Raw application doesn't register any cleanup
-- but for the sake of consistency, we nonetheless run
-- the cleanup once its done
cleanupRef <- newCleanupRef
r <- runDelayed rawApplication env request cleanupRef
go r request respond `finally` runCleanup cleanupRef
r <- runDelayed rawApplication env request
liftIO $ go r request respond
where go r request respond = case r of
Route app -> app request (respond . Route)

154
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -1,24 +1,32 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.Server.Internal.RoutingApplication where
import Control.Exception (finally)
import Control.Monad (ap, liftM)
import Control.Monad.Trans (MonadIO(..))
import Data.IORef (newIORef, readIORef, IORef, atomicModifyIORef)
import Network.Wai (Application, Request,
Response, ResponseReceived)
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Catch (MonadThrow (..))
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 Network.Wai (Application, Request, Response, ResponseReceived)
import Prelude ()
import Prelude.Compat
import Servant.Server.Internal.ServantErr
import Servant.Server.Internal.Handler
import Servant.Server.Internal.ServantErr
type RoutingApplication =
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
@ -32,6 +40,55 @@ data RouteResult a =
| Route !a
deriving (Eq, Show, Read, Functor)
instance Applicative RouteResult where
pure = return
(<*>) = ap
instance Monad RouteResult where
return = Route
Route a >>= f = f a
Fail e >>= _ = Fail e
FailFatal e >>= _ = FailFatal e
newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }
deriving (Functor)
instance MonadTrans RouteResultT where
lift = RouteResultT . liftM Route
instance (Functor m, Monad m) => Applicative (RouteResultT m) where
pure = return
(<*>) = ap
instance Monad m => Monad (RouteResultT m) where
return = RouteResultT . return . Route
m >>= k = RouteResultT $ do
a <- runRouteResultT m
case a of
Fail e -> return $ Fail e
FailFatal e -> return $ FailFatal e
Route b -> runRouteResultT (k b)
instance MonadIO m => MonadIO (RouteResultT m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (RouteResultT m) where
liftBase = lift . liftBase
instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where
type StM (RouteResultT m) a = ComposeSt RouteResultT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTransControl RouteResultT where
type StT RouteResultT a = RouteResult a
liftWith f = RouteResultT $ liftM return $ f $ runRouteResultT
restoreT = RouteResultT
instance MonadThrow m => MonadThrow (RouteResultT m) where
throwM = lift . throwM
toApplication :: RoutingApplication -> Application
toApplication ra request respond = ra request routingRespond
where
@ -115,53 +172,30 @@ instance Functor (Delayed env) where
, ..
} -- Note [Existential Record Update]
-- | A mutable cleanup action
newtype CleanupRef = CleanupRef (IORef (IO ()))
newCleanupRef :: IO CleanupRef
newCleanupRef = CleanupRef <$> newIORef (return ())
-- | Add a clean up action to a 'CleanupRef'
addCleanup' :: IO () -> CleanupRef -> IO ()
addCleanup' act (CleanupRef ref) = atomicModifyIORef ref (\act' -> (act' >> act, ()))
addCleanup :: IO () -> DelayedIO ()
addCleanup act = DelayedIO $ \_req cleanupRef ->
addCleanup' act cleanupRef >> return (Route ())
-- | Run all the clean up actions registered in
-- a 'CleanupRef'.
runCleanup :: CleanupRef -> IO ()
runCleanup (CleanupRef ref) = do
act <- readIORef ref
act
-- | Computations used in a 'Delayed' can depend on the
-- incoming 'Request', may perform 'IO, and result in a
-- 'RouteResult, meaning they can either suceed, fail
-- (with the possibility to recover), or fail fatally.
--
newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> CleanupRef -> IO (RouteResult a) }
newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
deriving
( Functor, Applicative, Monad
, MonadIO, MonadReader Request
, MonadBase IO
, MonadThrow
, MonadResource
)
instance Functor DelayedIO where
fmap = liftM
liftRouteResult :: RouteResult a -> DelayedIO a
liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
instance Applicative DelayedIO where
pure = return
(<*>) = ap
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
instance Monad DelayedIO where
return x = DelayedIO (\_req _cleanup -> return (Route x))
DelayedIO m >>= f =
DelayedIO $ \ req cl -> do
r <- m req cl
case r of
Fail e -> return $ Fail e
FailFatal e -> return $ FailFatal e
Route a -> runDelayedIO (f a) req cl
instance MonadIO DelayedIO where
liftIO m = DelayedIO (\_req _cl -> Route <$> m)
runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
-- | A 'Delayed' without any stored checks.
emptyDelayed :: RouteResult a -> Delayed env a
@ -172,15 +206,17 @@ emptyDelayed result =
-- | Fail with the option to recover.
delayedFail :: ServantErr -> DelayedIO a
delayedFail err = DelayedIO (\_req _cleanup -> return $ Fail err)
delayedFail err = liftRouteResult $ Fail err
-- | Fail fatally, i.e., without any option to recover.
delayedFailFatal :: ServantErr -> DelayedIO a
delayedFailFatal err = DelayedIO (\_req _cleanup -> return $ FailFatal err)
delayedFailFatal err = liftRouteResult $ FailFatal err
-- | Gain access to the incoming request.
withRequest :: (Request -> DelayedIO a) -> DelayedIO a
withRequest f = DelayedIO (\ req cl -> runDelayedIO (f req) req cl)
withRequest f = do
req <- ask
f req
-- | Add a capture to the end of the capture block.
addCapture :: Delayed env (a -> b)
@ -264,18 +300,17 @@ passToServer Delayed{..} x =
runDelayed :: Delayed env a
-> env
-> Request
-> CleanupRef
-> IO (RouteResult a)
runDelayed Delayed{..} env req cleanupRef =
-> ResourceT IO (RouteResult a)
runDelayed Delayed{..} env req =
runDelayedIO
(do c <- capturesD env
methodD
a <- authD
b <- bodyD
DelayedIO $ \ r _cleanup -> return (serverD c a b r)
r <- ask
liftRouteResult (serverD c a b r)
)
req
cleanupRef
-- | Runs a delayed server and the resulting action.
-- Takes a continuation that lets us send a response.
@ -287,15 +322,12 @@ runAction :: Delayed env (Handler a)
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction action env req respond k = do
cleanupRef <- newCleanupRef
(runDelayed action env req cleanupRef >>= go >>= respond)
`finally` runCleanup cleanupRef
runAction action env req respond k = runResourceT $ do
runDelayed action env req >>= go >>= liftIO . respond
where
go (Fail e) = return $ Fail e
go (FailFatal e) = return $ FailFatal e
go (Route a) = do
go (Route a) = liftIO $ do
e <- runHandler a
case e of
Left err -> return . Route $ responseServantErr err

114
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
View file

@ -1,33 +1,67 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.Internal.RoutingApplicationSpec (spec) where
import Prelude ()
import Prelude.Compat
import Control.Exception hiding (Handler)
import Control.Monad.Trans.Resource (register)
import Control.Monad.IO.Class
import Data.Maybe (isJust)
import Data.IORef
import Servant.Server
import Data.Proxy
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Servant
import Servant.Server.Internal.RoutingApplication
import Test.Hspec
import Test.Hspec.Wai (request, shouldRespondWith, with)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
ok :: IO (RouteResult ())
ok = return (Route ())
data TestResource x
= TestResourceNone
| TestResource x
| TestResourceFreed
| TestResourceError
deriving (Eq, Show)
-- Let's not write to the filesystem
delayedTestRef :: IORef (Maybe String)
delayedTestRef = unsafePerformIO $ newIORef Nothing
delayedTestRef :: IORef (TestResource String)
delayedTestRef = unsafePerformIO $ newIORef TestResourceNone
fromTestResource :: a -> (b -> a) -> TestResource b -> a
fromTestResource _ f (TestResource x) = f x
fromTestResource x _ _ = x
initTestResource :: IO ()
initTestResource = writeIORef delayedTestRef TestResourceNone
writeTestResource :: String -> IO ()
writeTestResource x = modifyIORef delayedTestRef $ \r -> case r of
TestResourceNone -> TestResource x
_ -> TestResourceError
freeTestResource :: IO ()
freeTestResource = modifyIORef delayedTestRef $ \r -> case r of
TestResource _ -> TestResourceFreed
_ -> TestResourceError
delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
delayed body srv = Delayed
{ capturesD = \() -> DelayedIO $ \_req _cl -> ok
, methodD = DelayedIO $ \_req_ _cl -> ok
, authD = DelayedIO $ \_req _cl -> ok
{ capturesD = \_ -> return ()
, methodD = return ()
, authD = return ()
, bodyD = do
liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
addCleanup (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
liftIO (writeTestResource"hia" >> putStrLn "garbage created")
_ <- register (freeTestResource >> putStrLn "garbage collected")
body
, serverD = \() () _body _req -> srv
}
@ -40,22 +74,64 @@ simpleRun d = fmap (either ignoreE id) . try $
where ignoreE :: SomeException -> ()
ignoreE = const ()
-------------------------------------------------------------------------------
-- Combinator example
-------------------------------------------------------------------------------
-- | This data types writes 'sym' to 'delayedTestRef'.
data Res (sym :: Symbol)
instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
route Proxy ctx server = route (Proxy :: Proxy api) ctx $
server `addBodyCheck` check
where
sym = symbolVal (Proxy :: Proxy sym)
check = do
liftIO $ writeTestResource sym
_ <- register freeTestResource
return delayedTestRef
type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
resApi :: Proxy ResApi
resApi = Proxy
resServer :: Server ResApi
resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref
-------------------------------------------------------------------------------
-- Spec
-------------------------------------------------------------------------------
spec :: Spec
spec = do
describe "Delayed" $ do
it "actually runs clean up actions" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with exceptions in serverD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with routing failure in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with exceptions in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
describe "ResApi" $
with (return $ serve resApi resServer) $ do
it "writes and cleanups resources" $ do
liftIO initTestResource
request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
liftIO $ do
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed