eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Move general authentication to Experimental module

Browse source 
Removes the UndecidableInstances extension in the module containing the
HasServer instances.
This commit is contained in:
aaron levin 2016-03-06 22:23:55 +01:00
parent 29f8e64e1c
commit b3af5a8d95
14 changed files with 94 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
servant-client/servant-client.cabal
View file

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

2
servant-client/src/Servant/Client.hs
View file

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

2
servant-client/src/Servant/Common/Auth.hs → servant-client/src/Servant/Client/Experimental/Auth.hs
View file

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

13
servant-client/test/Servant/ClientSpec.hs
View file

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

1
servant-examples/auth-combinator/auth-combinator.hs
View file

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

4
servant-server/servant-server.cabal
View file

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

6
servant-server/src/Servant/Server.hs
View file

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

66
servant-server/src/Servant/Server/Experimental/Auth.hs Normal file
View file

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

22
servant-server/src/Servant/Server/Internal.hs
View file

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

32
servant-server/src/Servant/Server/Internal/Auth.hs
View file

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

4
servant-server/test/Servant/ServerSpec.hs
View file

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

2
servant/servant.cabal
View file

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

10
servant/src/Servant/API.hs
View file

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

2
servant/src/Servant/Experimental/API/Auth.hs → servant/src/Servant/API/Experimental/Auth.hs
View file

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