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 32857ebef..e3c603429 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 956af6b8c..7d4809a2f 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 75257f348..1810e64d2 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"])