Merge pull request #675 from phadej/resourcet

Use resourcet for resource managment

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

servant-server/src/Servant/Server/Internal.hs

@@ -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
-    r <- runDelayed rawApplication env request cleanupRef
+    liftIO $ go r request respond
-    go r request respond `finally` runCleanup cleanupRef
 
     where go r request respond = case r of
             Route app   -> app request (respond . Route)

servant-server/src/Servant/Server/Internal/RoutingApplication.hs

@@ -1,24 +1,32 @@
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DeriveFunctor              #-}
-{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE TypeOperators              #-}
 {-# 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           Control.Monad.Base                 (MonadBase (..))
-import           Data.IORef                         (newIORef, readIORef, IORef, atomicModifyIORef)
+import           Control.Monad.Catch                (MonadThrow (..))
-import           Network.Wai                        (Application, Request,
+import           Control.Monad.Reader               (MonadReader (..), ReaderT, runReaderT)
-                                                     Response, ResponseReceived)
+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
+liftRouteResult :: RouteResult a -> DelayedIO a
-  fmap = liftM
+liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
 
-instance Applicative DelayedIO where
+instance MonadBaseControl IO DelayedIO where
-  pure = return
+    type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
-  (<*>) = ap
+    liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
+    restoreM       = DelayedIO . restoreM
 
-instance Monad DelayedIO where
+runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
-  return x = DelayedIO (\_req _cleanup -> return (Route x))
+runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
-  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)
 
 -- | 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
+           -> ResourceT IO (RouteResult a)
-           -> IO (RouteResult a)
+runDelayed Delayed{..} env req  =
-runDelayed Delayed{..} env req cleanupRef =
   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
+runAction action env req respond k = runResourceT $ do
-  cleanupRef <- newCleanupRef
+    runDelayed action env req >>= go >>= liftIO . respond
-  (runDelayed action env req cleanupRef >>= go >>= respond)
-    `finally` runCleanup cleanupRef
-
   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

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs

@@ -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 ())
+data TestResource x
-ok = return (Route ())
+    = TestResourceNone
+    | TestResource x
+    | TestResourceFreed
+    | TestResourceError
+  deriving (Eq, Show)
 
 -- Let's not write to the filesystem
-delayedTestRef :: IORef (Maybe String)
+delayedTestRef :: IORef (TestResource String)
-delayedTestRef = unsafePerformIO $ newIORef Nothing
+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
+  { capturesD = \_ -> return ()
-  , methodD = DelayedIO $ \_req_ _cl -> ok
+  , methodD   = return ()
-  , authD = DelayedIO $ \_req _cl -> ok
+  , authD     = return ()
   , bodyD     = do
-      liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
+      liftIO (writeTestResource"hia" >> putStrLn "garbage created")
-      addCleanup (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
+      _ <- 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
+      res <- readIORef delayedTestRef
-      cleanUpDone `shouldBe` False
+      res `shouldBe` TestResourceFreed
     it "even with exceptions in serverD" $ do
+      liftIO initTestResource
       _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
-      cleanUpDone <- isJust <$> readIORef delayedTestRef
+      res <- readIORef delayedTestRef
-      cleanUpDone `shouldBe` False
+      res `shouldBe` TestResourceFreed
     it "even with routing failure in bodyD" $ do
+      liftIO initTestResource
       _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
-      cleanUpDone <- isJust <$> readIORef delayedTestRef
+      res <- readIORef delayedTestRef
-      cleanUpDone `shouldBe` False
+      res `shouldBe` TestResourceFreed
     it "even with exceptions in bodyD" $ do
+      liftIO initTestResource
       _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
-      cleanUpDone <- isJust <$> readIORef delayedTestRef
+      res <- readIORef delayedTestRef
-      cleanUpDone `shouldBe` False
+      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