From bc6ff20f4dd1e89c25711c99014f275bb29fcc7f Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 18 Jan 2017 11:37:18 +0200 Subject: [PATCH 1/5] Use resourcet for resource managment --- servant-server/servant-server.cabal | 8 +- servant-server/src/Servant/Server/Internal.hs | 6 +- .../Server/Internal/RoutingApplication.hs | 151 +++++++++++------- .../Server/Internal/RoutingApplicationSpec.hs | 16 +- 4 files changed, 107 insertions(+), 74 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index fb03edd7..5ff6bcc4 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 890c1856..2fad4452 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -23,7 +23,6 @@ module Servant.Server.Internal , module Servant.Server.Internal.ServantErr ) where -import Control.Exception (finally) import Control.Monad.Trans (liftIO) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 @@ -404,9 +403,8 @@ instance HasServer Raw context where -- 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 + go r request respond where go r request respond = case r of Route app -> app request (respond . Route) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index e8bd7bc6..131f4ee9 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -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) +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,58 @@ 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) + +-- As we write these instances, we get instances for `DelayedIO` with GND. +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 + +-- instance MonadCatch m => MonadCatch (RouteResultT m) where +-- instance MonadError ServantErr (RouteResultT m) where + toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where @@ -115,53 +175,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 +returnRouteResult :: RouteResult a -> DelayedIO a +returnRouteResult 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 -> IO (RouteResult a) +runDelayedIO m req = runRouteResultT $ runResourceT $ runReaderT (runDelayedIO' m) req -- | A 'Delayed' without any stored checks. emptyDelayed :: RouteResult a -> Delayed env a @@ -172,15 +209,17 @@ emptyDelayed result = -- | Fail with the option to recover. delayedFail :: ServantErr -> DelayedIO a -delayedFail err = DelayedIO (\_req _cleanup -> return $ Fail err) +delayedFail err = returnRouteResult $ 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 = returnRouteResult $ 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 +303,17 @@ passToServer Delayed{..} x = runDelayed :: Delayed env a -> env -> Request - -> CleanupRef -> IO (RouteResult a) -runDelayed Delayed{..} env req cleanupRef = +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 + returnRouteResult (serverD c a b r) ) req - cleanupRef -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. @@ -288,10 +326,7 @@ runAction :: Delayed env (Handler a) -> (a -> RouteResult Response) -> IO r runAction action env req respond k = do - cleanupRef <- newCleanupRef - (runDelayed action env req cleanupRef >>= go >>= respond) - `finally` runCleanup cleanupRef - + runDelayed action env req >>= go >>= respond where go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index abdf016d..57c01cdb 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -4,6 +4,7 @@ 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 @@ -13,23 +14,20 @@ import Test.Hspec import System.IO.Unsafe (unsafePerformIO) -ok :: IO (RouteResult ()) -ok = return (Route ()) - -- Let's not write to the filesystem delayedTestRef :: IORef (Maybe String) delayedTestRef = unsafePerformIO $ newIORef Nothing 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 - , bodyD = do + { capturesD = \_ -> return () + , methodD = return () + , authD = return () + , bodyD = do liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created") - addCleanup (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected") + _ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected") body - , serverD = \() () _body _req -> srv + , serverD = \() () _body _req -> srv } simpleRun :: Delayed () (Handler ()) From 091f6f44121c7519cde57426bd475ec63f87cec6 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 18 Jan 2017 12:17:38 +0200 Subject: [PATCH 2/5] Add failing test --- .../Server/Internal/RoutingApplicationSpec.hs | 54 ++++++++++++++++++- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index 57c01cdb..850fbf9d 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -1,3 +1,11 @@ +{-# 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 () @@ -6,11 +14,16 @@ 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.Maybe (isJust) +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) @@ -38,6 +51,36 @@ 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 (Maybe 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 $ writeIORef delayedTestRef (Just sym) + _ <- register (writeIORef delayedTestRef Nothing) + return delayedTestRef + +type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text + +resApi :: Proxy ResApi +resApi = Proxy + +resServer :: Server ResApi +resServer ref = liftIO $ fmap (maybe "" T.pack) $ readIORef ref + +------------------------------------------------------------------------------- +-- Spec +------------------------------------------------------------------------------- + spec :: Spec spec = do describe "Delayed" $ do @@ -57,3 +100,10 @@ spec = do _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ()) cleanUpDone <- isJust <$> readIORef delayedTestRef cleanUpDone `shouldBe` False + describe "ResApi" $ + with (return $ serve resApi resServer) $ do + it "writes and cleanups resources" $ do + request "GET" "foobar" [] "" `shouldRespondWith` "foobar" + liftIO $ do + cleanUpDone <- isJust <$> readIORef delayedTestRef + cleanUpDone `shouldBe` False From 2caabad61a25884477eb76019c09ed46e5845884 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 18 Jan 2017 12:25:18 +0200 Subject: [PATCH 3/5] Expose ResourceT, fix the test --- servant-server/src/Servant/Server/Internal.hs | 5 +++-- .../Servant/Server/Internal/RoutingApplication.hs | 14 +++++++------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 2fad4452..62b92612 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -24,6 +24,7 @@ module Servant.Server.Internal ) where 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 @@ -399,12 +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 r <- runDelayed rawApplication env request - go r request respond + liftIO $ go r request respond where go r request respond = case r of Route app -> app request (respond . Route) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 131f4ee9..5a13b843 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -21,7 +21,7 @@ import Control.Monad.Reader (MonadReader (..), ReaderT, import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM) -import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT) +import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat @@ -197,8 +197,8 @@ instance MonadBaseControl IO DelayedIO where liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') restoreM = DelayedIO . restoreM -runDelayedIO :: DelayedIO a -> Request -> IO (RouteResult a) -runDelayedIO m req = runRouteResultT $ runResourceT $ runReaderT (runDelayedIO' m) req +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 @@ -303,7 +303,7 @@ passToServer Delayed{..} x = runDelayed :: Delayed env a -> env -> Request - -> IO (RouteResult a) + -> ResourceT IO (RouteResult a) runDelayed Delayed{..} env req = runDelayedIO (do c <- capturesD env @@ -325,12 +325,12 @@ runAction :: Delayed env (Handler a) -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r -runAction action env req respond k = do - runDelayed action env req >>= go >>= respond +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 From d4fe0e582a3833142cffb60e2125a4a9b89d5faa Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 19 Jan 2017 00:41:18 +0200 Subject: [PATCH 4/5] Fix stylistic issues --- .../Servant/Server/Internal/RoutingApplication.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 5a13b843..f5c6ca8c 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -53,7 +53,6 @@ instance Monad RouteResult where newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } deriving (Functor) --- As we write these instances, we get instances for `DelayedIO` with GND. instance MonadTrans RouteResultT where lift = RouteResultT . liftM Route @@ -89,8 +88,6 @@ instance MonadTransControl RouteResultT where instance MonadThrow m => MonadThrow (RouteResultT m) where throwM = lift . throwM --- instance MonadCatch m => MonadCatch (RouteResultT m) where --- instance MonadError ServantErr (RouteResultT m) where toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond @@ -189,8 +186,8 @@ newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (R , MonadResource ) -returnRouteResult :: RouteResult a -> DelayedIO a -returnRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x +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 @@ -209,11 +206,11 @@ emptyDelayed result = -- | Fail with the option to recover. delayedFail :: ServantErr -> DelayedIO a -delayedFail err = returnRouteResult $ Fail err +delayedFail err = liftRouteResult $ Fail err -- | Fail fatally, i.e., without any option to recover. delayedFailFatal :: ServantErr -> DelayedIO a -delayedFailFatal err = returnRouteResult $ FailFatal err +delayedFailFatal err = liftRouteResult $ FailFatal err -- | Gain access to the incoming request. withRequest :: (Request -> DelayedIO a) -> DelayedIO a @@ -311,7 +308,7 @@ runDelayed Delayed{..} env req = a <- authD b <- bodyD r <- ask - returnRouteResult (serverD c a b r) + liftRouteResult (serverD c a b r) ) req From 6527937e2722bc4c3f6713e222743b0ba75ad4b1 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 19 Jan 2017 00:55:04 +0200 Subject: [PATCH 5/5] More robust testing, via resource state machine --- .../Server/Internal/RoutingApplicationSpec.hs | 66 +++++++++++++------ 1 file changed, 47 insertions(+), 19 deletions(-) diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index 850fbf9d..776eca1d 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -15,7 +15,6 @@ import Control.Exception hiding (Handler) import Control.Monad.Trans.Resource (register) import Control.Monad.IO.Class import Data.IORef -import Data.Maybe (isJust) import Data.Proxy import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Servant @@ -27,9 +26,33 @@ import qualified Data.Text as T import System.IO.Unsafe (unsafePerformIO) +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 @@ -37,8 +60,8 @@ delayed body srv = Delayed , methodD = return () , authD = return () , bodyD = do - liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created") - _ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected") + liftIO (writeTestResource"hia" >> putStrLn "garbage created") + _ <- register (freeTestResource >> putStrLn "garbage collected") body , serverD = \() () _body _req -> srv } @@ -59,14 +82,14 @@ simpleRun d = fmap (either ignoreE id) . try $ data Res (sym :: Symbol) instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where - type ServerT (Res sym :> api) m = IORef (Maybe String) -> ServerT api m + 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 $ writeIORef delayedTestRef (Just sym) - _ <- register (writeIORef delayedTestRef Nothing) + liftIO $ writeTestResource sym + _ <- register freeTestResource return delayedTestRef type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text @@ -75,7 +98,7 @@ resApi :: Proxy ResApi resApi = Proxy resServer :: Server ResApi -resServer ref = liftIO $ fmap (maybe "" T.pack) $ readIORef ref +resServer ref = liftIO $ fmap (fromTestResource "" T.pack) $ readIORef ref ------------------------------------------------------------------------------- -- Spec @@ -85,25 +108,30 @@ 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 - cleanUpDone <- isJust <$> readIORef delayedTestRef - cleanUpDone `shouldBe` False + res <- readIORef delayedTestRef + res `shouldBe` TestResourceFreed