diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 124d6307..6fbb6642 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index d62515dc..e73c05a4 100644 --- a/servant-client/src/Servant/Client.hs +++ b/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 diff --git a/servant-client/src/Servant/Common/Auth.hs b/servant-client/src/Servant/Client/Experimental/Auth.hs similarity index 96% rename from servant-client/src/Servant/Common/Auth.hs rename to servant-client/src/Servant/Client/Experimental/Auth.hs index 9bcef932..a98d0b41 100644 --- a/servant-client/src/Servant/Common/Auth.hs +++ b/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 diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 0ee1ed01..0ad3b70e 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/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 () ] -serverContext = basicAuthHandler :. EmptyContext +basicServerContext :: Context '[ BasicAuthCheck () ] +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 () ] -serverConfig = genAuthHandler :. EmptyConfig +genAuthServerContext :: Context '[ AuthHandler Request () ] +genAuthServerContext = genAuthHandler :. EmptyContext genAuthServer :: Application -genAuthServer = serve genAuthAPI serverConfig (const (return alice)) +genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index bfa4b6ee..709efa0c 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/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 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index f15e7a45..6167a2b4 100644 --- a/servant-server/servant-server.cabal +++ b/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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index c88b1375..8eff9c66 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -50,9 +50,9 @@ module Servant.Server , BasicAuthResult(..) -- * General Authentication - , AuthHandler(unAuthHandler) - , AuthServerData - , mkAuthHandler + -- , AuthHandler(unAuthHandler) + -- , AuthServerData + -- , mkAuthHandler -- * Default error type , ServantErr(..) diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs new file mode 100644 index 00000000..1cc698fc --- /dev/null +++ b/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 + diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 37955122..c170de9b 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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 diff --git a/servant-server/src/Servant/Server/Internal/Auth.hs b/servant-server/src/Servant/Server/Internal/Auth.hs deleted file mode 100644 index f3428a93..00000000 --- a/servant-server/src/Servant/Server/Internal/Auth.hs +++ /dev/null @@ -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 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 04e6f407..0e17c022 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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 diff --git a/servant/servant.cabal b/servant/servant.cabal index fc2dec36..a66efbce 100644 --- a/servant/servant.cabal +++ b/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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index fc70272f..5ea7b480 100644 --- a/servant/src/Servant/API.hs +++ b/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 (..)) diff --git a/servant/src/Servant/Experimental/API/Auth.hs b/servant/src/Servant/API/Experimental/Auth.hs similarity index 90% rename from servant/src/Servant/Experimental/API/Auth.hs rename to servant/src/Servant/API/Experimental/Auth.hs index 0647b012..ce330287 100644 --- a/servant/src/Servant/Experimental/API/Auth.hs +++ b/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)