@@ -1,24 +1,32 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE FlexibleInstances #-}
54{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
66{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
79{-# LANGUAGE RecordWildCards #-}
810{-# LANGUAGE StandaloneDeriving #-}
911{-# LANGUAGE TupleSections #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
1015module Servant.Server.Internal.RoutingApplication where
1116
12−import Control.Exception (finally)
1317import Control.Monad (ap, liftM)
14−import Control.Monad.Trans (MonadIO(..))
15−import Data.IORef (newIORef, readIORef, IORef, atomicModifyIORef)
16−import Network.Wai (Application, Request,
17− Response, ResponseReceived)
18+import Control.Monad.Base (MonadBase (..))
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, transResourceT)
25+import Network.Wai (Application, Request, Response, ResponseReceived)
1826import Prelude ()
1927import Prelude.Compat
20−import Servant.Server.Internal.ServantErr
2128import Servant.Server.Internal.Handler
29+import Servant.Server.Internal.ServantErr
2230
2331type RoutingApplication =
2432 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
@@ -32,6 +40,55 @@ data RouteResult a =
3240 | Route !a
3341 deriving (Eq, Show, Read, Functor)
3442
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+instance MonadTrans RouteResultT where
57+ lift = RouteResultT . liftM Route
58+
59+instance (Functor m, Monad m) => Applicative (RouteResultT m) where
60+ pure = return
61+ (<*>) = ap
62+
63+instance Monad m => Monad (RouteResultT m) where
64+ return = RouteResultT . return . Route
65+ m >>= k = RouteResultT $ do
66+ a <- runRouteResultT m
67+ case a of
68+ Fail e -> return $ Fail e
69+ FailFatal e -> return $ FailFatal e
70+ Route b -> runRouteResultT (k b)
71+
72+instance MonadIO m => MonadIO (RouteResultT m) where
73+ liftIO = lift . liftIO
74+
75+instance MonadBase b m => MonadBase b (RouteResultT m) where
76+ liftBase = lift . liftBase
77+
78+instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where
79+ type StM (RouteResultT m) a = ComposeSt RouteResultT m a
80+ liftBaseWith = defaultLiftBaseWith
81+ restoreM = defaultRestoreM
82+
83+instance MonadTransControl RouteResultT where
84+ type StT RouteResultT a = RouteResult a
85+ liftWith f = RouteResultT $ liftM return $ f $ runRouteResultT
86+ restoreT = RouteResultT
87+
88+instance MonadThrow m => MonadThrow (RouteResultT m) where
89+ throwM = lift . throwM
90+
91+
3592toApplication :: RoutingApplication -> Application
3693toApplication ra request respond = ra request routingRespond
3794 where
@@ -115,53 +172,30 @@ instance Functor (Delayed env) where
115172 , ..
116173 } -- Note [Existential Record Update]
117174
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−
139175-- | Computations used in a 'Delayed' can depend on the
140176-- incoming 'Request', may perform 'IO, and result in a
141177-- 'RouteResult, meaning they can either suceed, fail
142178-- (with the possibility to recover), or fail fatally.
143179--
144−newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> CleanupRef -> IO (RouteResult a) }
145−
146−instance Functor DelayedIO where
147− fmap = liftM
180+newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
181+ deriving
182+ ( Functor, Applicative, Monad
183+ , MonadIO, MonadReader Request
184+ , MonadBase IO
185+ , MonadThrow
186+ , MonadResource
187+ )
148188
149−instance Applicative DelayedIO where
150− pure = return
151− (<*>) = ap
189+liftRouteResult :: RouteResult a -> DelayedIO a
190+liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
152191
153−instance Monad DelayedIO where
154− return x = DelayedIO (\_req _cleanup -> return (Route x))
155− DelayedIO m >>= f =
156− DelayedIO $ \ req cl -> do
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
192+instance MonadBaseControl IO DelayedIO where
193+ type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
194+ liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
195+ restoreM = DelayedIO . restoreM
162196
163−instance MonadIO DelayedIO where
164− liftIO m = DelayedIO (\_req _cl -> Route <$> m)
197+runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
198+runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
165199
166200-- | A 'Delayed' without any stored checks.
167201emptyDelayed :: RouteResult a -> Delayed env a
@@ -172,15 +206,17 @@ emptyDelayed result =
172206
173207-- | Fail with the option to recover.
174208delayedFail :: ServantErr -> DelayedIO a
175−delayedFail err = DelayedIO (\_req _cleanup -> return $ Fail err)
209+delayedFail err = liftRouteResult $ Fail err
176210
177211-- | Fail fatally, i.e., without any option to recover.
178212delayedFailFatal :: ServantErr -> DelayedIO a
179−delayedFailFatal err = DelayedIO (\_req _cleanup -> return $ FailFatal err)
213+delayedFailFatal err = liftRouteResult $ FailFatal err
180214
181215-- | Gain access to the incoming request.
182216withRequest :: (Request -> DelayedIO a) -> DelayedIO a
183−withRequest f = DelayedIO (\ req cl -> runDelayedIO (f req) req cl)
217+withRequest f = do
218+ req <- ask
219+ f req
184220
185221-- | Add a capture to the end of the capture block.
186222addCapture :: Delayed env (a -> b)
@@ -264,18 +300,17 @@ passToServer Delayed{..} x =
264300runDelayed :: Delayed env a
265301 -> env
266302 -> Request
267− -> CleanupRef
268− -> IO (RouteResult a)
269−runDelayed Delayed{..} env req cleanupRef =
303+ -> ResourceT IO (RouteResult a)
304+runDelayed Delayed{..} env req =
270305 runDelayedIO
271306 (do c <- capturesD env
272307 methodD
273308 a <- authD
274309 b <- bodyD
275− DelayedIO $ \ r _cleanup -> return (serverD c a b r)
310+ r <- ask
311+ liftRouteResult (serverD c a b r)
276312 )
277313 req
278− cleanupRef
279314
280315-- | Runs a delayed server and the resulting action.
281316-- Takes a continuation that lets us send a response.
@@ -287,15 +322,12 @@ runAction :: Delayed env (Handler a)
287322 -> (RouteResult Response -> IO r)
288323 -> (a -> RouteResult Response)
289324 -> IO r
290−runAction action env req respond k = do
291− cleanupRef <- newCleanupRef
292− (runDelayed action env req cleanupRef >>= go >>= respond)
293− `finally` runCleanup cleanupRef
294−
325+runAction action env req respond k = runResourceT $ do
326+ runDelayed action env req >>= go >>= liftIO . respond
295327 where
296328 go (Fail e) = return $ Fail e
297329 go (FailFatal e) = return $ FailFatal e
298− go (Route a) = do
330+ go (Route a) = liftIO $ do
299331 e <- runHandler a
300332 case e of
301333 Left err -> return . Route $ responseServantErr err