diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index eee1d8d0..2223ca01 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -59,9 +59,6 @@ import Network.Wai (Application, import Servant.API ((:<|>) (..), (:>), Capture, Delete, Get, Header, IsSecure (Secure, NotSecure), - MatrixFlag, - MatrixParam, - MatrixParams, Patch, Post, Put, QueryFlag, QueryParam, @@ -73,7 +70,9 @@ import Servant.API.Authentication (AuthPolicy (Strict, AuthProtected) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), - AllCTUnrender (..)) + AllCTUnrender (..), + AllMime (..), + canHandleAcceptH) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, @@ -83,7 +82,6 @@ import Servant.Server.Internal.Authentication (AuthData (authData) checkAuthStrict, AuthHandlers(onMissingAuthData, onUnauthenticated)) -import Servant.Server.Internal.PathInfo import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr @@ -280,38 +278,38 @@ instance type ServerT (AuthProtect authdata usr 'Strict :> sublayout) m = AuthProtected authdata usr (usr -> ServerT sublayout m) 'Strict - route _ subserver = WithRequest $ \req -> - route (Proxy :: Proxy sublayout) $ do - -- Note: this may perform IO for each attempt at matching. +-- route :: Proxy (a :> s) -> Delayed (AuthProtected aData usr (usr -> servert) 'S) -> Router + route _ (Delayed _ _ _ m) = WithRequest $ \req -> + route (Proxy :: Proxy sublayout) $ addBodyCheck subserver $ case authData req of + + Nothing -> do + -- we're in strict mode: don't let the request go + -- call the provided "on missing auth" handler + resp <- onMissingAuthData (authHandlers authProtectionStrict) + return $ FailFatal resp + + + -- succesfully pulled auth data out of the Request + Just authData' -> do + mUsr <- (checkAuthStrict authProtectionStrict) authData' + case mUsr of + -- this user is not authenticated. + Nothing -> do + resp <- onUnauthenticated (authHandlers authProtectionStrict) authData' + return $ FailFatal resp + + -- this user is authenticated. + Just usr -> + (return . Route . subServerStrict authProtectionStrict) usr + rr <- routeResult <$> subserver case rr of -- Successful route match, so we extract the author-provided -- auth data. Right authProtectionStrict -> - case authData req of - -- could not pull authenticate data out of the request - Nothing -> do - -- we're in strict mode: don't let the request go - -- call the provided "on missing auth" handler - resp <- onMissingAuthData (authHandlers authProtectionStrict) - return $ failWith (RouteMismatch resp) - - -- succesfully pulled auth data out of the Request - Just authData' -> do - mUsr <- (checkAuthStrict authProtectionStrict) authData' - case mUsr of - -- this user is not authenticated. - Nothing -> do - resp <- onUnauthenticated (authHandlers authProtectionStrict) authData' - return $ failWith (RouteMismatch resp) - - -- this user is authenticated. - Just usr -> - (return . succeedWith . subServerStrict authProtectionStrict) usr - -- route did not match, propagate failure. Left rMismatch -> - return (failWith rMismatch) + return (Fail rMismatch) -- | Authentication in Lax mode. instance @@ -335,10 +333,10 @@ instance -- authentication on it. In Lax mode, we just pass `Maybe usr` -- to the autho. musr <- maybe (pure Nothing) (checkAuthLax authProtectionLax) (authData req) - (return . succeedWith . subServerLax authProtectionLax) musr + (return . Route . subServerLax authProtectionLax) musr -- route did not match, propagate failure Left rMismatch -> - return (failWith rMismatch) + return (Fail rMismatch) -- | When implementing the handler for a 'Get' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index bb1089d8..4b27c688 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -15,9 +15,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Maybe (fromMaybe) -import Data.String (fromString) -import Network.HTTP.Types hiding (ResponseHeaders) import Network.Wai (Application, Request, Response, ResponseReceived, requestBody, @@ -36,48 +33,6 @@ data RouteResult a = | Route !a deriving (Eq, Show, Read, Functor) --- Note that the ordering of the constructors has great significance! It --- determines the Ord instance and, consequently, the monoid instance. -data RouteMismatch = - NotFound -- ^ the usual "not found" error - | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error - | UnsupportedMediaType -- ^ request body has unsupported media type - | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error - | HttpError Status [Header] (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. - | RouteMismatch Response -- ^ an arbitrary mismatch with custom Response. - --- | specialized 'Less Than' for use with Monoid RouteMismatch -(<=:) :: RouteMismatch -> RouteMismatch -> Bool -{-# INLINE (<=:) #-} -NotFound <=: _ = True -WrongMethod <=: rmm = not (rmm <=: NotFound) -UnsupportedMediaType <=: rmm = not (rmm <=: WrongMethod) -InvalidBody _ <=: rmm = not (rmm <=: UnsupportedMediaType) -HttpError _ _ _ <=: rmm = not (rmm <=: (InvalidBody "")) -RouteMismatch _ <=: _ = False - -instance Monoid RouteMismatch where - mempty = NotFound - -- The following isn't great, since it picks @InvalidBody@ based on - -- alphabetical ordering, but any choice would be arbitrary. - -- - -- "As one judge said to the other, 'Be just and if you can't be just, be - -- arbitrary'" -- William Burroughs - -- - -- It used to be the case that `mappend = max` but getting rid of the `Eq` - -- and `Ord` instance meant we had to roll out our own max ;\ - rmm `mappend` NotFound = rmm - NotFound `mappend` rmm = rmm - WrongMethod `mappend` rmm | rmm <=: WrongMethod = WrongMethod - WrongMethod `mappend` rmm = rmm - UnsupportedMediaType `mappend` rmm | rmm <=: UnsupportedMediaType = UnsupportedMediaType - UnsupportedMediaType `mappend` rmm = rmm - i@(InvalidBody _) `mappend` rmm | rmm <=: i = i - InvalidBody _ `mappend` rmm = rmm - h@(HttpError _ _ _) `mappend` rmm | rmm <=: h = h - HttpError _ _ _ `mappend` rmm = rmm - r@(RouteMismatch _) `mappend` _ = r - data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString