bc6ff20 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Use resourcet for resource managment

bc6ff20Oleg Grenrus10 years ago

servant-server/servant-server.cabal+5−3

compare with master

unifiedsplit

@@ -69,6 +69,7 @@ library

69 , string-conversions >= 0.3 && < 0.5

70 , system-filepath >= 0.4 && < 0.5

71 , filepath >= 1 && < 1.5

72+ , resourcet >= 1.1.6 && <1.2

72 , text >= 1.2 && < 1.3

73 , text >= 1.2 && < 1.3

73 , transformers >= 0.3 && < 0.6

74 , transformers >= 0.3 && < 0.6

74 , transformers-base >= 0.4.4 && < 0.5

75 , transformers-base >= 0.4.4 && < 0.5

@@ -127,19 +128,20 @@ test-suite spec

127 , hspec == 2.*

128 , hspec == 2.*

128 , hspec-wai >= 0.8 && <0.9

129 , hspec-wai >= 0.8 && <0.9

129 , http-types

130 , http-types

131+ , mtl

130 , network >= 2.6

132 , network >= 2.6

131− , QuickCheck

132 , parsec

133 , parsec

134+ , QuickCheck

135+ , resourcet

133 , safe

136 , safe

134 , servant

137 , servant

135 , servant-server

138 , servant-server

136− , string-conversions

137 , should-not-typecheck == 2.1.*

139 , should-not-typecheck == 2.1.*

140+ , string-conversions

138 , temporary

141 , temporary

139 , text

142 , text

140 , transformers

143 , transformers

141 , transformers-compat

144 , transformers-compat

142− , mtl

143 , wai

145 , wai

144 , wai-extra

146 , wai-extra

145 , warp

147 , warp

servant-server/src/Servant/Server/Internal.hs+2−4

@@ -23,7 +23,6 @@ module Servant.Server.Internal

23 , module Servant.Server.Internal.ServantErr

24 ) where

26−import Control.Exception (finally)

27import Control.Monad.Trans (liftIO)

26import Control.Monad.Trans (liftIO)

28import qualified Data.ByteString as B

27import qualified Data.ByteString as B

29import qualified Data.ByteString.Char8 as BC8

28import qualified Data.ByteString.Char8 as BC8

@@ -404,9 +403,8 @@ instance HasServer Raw context where

404 -- note: a Raw application doesn't register any cleanup

403 -- note: a Raw application doesn't register any cleanup

405 -- but for the sake of consistency, we nonetheless run

404 -- but for the sake of consistency, we nonetheless run

406 -- the cleanup once its done

405 -- the cleanup once its done

407− cleanupRef <- newCleanupRef

408− r <- runDelayed rawApplication env request cleanupRef

406+ r <- runDelayed rawApplication env request

409− go r request respond `finally` runCleanup cleanupRef

407+ go r request respond

410

408

411 where go r request respond = case r of

409 where go r request respond = case r of

412 Route app -> app request (respond . Route)

410 Route app -> app request (respond . Route)

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+93−58

@@ -1,24 +1,32 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE RecordWildCards #-}

9{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE StandaloneDeriving #-}

10{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE TupleSections #-}

11{-# LANGUAGE TupleSections #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

10module Servant.Server.Internal.RoutingApplication where

15module Servant.Server.Internal.RoutingApplication where

12−import Control.Exception (finally)

13import Control.Monad (ap, liftM)

17import Control.Monad (ap, liftM)

14−import Control.Monad.Trans (MonadIO(..))

18+import Control.Monad.Base (MonadBase (..))

15−import Data.IORef (newIORef, readIORef, IORef, atomicModifyIORef)

19+import Control.Monad.Catch (MonadThrow (..))

20+import Control.Monad.Reader (MonadReader (..), ReaderT, runReaderT)

21+import Control.Monad.Trans (MonadIO (..), MonadTrans (..))

22+import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..),

23+ defaultLiftBaseWith, defaultRestoreM)

24+import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT)

16−import Network.Wai (Application, Request,

25+import Network.Wai (Application, Request, Response, ResponseReceived)

17− Response, ResponseReceived)

18import Prelude ()

26import Prelude ()

19import Prelude.Compat

27import Prelude.Compat

20−import Servant.Server.Internal.ServantErr

21import Servant.Server.Internal.Handler

28import Servant.Server.Internal.Handler

29+import Servant.Server.Internal.ServantErr

23type RoutingApplication =

31type RoutingApplication =

24 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

32 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

@@ -32,6 +40,58 @@ data RouteResult a =

32 | Route !a

40 | Route !a

33 deriving (Eq, Show, Read, Functor)

41 deriving (Eq, Show, Read, Functor)

43+instance Applicative RouteResult where

44+ pure = return

45+ (<*>) = ap

46+

47+instance Monad RouteResult where

48+ return = Route

49+ Route a >>= f = f a

50+ Fail e >>= _ = Fail e

51+ FailFatal e >>= _ = FailFatal e

52+

53+newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }

54+ deriving (Functor)

55+

56+-- As we write these instances, we get instances for `DelayedIO` with GND.

57+instance MonadTrans RouteResultT where

58+ lift = RouteResultT . liftM Route

59+

60+instance (Functor m, Monad m) => Applicative (RouteResultT m) where

61+ pure = return

62+ (<*>) = ap

63+

64+instance Monad m => Monad (RouteResultT m) where

65+ return = RouteResultT . return . Route

66+ m >>= k = RouteResultT $ do

67+ a <- runRouteResultT m

68+ case a of

69+ Fail e -> return $ Fail e

70+ FailFatal e -> return $ FailFatal e

71+ Route b -> runRouteResultT (k b)

72+

73+instance MonadIO m => MonadIO (RouteResultT m) where

74+ liftIO = lift . liftIO

75+

76+instance MonadBase b m => MonadBase b (RouteResultT m) where

77+ liftBase = lift . liftBase

78+

79+instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where

80+ type StM (RouteResultT m) a = ComposeSt RouteResultT m a

81+ liftBaseWith = defaultLiftBaseWith

82+ restoreM = defaultRestoreM

83+

84+instance MonadTransControl RouteResultT where

85+ type StT RouteResultT a = RouteResult a

86+ liftWith f = RouteResultT $ liftM return $ f $ runRouteResultT

87+ restoreT = RouteResultT

88+

89+instance MonadThrow m => MonadThrow (RouteResultT m) where

90+ throwM = lift . throwM

91+

92+-- instance MonadCatch m => MonadCatch (RouteResultT m) where

93+-- instance MonadError ServantErr (RouteResultT m) where

94+

35toApplication :: RoutingApplication -> Application

95toApplication :: RoutingApplication -> Application

36toApplication ra request respond = ra request routingRespond

96toApplication ra request respond = ra request routingRespond

37 where

97 where

@@ -115,53 +175,30 @@ instance Functor (Delayed env) where

115 , ..

175 , ..

116 } -- Note [Existential Record Update]

176 } -- Note [Existential Record Update]

117

177

118−-- | A mutable cleanup action

119−newtype CleanupRef = CleanupRef (IORef (IO ()))

120−

121−newCleanupRef :: IO CleanupRef

122−newCleanupRef = CleanupRef <$> newIORef (return ())

123−

124−-- | Add a clean up action to a 'CleanupRef'

125−addCleanup' :: IO () -> CleanupRef -> IO ()

126−addCleanup' act (CleanupRef ref) = atomicModifyIORef ref (\act' -> (act' >> act, ()))

127−

128−addCleanup :: IO () -> DelayedIO ()

129−addCleanup act = DelayedIO $ \_req cleanupRef ->

130− addCleanup' act cleanupRef >> return (Route ())

131−

132−-- | Run all the clean up actions registered in

133−-- a 'CleanupRef'.

134−runCleanup :: CleanupRef -> IO ()

135−runCleanup (CleanupRef ref) = do

136− act <- readIORef ref

137− act

138−

139-- | Computations used in a 'Delayed' can depend on the

178-- | Computations used in a 'Delayed' can depend on the

140-- incoming 'Request', may perform 'IO, and result in a

179-- incoming 'Request', may perform 'IO, and result in a

141-- 'RouteResult, meaning they can either suceed, fail

180-- 'RouteResult, meaning they can either suceed, fail

142-- (with the possibility to recover), or fail fatally.

181-- (with the possibility to recover), or fail fatally.

143--

182--

144−newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> CleanupRef -> IO (RouteResult a) }

183+newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }

145−

184+ deriving

146−instance Functor DelayedIO where

185+ ( Functor, Applicative, Monad

147− fmap = liftM

186+ , MonadIO, MonadReader Request

187+ , MonadBase IO

188+ , MonadThrow

189+ , MonadResource

190+ )

148

191

149−instance Applicative DelayedIO where

192+returnRouteResult :: RouteResult a -> DelayedIO a

150− pure = return

193+returnRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x

151− (<*>) = ap

152

194

153−instance Monad DelayedIO where

195+instance MonadBaseControl IO DelayedIO where

154− return x = DelayedIO (\_req _cleanup -> return (Route x))

196+ type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a

155− DelayedIO m >>= f =

197+ liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')

156− DelayedIO $ \ req cl -> do

198+ restoreM = DelayedIO . restoreM

157− r <- m req cl

158− case r of

159− Fail e -> return $ Fail e

160− FailFatal e -> return $ FailFatal e

161− Route a -> runDelayedIO (f a) req cl

162

199

163−instance MonadIO DelayedIO where

200+runDelayedIO :: DelayedIO a -> Request -> IO (RouteResult a)

164− liftIO m = DelayedIO (\_req _cl -> Route <$> m)

201+runDelayedIO m req = runRouteResultT $ runResourceT $ runReaderT (runDelayedIO' m) req

165

202

166-- | A 'Delayed' without any stored checks.

203-- | A 'Delayed' without any stored checks.

167emptyDelayed :: RouteResult a -> Delayed env a

204emptyDelayed :: RouteResult a -> Delayed env a

@@ -172,15 +209,17 @@ emptyDelayed result =

172

209

173-- | Fail with the option to recover.

210-- | Fail with the option to recover.

174delayedFail :: ServantErr -> DelayedIO a

211delayedFail :: ServantErr -> DelayedIO a

175−delayedFail err = DelayedIO (\_req _cleanup -> return $ Fail err)

212+delayedFail err = returnRouteResult $ Fail err

176

213

177-- | Fail fatally, i.e., without any option to recover.

214-- | Fail fatally, i.e., without any option to recover.

178delayedFailFatal :: ServantErr -> DelayedIO a

215delayedFailFatal :: ServantErr -> DelayedIO a

179−delayedFailFatal err = DelayedIO (\_req _cleanup -> return $ FailFatal err)

216+delayedFailFatal err = returnRouteResult $ FailFatal err

180

217

181-- | Gain access to the incoming request.

218-- | Gain access to the incoming request.

182withRequest :: (Request -> DelayedIO a) -> DelayedIO a

219withRequest :: (Request -> DelayedIO a) -> DelayedIO a

183−withRequest f = DelayedIO (\ req cl -> runDelayedIO (f req) req cl)

220+withRequest f = do

221+ req <- ask

222+ f req

184

223

185-- | Add a capture to the end of the capture block.

224-- | Add a capture to the end of the capture block.

186addCapture :: Delayed env (a -> b)

225addCapture :: Delayed env (a -> b)

@@ -264,18 +303,17 @@ passToServer Delayed{..} x =

264runDelayed :: Delayed env a

303runDelayed :: Delayed env a

265 -> env

304 -> env

266 -> Request

305 -> Request

267− -> CleanupRef

268 -> IO (RouteResult a)

306 -> IO (RouteResult a)

269−runDelayed Delayed{..} env req cleanupRef =

307+runDelayed Delayed{..} env req =

270 runDelayedIO

308 runDelayedIO

271 (do c <- capturesD env

309 (do c <- capturesD env

272 methodD

310 methodD

273 a <- authD

311 a <- authD

274 b <- bodyD

312 b <- bodyD

275− DelayedIO $ \ r _cleanup -> return (serverD c a b r)

313+ r <- ask

314+ returnRouteResult (serverD c a b r)

276 )

315 )

277 req

316 req

278− cleanupRef

279

317

280-- | Runs a delayed server and the resulting action.

318-- | Runs a delayed server and the resulting action.

281-- Takes a continuation that lets us send a response.

319-- Takes a continuation that lets us send a response.

@@ -288,10 +326,7 @@ runAction :: Delayed env (Handler a)

288 -> (a -> RouteResult Response)

326 -> (a -> RouteResult Response)

289 -> IO r

327 -> IO r

290runAction action env req respond k = do

328runAction action env req respond k = do

291− cleanupRef <- newCleanupRef

292− (runDelayed action env req cleanupRef >>= go >>= respond)

329+ runDelayed action env req >>= go >>= respond

293− `finally` runCleanup cleanupRef

294−

295 where

330 where

296 go (Fail e) = return $ Fail e

331 go (Fail e) = return $ Fail e

297 go (FailFatal e) = return $ FailFatal e

332 go (FailFatal e) = return $ FailFatal e

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+7−9

@@ -4,6 +4,7 @@ import Prelude ()

4import Prelude.Compat

6import Control.Exception hiding (Handler)

7+import Control.Monad.Trans.Resource (register)

7import Control.Monad.IO.Class

8import Control.Monad.IO.Class

8import Data.Maybe (isJust)

9import Data.Maybe (isJust)

9import Data.IORef

10import Data.IORef

@@ -13,23 +14,20 @@ import Test.Hspec

14import System.IO.Unsafe (unsafePerformIO)

15import System.IO.Unsafe (unsafePerformIO)

16−ok :: IO (RouteResult ())

17−ok = return (Route ())

18−

19-- Let's not write to the filesystem

17-- Let's not write to the filesystem

20delayedTestRef :: IORef (Maybe String)

18delayedTestRef :: IORef (Maybe String)

21delayedTestRef = unsafePerformIO $ newIORef Nothing

19delayedTestRef = unsafePerformIO $ newIORef Nothing

23delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())

21delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())

24delayed body srv = Delayed

22delayed body srv = Delayed

25− { capturesD = \() -> DelayedIO $ \_req _cl -> ok

23+ { capturesD = \_ -> return ()

26− , methodD = DelayedIO $ \_req_ _cl -> ok

24+ , methodD = return ()

27− , authD = DelayedIO $ \_req _cl -> ok

25+ , authD = return ()

28− , bodyD = do

26+ , bodyD = do

29 liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")

27 liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")

30− addCleanup (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")

28+ _ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")

31 body

29 body

32− , serverD = \() () _body _req -> srv

30+ , serverD = \() () _body _req -> srv

33 }

31 }

35simpleRun :: Delayed () (Handler ())

33simpleRun :: Delayed () (Handler ())