diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index da7c763b..755c9f76 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -218,7 +218,10 @@ type GenAuthAPI = genAuthAPI :: Proxy GenAuthAPI genAuthAPI = Proxy -type instance AuthServerData (AuthProtect "auth-tag") = () +instance HasAuthServerData (AuthProtect "auth-tag") where + AuthServerData (AuthProtect "auth-tag") = () + +-- type instance AuthServerData (AuthProtect "auth-tag") = () type instance AuthClientData (AuthProtect "auth-tag") = () genAuthHandler :: AuthHandler Request () diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs index fd38ff1e..81c15f74 100644 --- a/servant-server/src/Servant/Server/Experimental/Auth.hs +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} module Servant.Server.Experimental.Auth where @@ -31,13 +32,21 @@ import Servant.Server.Internal.RoutingApplication (addAuthCheck, withRequest) import Servant.Server.Internal.ServantErr (Handler) +import GHC.TypeLits + -- * General Auth -- | Specify the type of data returned after we've authenticated a request. -- quite often this is some `User` datatype. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -type family AuthServerData a :: * +-- type family AuthServerData a :: * +class HasAuthServerData a where + +type AuthServerData a :: * + +instance {-# OVERLAPPING #-} HasAuthServerData a where + type AuthServerData a = TypeError ('Text "aha this should never occur") -- | Handlers for AuthProtected resources -- diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2337c258..f63f07ae 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -61,7 +61,7 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders, import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), BasicAuthResult(Authorized,Unauthorized)) import Servant.Server.Experimental.Auth - (AuthHandler, AuthServerData, + (AuthHandler, HasAuthServerData, AuthServerData, mkAuthHandler) import Servant.Server.Internal.Context (NamedContext(..)) @@ -71,8 +71,20 @@ import Servant.Server.Internal.Context -- This declaration simply checks that all instances are in place. _ = serveWithContext comprehensiveAPI comprehensiveApiContext -comprehensiveApiContext :: Context '[NamedContext "foo" '[]] -comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext +authCheck :: BasicAuthCheck String +authCheck = BasicAuthCheck check + where + check _ = return (Authorized "servant") + +authHandler :: AuthHandler Request String +authHandler = + let handler req = return "foo" + in mkAuthHandler handler + +-- type instance AuthServerData (AuthProtect "foo") = String + +comprehensiveApiContext :: Context '[AuthHandler Request String, BasicAuthCheck String, NamedContext "foo" '[]] +comprehensiveApiContext = authHandler :. authCheck :. NamedContext EmptyContext :. EmptyContext -- * Specs @@ -637,7 +649,8 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") -type instance AuthServerData (AuthProtect "auth") = () +instance {-# OVERLAPS #-} HasAuthServerData (AuthProtect "auth") where + type AuthServerData (AuthProtect "auth") = () genAuthContext :: Context '[AuthHandler Request ()] genAuthContext = diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index e7c15633..719b7d5c 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -36,8 +36,10 @@ type ComprehensiveAPIWithoutRaw = Vault :> GET :<|> Verb 'POST 204 '[JSON] NoContent :<|> Verb 'POST 204 '[JSON] Int :<|> + BasicAuth "foo" String :> GET :<|> WithNamedContext "foo" '[] GET :<|> - CaptureAll "foo" Int :> GET + CaptureAll "foo" Int :> GET :<|> + AuthProtect "foo" :> GET comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw comprehensiveAPIWithoutRaw = Proxy