Merge pull request #1531 from gdeest/servant-auth-named-routes

servant-auth-server: Support NamedRoutes

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

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

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"])