@@ -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)
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,58 @@ 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+-- 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+
3595toApplication :: RoutingApplication -> Application
3696toApplication ra request respond = ra request routingRespond
3797 where
@@ -115,53 +175,30 @@ instance Functor (Delayed env) where
115175 , ..
116176 } -- Note [Existential Record Update]
117177
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−
139178-- | Computations used in a 'Delayed' can depend on the
140179-- incoming 'Request', may perform 'IO, and result in a
141180-- 'RouteResult, meaning they can either suceed, fail
142181-- (with the possibility to recover), or fail fatally.
143182--
144−newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> CleanupRef -> IO (RouteResult a) }
145−
146−instance Functor DelayedIO where
147− fmap = liftM
183+newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
184+ deriving
185+ ( Functor, Applicative, Monad
186+ , MonadIO, MonadReader Request
187+ , MonadBase IO
188+ , MonadThrow
189+ , MonadResource
190+ )
148191
149−instance Applicative DelayedIO where
150− pure = return
151− (<*>) = ap
192+returnRouteResult :: RouteResult a -> DelayedIO a
193+returnRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
152194
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
195+instance MonadBaseControl IO DelayedIO where
196+ type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
197+ liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
198+ restoreM = DelayedIO . restoreM
162199
163−instance MonadIO DelayedIO where
164− liftIO m = DelayedIO (\_req _cl -> Route <$> m)
200+runDelayedIO :: DelayedIO a -> Request -> IO (RouteResult a)
201+runDelayedIO m req = runRouteResultT $ runResourceT $ runReaderT (runDelayedIO' m) req
165202
166203-- | A 'Delayed' without any stored checks.
167204emptyDelayed :: RouteResult a -> Delayed env a
@@ -172,15 +209,17 @@ emptyDelayed result =
172209
173210-- | Fail with the option to recover.
174211delayedFail :: ServantErr -> DelayedIO a
175−delayedFail err = DelayedIO (\_req _cleanup -> return $ Fail err)
212+delayedFail err = returnRouteResult $ Fail err
176213
177214-- | Fail fatally, i.e., without any option to recover.
178215delayedFailFatal :: ServantErr -> DelayedIO a
179−delayedFailFatal err = DelayedIO (\_req _cleanup -> return $ FailFatal err)
216+delayedFailFatal err = returnRouteResult $ FailFatal err
180217
181218-- | Gain access to the incoming request.
182219withRequest :: (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
184223
185224-- | Add a capture to the end of the capture block.
186225addCapture :: Delayed env (a -> b)
@@ -264,18 +303,17 @@ passToServer Delayed{..} x =
264303runDelayed :: Delayed env a
265304 -> env
266305 -> Request
267− -> CleanupRef
268306 -> IO (RouteResult a)
269−runDelayed Delayed{..} env req cleanupRef =
307+runDelayed Delayed{..} env req =
270308 runDelayedIO
271309 (do c <- capturesD env
272310 methodD
273311 a <- authD
274312 b <- bodyD
275− DelayedIO $ \ r _cleanup -> return (serverD c a b r)
313+ r <- ask
314+ returnRouteResult (serverD c a b r)
276315 )
277316 req
278− cleanupRef
279317
280318-- | Runs a delayed server and the resulting action.
281319-- Takes a continuation that lets us send a response.
@@ -288,10 +326,7 @@ runAction :: Delayed env (Handler a)
288326 -> (a -> RouteResult Response)
289327 -> IO r
290328runAction action env req respond k = do
291− cleanupRef <- newCleanupRef
292− (runDelayed action env req cleanupRef >>= go >>= respond)
293− `finally` runCleanup cleanupRef
294−
329+ runDelayed action env req >>= go >>= respond
295330 where
296331 go (Fail e) = return $ Fail e
297332 go (FailFatal e) = return $ FailFatal e