From bd9151b9de579e98d14add3328933d155df25fc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 14 Feb 2022 14:18:56 +0100 Subject: [PATCH] servant-auth-server: Support NamedRoutes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Trying to use `NamedRoutes` with `servant-auth-server` currently results in hideous error messages such as: ``` app/Main.hs:50:7: error: • No instance for (Servant.Auth.Server.Internal.AddSetCookie.AddSetCookies ('Servant.Auth.Server.Internal.AddSetCookie.S ('Servant.Auth.Server.Internal.AddSetCookie.S 'Servant.Auth.Server.Internal.AddSetCookie.Z)) (AdminRoutes (Servant.Server.Internal.AsServerT Handler)) (ServerT (Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi (Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi (NamedRoutes AdminRoutes))) Handler)) arising from a use of 'serveWithContext' • In the expression: serveWithContext (Proxy @API) ctx RootAPI {..} ``` This is because we didn't teach it how to recurse along `NamedRoutes` trees and sprinkle headers at the tip of each branch. This commit adds a test case and fixes the issue. In the process, it also implements `ThrowAll` for `NamedRoutes`, which was necessary for the test to run, and should also prove convenient for users. --- .../src/Servant/Auth/Server/Internal/AddSetCookie.hs | 12 ++++++++++++ .../src/Servant/Auth/Server/Internal/ThrowAll.hs | 11 ++++++++++- .../test/Servant/Auth/ServerSpec.hs | 7 +++++++ 3 files changed, 29 insertions(+), 1 deletion(-) diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs index 32857ebe..e3c60342 100644 --- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs @@ -11,6 +11,8 @@ import Data.Tagged (Tagged (..)) import qualified Network.HTTP.Types as HTTP import Network.Wai (mapResponseHeaders) import Servant +import Servant.API.Generic +import Servant.Server.Generic import Web.Cookie -- What are we doing here? Well, the idea is to add headers to the response, @@ -34,6 +36,7 @@ type family AddSetCookieApiVerb a where type family AddSetCookieApi a :: * type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b +type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api) type instance AddSetCookieApi (Verb method stat ctyps a) = Verb method stat ctyps (AddSetCookieApiVerb a) type instance AddSetCookieApi Raw = Raw @@ -72,6 +75,15 @@ instance {-# OVERLAPS #-} => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b +instance {-# OVERLAPS #-} + ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi + , Generic (api (AsServerT m)) + , GServantProduct (Rep (api (AsServerT m))) + , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + ) + => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where + addSetCookies cookies = addSetCookies cookies . toServant + -- | for @servant <0.11@ instance AddSetCookies ('S n) Application Application where diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs index 956af6b8..7d4809a2 100644 --- a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs @@ -8,7 +8,10 @@ module Servant.Auth.Server.Internal.ThrowAll where import Control.Monad.Error.Class import Data.Tagged (Tagged (..)) -import Servant ((:<|>) (..), ServerError(..)) +import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..)) +import Servant.API.Generic +import Servant.Server.Generic +import Servant.Server import Network.HTTP.Types import Network.Wai @@ -26,6 +29,12 @@ class ThrowAll a where instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where throwAll e = throwAll e :<|> throwAll e +instance + ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) => + ThrowAll (api (AsServerT m)) where + + throwAll = fromServant . throwAll + -- Really this shouldn't be necessary - ((->) a) should be an instance of -- MonadError, no? instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where diff --git a/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs index 75257f34..1810e64d 100644 --- a/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -50,6 +50,7 @@ import Network.Wreq (Options, auth, basicAuth, import Network.Wreq.Types (Postable(..)) import Servant hiding (BasicAuth, IsSecure (..), header) +import Servant.API.Generic ((:-)) import Servant.Auth.Server import Servant.Auth.Server.Internal.Cookie (expireTime) import Servant.Auth.Server.SetCookieOrphan () @@ -405,6 +406,7 @@ type API auths = Auth auths User :> ( Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int + :<|> NamedRoutes DummyRoutes :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int) #if MIN_VERSION_servant_server(0,15,0) :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) @@ -416,6 +418,10 @@ type API auths :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie , Header "Set-Cookie" SetCookie ] NoContent) +data DummyRoutes mode = DummyRoutes + { dummyInt :: mode :- "dummy" :> Get '[JSON] Int + } deriving Generic + jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) jwtOnlyApi = Proxy @@ -476,6 +482,7 @@ server ccfg = (\authResult -> case authResult of Authenticated usr -> getInt usr :<|> postInt usr + :<|> DummyRoutes { dummyInt = getInt usr } :<|> getHeaderInt #if MIN_VERSION_servant_server(0,15,0) :<|> return (S.source ["bytestring"])