@@ -1,4 +1,5 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
23{-# LANGUAGE GeneralizedNewtypeDeriving #-}
34{-# LANGUAGE OverloadedStrings #-}
45{-# LANGUAGE TypeOperators #-}
@@ -6,21 +7,17 @@ module Servant.Server.Internal.RoutingApplication where
67
78#if !MIN_VERSION_base(4,8,0)
89import Control.Applicative (Applicative, (<$>))
9−import Data.Monoid (Monoid, mappend, mempty)
10+import Data.Monoid (Monoid, mappend, mempty,
11+ (<>))
1012#endif
1113import Control.Monad.Trans.Except (ExceptT, runExceptT)
1214import qualified Data.ByteString as B
1315import qualified Data.ByteString.Lazy as BL
1416import Data.IORef (newIORef, readIORef,
1517 writeIORef)
16−import Data.Maybe (fromMaybe)
17−import Data.Monoid ((<>))
18−import Data.String (fromString)
19−import Network.HTTP.Types hiding (Header,
20− ResponseHeaders)
2118import Network.Wai (Application, Request,
2219 Response, ResponseReceived,
23− requestBody, responseLBS,
20+ requestBody,
2421 strictRequestBody)
2522import Servant.API ((:<|>) (..))
2623import Servant.Server.Internal.ServantErr
@@ -30,39 +27,12 @@ type RoutingApplication =
3027 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
3128
3229-- | A wrapper around @'Either' 'RouteMismatch' a@.
33−newtype RouteResult a =
34− RR { routeResult :: Either RouteMismatch a }
35− deriving (Eq, Show, Functor, Applicative)
36−
37−-- | If we get a `Right`, it has precedence over everything else.
38−--
39−-- This in particular means that if we could get several 'Right's,
40−-- only the first we encounter would be taken into account.
41−instance Monoid (RouteResult a) where
42− mempty = RR $ Left mempty
43−
44− RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
45− RR (Left _) `mappend` RR (Right y) = RR $ Right y
46− r `mappend` _ = r
47−
48−-- Note that the ordering of the constructors has great significance! It
49−-- determines the Ord instance and, consequently, the monoid instance.
50−data RouteMismatch =
51− NotFound -- ^ the usual "not found" error
52− | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
53− | UnsupportedMediaType -- ^ request body has unsupported media type
54− | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
55− | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
56− deriving (Eq, Ord, Show)
57−
58−instance Monoid RouteMismatch where
59− mempty = NotFound
60− -- The following isn't great, since it picks @InvalidBody@ based on
61− -- alphabetical ordering, but any choice would be arbitrary.
62− --
63− -- "As one judge said to the other, 'Be just and if you can't be just, be
64− -- arbitrary'" -- William Burroughs
65− mappend = max
30+data RouteResult a =
31+ Retriable ServantErr -- ^ Keep trying other paths. The @ServantErr@
32+ -- should only be 404 or 405.
33+ | NonRetriable ServantErr -- ^ Stop trying.
34+ | HandlerVal a
35+ deriving (Eq, Show, Read, Functor)
6636
6737data ReqBodyState = Uncalled
6838 | Called !B.ByteString
@@ -91,55 +61,52 @@ toApplication ra request respond = do
9161 writeIORef reqBodyRef $ Called bs
9262 return B.empty
9363
94− ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
64+ ra request{ requestBody = memoReqBody } routingRespond
9565 where
96− routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
97− routingRespond (Left NotFound) =
98− respond $ responseLBS notFound404 [] "not found"
99− routingRespond (Left WrongMethod) =
100− respond $ responseLBS methodNotAllowed405 [] "method not allowed"
101− routingRespond (Left (InvalidBody err)) =
102− respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
103− routingRespond (Left UnsupportedMediaType) =
104− respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
105− routingRespond (Left (HttpError status body)) =
106− respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
107− routingRespond (Right response) =
108− respond response
66+ routingRespond :: RouteResult Response -> IO ResponseReceived
67+ routingRespond (Retriable err) = respond $! responseServantErr err
68+ routingRespond (NonRetriable err) = respond $! responseServantErr err
69+ routingRespond (HandlerVal v) = respond v
10970
11071runAction :: IO (RouteResult (ExceptT ServantErr IO a))
11172 -> (RouteResult Response -> IO r)
11273 -> (a -> RouteResult Response)
11374 -> IO r
114−runAction action respond k = do
115− r <- action
116− go r
75+runAction action respond k = action >>= go >>= respond
11776 where
118− go (RR (Right a)) = do
77+ go (Retriable e) = return $! Retriable e
78+ go (NonRetriable e) = return . succeedWith $! responseServantErr e
79+ go (HandlerVal a) = do
11980 e <- runExceptT a
120− respond $ case e of
121− Right x -> k x
122− Left err -> succeedWith $ responseServantErr err
123− go (RR (Left err)) = respond $ failWith err
81+ case e of
82+ Left err -> return . succeedWith $! responseServantErr err
83+ Right x -> return $! k x
12484
12585feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
12686feedTo f x = (($ x) <$>) <$> f
12787
12888extractL :: RouteResult (a :<|> b) -> RouteResult a
129−extractL (RR (Right (a :<|> _))) = RR (Right a)
130−extractL (RR (Left err)) = RR (Left err)
89+extractL (HandlerVal (a :<|> _)) = HandlerVal a
90+extractL (Retriable x) = Retriable x
91+extractL (NonRetriable x) = NonRetriable x
13192
13293extractR :: RouteResult (a :<|> b) -> RouteResult b
133−extractR (RR (Right (_ :<|> b))) = RR (Right b)
134−extractR (RR (Left err)) = RR (Left err)
94+extractR (HandlerVal (_ :<|> b)) = HandlerVal b
95+extractR (Retriable x) = Retriable x
96+extractR (NonRetriable x) = NonRetriable x
97+
98+-- | Fail with a @ServantErr@, but keep trying other paths and.
99+failWith :: ServantErr -> RouteResult a
100+failWith = Retriable
135101
136−failWith :: RouteMismatch -> RouteResult a
137−failWith = RR . Left
102+-- | Fail with immediately @ServantErr@.
103+failFatallyWith :: ServantErr -> RouteResult a
104+failFatallyWith = NonRetriable
138105
106+-- | Return a value, and don't try other paths.
139107succeedWith :: a -> RouteResult a
140−succeedWith = RR . Right
108+succeedWith = HandlerVal
141109
142110isMismatch :: RouteResult a -> Bool
143−isMismatch (RR (Left _)) = True
111+isMismatch (Retriable _) = True
144112isMismatch _ = False
145−