Changes for #465 and #576

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 ()

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
 --

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" '[]]
+authCheck :: BasicAuthCheck String
-comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
+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 =

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