Move general authentication to Experimental module

Removes the UndecidableInstances extension in the module containing the
HasServer instances.

servant-client/servant-client.cabal

@@ -27,7 +27,7 @@ source-repository head
 library
   exposed-modules:
     Servant.Client
-    Servant.Common.Auth
+    Servant.Client.Experimental.Auth
     Servant.Common.BaseUrl
     Servant.Common.BasicAuth
     Servant.Common.Req

servant-client/src/Servant/Client.hs

@@ -39,7 +39,7 @@ import           Network.HTTP.Media
 import qualified Network.HTTP.Types         as H
 import qualified Network.HTTP.Types.Header  as HTTP
 import           Servant.API
-import           Servant.Common.Auth
+import           Servant.Client.Experimental.Auth
 import           Servant.Common.BaseUrl
 import           Servant.Common.BasicAuth
 import           Servant.Common.Req

servant-client/src/Servant/Client/Experimental/Auth.hs

@@ -4,7 +4,7 @@
 
 -- | Authentication for clients
 
-module Servant.Common.Auth (
+module Servant.Client.Experimental.Auth (
     AuthenticateReq(AuthenticateReq, unAuthReq)
   , AuthClientData
   , mkAuthenticateReq

servant-client/test/Servant/ClientSpec.hs

@@ -55,6 +55,7 @@ import           Servant.API
 import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Client
 import           Servant.Server
+import           Servant.Server.Experimental.Auth
 import qualified Servant.Common.Req         as SCR
 
 -- This declaration simply checks that all instances are in place.
@@ -169,11 +170,11 @@ basicAuthHandler =
         else return Unauthorized
   in BasicAuthCheck check
 
-serverContext :: Context '[ BasicAuthCheck () ]
+basicServerContext :: Context '[ BasicAuthCheck () ]
-serverContext = basicAuthHandler :. EmptyContext
+basicServerContext = basicAuthHandler :. EmptyContext
 
 basicAuthServer :: Application
-basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice))
+basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
 
 -- * general auth stuff
 
@@ -193,11 +194,11 @@ genAuthHandler =
         Just _ -> return ()
   in mkAuthHandler handler
 
-serverConfig :: Config '[ AuthHandler Request () ]
+genAuthServerContext :: Context '[ AuthHandler Request () ]
-serverConfig = genAuthHandler :. EmptyConfig
+genAuthServerContext = genAuthHandler :. EmptyContext
 
 genAuthServer :: Application
-genAuthServer = serve genAuthAPI serverConfig (const (return alice))
+genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
 
 {-# NOINLINE manager #-}
 manager :: C.Manager

servant-examples/auth-combinator/auth-combinator.hs

@@ -20,6 +20,7 @@ import           GHC.Generics
 import           Network.Wai
 import           Network.Wai.Handler.Warp
 import           Servant
+import           Servant.Server.Experimental.Auth
 
 -- | This file contains an authenticated server using servant's generalized
 -- authentication support. Our basic authentication scheme is trivial: we

servant-server/servant-server.cabal

@@ -36,10 +36,10 @@ library
   exposed-modules:
     Servant
     Servant.Server
+    Servant.Server.Experimental.Auth
     Servant.Server.Internal
-    Servant.Server.Internal.Context
-    Servant.Server.Internal.Auth
     Servant.Server.Internal.BasicAuth
+    Servant.Server.Internal.Context
     Servant.Server.Internal.Enter
     Servant.Server.Internal.Router
     Servant.Server.Internal.RoutingApplication

servant-server/src/Servant/Server.hs

@@ -50,9 +50,9 @@ module Servant.Server
   , BasicAuthResult(..)
 
   -- * General Authentication
-  , AuthHandler(unAuthHandler)
+  -- , AuthHandler(unAuthHandler)
-  , AuthServerData
+  -- , AuthServerData
-  , mkAuthHandler
+  -- , mkAuthHandler
 
     -- * Default error type
   , ServantErr(..)

servant-server/src/Servant/Server/Experimental/Auth.hs

@@ -0,0 +1,66 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+module Servant.Server.Experimental.Auth where
+
+import           Control.Monad.Trans.Except                 (ExceptT,
+                                                             runExceptT)
+import           Data.Proxy                                 (Proxy (Proxy))
+import           Data.Typeable                              (Typeable)
+import           GHC.Generics                               (Generic)
+import           Network.Wai                                (Request)
+
+import           Servant                                    ((:>))
+import           Servant.API.Experimental.Auth
+import           Servant.Server.Internal                    (HasContextEntry,
+                                                             HasServer, ServerT,
+                                                             getContextEntry,
+                                                             route)
+import           Servant.Server.Internal.Router             (Router' (WithRequest))
+import           Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),
+                                                             addAuthCheck)
+import           Servant.Server.Internal.ServantErr         (ServantErr)
+
+-- * 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 :: *
+
+-- | Handlers for AuthProtected resources
+--
+-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
+newtype AuthHandler r usr = AuthHandler
+  { unAuthHandler :: r -> ExceptT ServantErr IO usr }
+  deriving (Generic, Typeable)
+
+-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
+mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr
+mkAuthHandler = AuthHandler
+
+-- | Known orphan instance.
+instance ( HasServer api context
+         , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))
+         )
+  => HasServer (AuthProtect tag :> api) context where
+
+  type ServerT (AuthProtect tag :> api) m =
+    AuthServerData (AuthProtect tag) -> ServerT api m
+
+  route Proxy context subserver = WithRequest $ \ request ->
+    route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
+      where
+        authHandler = unAuthHandler (getContextEntry context)
+        authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
+

servant-server/src/Servant/Server/Internal.hs

@@ -10,13 +10,11 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
-{-# LANGUAGE UndecidableInstances       #-}
 
 #include "overlapping-compat.h"
 
 module Servant.Server.Internal
   ( module Servant.Server.Internal
-  , module Servant.Server.Internal.Auth
   , module Servant.Server.Internal.Context
   , module Servant.Server.Internal.BasicAuth
   , module Servant.Server.Internal.Router
@@ -27,7 +25,7 @@ module Servant.Server.Internal
 #if !MIN_VERSION_base(4,8,0)
 import           Control.Applicative         ((<$>))
 #endif
-import           Control.Monad.Trans.Except (ExceptT, runExceptT)
+import           Control.Monad.Trans.Except (ExceptT)
 import qualified Data.ByteString            as B
 import qualified Data.ByteString.Char8      as BC8
 import qualified Data.ByteString.Lazy       as BL
@@ -52,7 +50,7 @@ import           Web.HttpApiData.Internal   (parseHeaderMaybe,
                                              parseQueryParamMaybe,
                                              parseUrlPieceMaybe)
 
-import           Servant.API                 ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture,
+import           Servant.API                 ((:<|>) (..), (:>), BasicAuth, Capture,
                                               Verb, ReflectMethod(reflectMethod),
                                               IsSecure(..), Header,
                                               QueryFlag, QueryParam, QueryParams,
@@ -66,7 +64,6 @@ import           Servant.API.ContentTypes    (AcceptHeader (..),
 import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
                                               getResponse)
 
-import           Servant.Server.Internal.Auth
 import           Servant.Server.Internal.Context
 import           Servant.Server.Internal.BasicAuth
 import           Servant.Server.Internal.Router
@@ -456,8 +453,6 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where
   route Proxy context subserver = WithRequest $ \req ->
     route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
 
--- * Basic Authentication
-
 -- | Basic Authentication
 instance ( KnownSymbol realm
          , HasServer api context
@@ -487,19 +482,6 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP
 
 -- * General Authentication
 
-instance ( HasServer api context
-         , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))
-         )
-  => HasServer (AuthProtect tag :> api) context where
-
-  type ServerT (AuthProtect tag :> api) m =
-    AuthServerData (AuthProtect tag) -> ServerT api m
-
-  route Proxy context subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
-      where
-        authHandler = unAuthHandler (getContextEntry context)
-        authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
 
 -- * contexts
 

servant-server/src/Servant/Server/Internal/Auth.hs

@@ -1,32 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor      #-}
-{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE TypeFamilies       #-}
-
-module Servant.Server.Internal.Auth where
-
-import           Control.Monad.Trans.Except         (ExceptT)
-import           Data.Typeable                      (Typeable)
-import           GHC.Generics                       (Generic)
-
-import           Servant.Server.Internal.ServantErr (ServantErr)
-
--- * 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 :: *
-
--- | Handlers for AuthProtected resources
---
--- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
-newtype AuthHandler r usr = AuthHandler
-  { unAuthHandler :: r -> ExceptT ServantErr IO usr }
-  deriving (Generic, Typeable)
-
--- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
-mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr
-mkAuthHandler = AuthHandler

servant-server/test/Servant/ServerSpec.hs

@@ -49,7 +49,7 @@ import           Servant.API                ((:<|>) (..), (:>), AuthProtect,
                                              Raw, RemoteHost, ReqBody,
                                              StdMethod (..), Verb, addHeader)
 import           Servant.API.Internal.Test.ComprehensiveAPI
-import           Servant.Server             (ServantErr (..), Server, err404,
+import           Servant.Server             (ServantErr (..), Server, err401, err404,
                                              serve, serveWithContext, Context((:.), EmptyContext))
 import           Test.Hspec                 (Spec, context, describe, it,
                                              shouldBe, shouldContain)
@@ -60,7 +60,7 @@ import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
 
 import           Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),
                                                     BasicAuthResult(Authorized,Unauthorized))
-import           Servant.Server.Internal.Auth
+import           Servant.Server.Experimental.Auth
                                             (AuthHandler, AuthServerData,
                                              mkAuthHandler)
 import           Servant.Server.Internal.RoutingApplication

servant/servant.cabal

@@ -30,6 +30,7 @@ library
     Servant.API.BasicAuth
     Servant.API.Capture
     Servant.API.ContentTypes
+    Servant.API.Experimental.Auth
     Servant.API.Header
     Servant.API.HttpVersion
     Servant.API.Internal.Test.ComprehensiveAPI
@@ -43,7 +44,6 @@ library
     Servant.API.Vault
     Servant.API.Verbs
     Servant.API.WithNamedContext
-    Servant.API.Experimental.Auth
     Servant.Utils.Links
   build-depends:
       base >=4.7 && <5

servant/src/Servant/API.hs

@@ -40,9 +40,6 @@ module Servant.API (
   -- * Response Headers
   module Servant.API.ResponseHeaders,
 
-  -- * General Authentication
-  module Servant.API.Auth,
-
   -- * Untyped endpoints
   module Servant.API.Raw,
   -- | Plugging in a wai 'Network.Wai.Application', serving directories
@@ -51,6 +48,11 @@ module Servant.API (
   module Web.HttpApiData,
   -- | Classes and instances for types that can be converted to and from HTTP API data.
 
+
+  -- * Experimental modules
+  module Servant.API.Experimental.Auth,
+  -- | General Authentication
+
   -- * Utilities
   module Servant.Utils.Links,
   -- | Type-safe internal URIs
@@ -58,13 +60,13 @@ module Servant.API (
 
 import           Servant.API.Alternative     ((:<|>) (..))
 import           Servant.API.BasicAuth       (BasicAuth,BasicAuthData(..))
-import           Servant.API.Auth            (AuthProtect)
 import           Servant.API.Capture         (Capture)
 import           Servant.API.ContentTypes    (Accept (..), FormUrlEncoded,
                                               FromFormUrlEncoded (..), JSON,
                                               MimeRender (..), NoContent (NoContent),
                                               MimeUnrender (..), OctetStream,
                                               PlainText, ToFormUrlEncoded (..))
+import           Servant.API.Experimental.Auth (AuthProtect)
 import           Servant.API.Header          (Header (..))
 import           Servant.API.HttpVersion     (HttpVersion (..))
 import           Servant.API.IsSecure        (IsSecure (..))

servant/src/Servant/API/Experimental/Auth.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE KindSignatures     #-}
 {-# LANGUAGE PolyKinds          #-}
-module Servant.API.Auth where
+module Servant.API.Experimental.Auth where
 
 import           Data.Typeable (Typeable)