b3af5a8 · typeable/servant

git.iko.soy/typeable/servant

Move general authentication to Experimental module

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

commitb3af5a8d9592dab6b016f3d7f9ec18253db10bb4 authoraaron levin <aaron.levin@soundcloud.com> dateSun 6 Mar 2016, 22:23 (11 years ago) parent29f8e64

14 files changed+94−74

compare with master

unifiedsplit

servant-client/servant-client.cabal+1−1 servant-client/src/Servant/Client.hs+1−1 servant-client/src/Servant/Common/Auth.hs → servant-client/src/Servant/Client/Experimental/Auth.hs+1−1 servant-client/test/Servant/ClientSpec.hs+7−6 servant-examples/auth-combinator/auth-combinator.hs+1 servant-server/servant-server.cabal+2−2 servant-server/src/Servant/Server.hs+3−3 servant-server/src/Servant/Server/Experimental/Auth.hs+66 servant-server/src/Servant/Server/Internal.hs+2−20 servant-server/src/Servant/Server/Internal/Auth.hs−32 servant-server/test/Servant/ServerSpec.hs+2−2 servant/servant.cabal+1−1 servant/src/Servant/API.hs+6−4 servant/src/Servant/Experimental/API/Auth.hs → servant/src/Servant/API/Experimental/Auth.hs+1−1

servant-client/servant-client.cabal+1−1

@@ -27,7 +27,7 @@ source-repository head

2727library

2828 exposed-modules:

2929 Servant.Client

30− Servant.Common.Auth

30+ Servant.Client.Experimental.Auth

3131 Servant.Common.BaseUrl

3232 Servant.Common.BasicAuth

3333 Servant.Common.Req

servant-client/src/Servant/Client.hs+1−1

@@ -39,7 +39,7 @@ import Network.HTTP.Media

3939import qualified Network.HTTP.Types as H

4040import qualified Network.HTTP.Types.Header as HTTP

4141import Servant.API

42−import Servant.Common.Auth

42+import Servant.Client.Experimental.Auth

4343import Servant.Common.BaseUrl

4444import Servant.Common.BasicAuth

4545import Servant.Common.Req

servant-client/src/Servant/Common/Auth.hs → servant-client/src/Servant/Client/Experimental/Auth.hsrenamed+1−1

@@ -4,7 +4,7 @@

55-- | Authentication for clients

7−module Servant.Common.Auth (

7+module Servant.Client.Experimental.Auth (

88 AuthenticateReq(AuthenticateReq, unAuthReq)

99 , AuthClientData

1010 , mkAuthenticateReq

servant-client/test/Servant/ClientSpec.hs+7−6

@@ -55,6 +55,7 @@ import Servant.API

5555import Servant.API.Internal.Test.ComprehensiveAPI

5656import Servant.Client

5757import Servant.Server

58+import Servant.Server.Experimental.Auth

5859import qualified Servant.Common.Req as SCR

5960

6061-- This declaration simply checks that all instances are in place.

@@ -169,11 +170,11 @@ basicAuthHandler =

169170 else return Unauthorized

170171 in BasicAuthCheck check

171172

172−serverContext :: Context '[ BasicAuthCheck () ]

173−serverContext = basicAuthHandler :. EmptyContext

173+basicServerContext :: Context '[ BasicAuthCheck () ]

174+basicServerContext = basicAuthHandler :. EmptyContext

174175

175176basicAuthServer :: Application

176−basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice))

177+basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))

177178

178179-- * general auth stuff

179180

@@ -193,11 +194,11 @@ genAuthHandler =

193194 Just _ -> return ()

194195 in mkAuthHandler handler

195196

196−serverConfig :: Config '[ AuthHandler Request () ]

197−serverConfig = genAuthHandler :. EmptyConfig

197+genAuthServerContext :: Context '[ AuthHandler Request () ]

198+genAuthServerContext = genAuthHandler :. EmptyContext

198199

199200genAuthServer :: Application

200−genAuthServer = serve genAuthAPI serverConfig (const (return alice))

201+genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))

201202

202203{-# NOINLINE manager #-}

203204manager :: C.Manager

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

@@ -20,6 +20,7 @@ import GHC.Generics

2020import Network.Wai

2121import Network.Wai.Handler.Warp

2222import Servant

23+import Servant.Server.Experimental.Auth

2324

2425-- | This file contains an authenticated server using servant's generalized

2526-- authentication support. Our basic authentication scheme is trivial: we

servant-server/servant-server.cabal+2−2

@@ -36,10 +36,10 @@ library

3636 exposed-modules:

3737 Servant

3838 Servant.Server

39+ Servant.Server.Experimental.Auth

3940 Servant.Server.Internal

40− Servant.Server.Internal.Context

41− Servant.Server.Internal.Auth

4241 Servant.Server.Internal.BasicAuth

42+ Servant.Server.Internal.Context

4343 Servant.Server.Internal.Enter

4444 Servant.Server.Internal.Router

4545 Servant.Server.Internal.RoutingApplication

servant-server/src/Servant/Server.hs+3−3

@@ -50,9 +50,9 @@ module Servant.Server

5050 , BasicAuthResult(..)

5151

5252 -- * General Authentication

53− , AuthHandler(unAuthHandler)

54− , AuthServerData

55− , mkAuthHandler

53+ -- , AuthHandler(unAuthHandler)

54+ -- , AuthServerData

55+ -- , mkAuthHandler

5656

5757 -- * Default error type

5858 , ServantErr(..)

servant-server/src/Servant/Server/Experimental/Auth.hsnew file+66

@@ -0,0 +1,66 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DeriveDataTypeable #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+

13+module Servant.Server.Experimental.Auth where

14+

15+import Control.Monad.Trans.Except (ExceptT,

16+ runExceptT)

17+import Data.Proxy (Proxy (Proxy))

18+import Data.Typeable (Typeable)

19+import GHC.Generics (Generic)

20+import Network.Wai (Request)

21+

22+import Servant ((:>))

23+import Servant.API.Experimental.Auth

24+import Servant.Server.Internal (HasContextEntry,

25+ HasServer, ServerT,

26+ getContextEntry,

27+ route)

28+import Servant.Server.Internal.Router (Router' (WithRequest))

29+import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),

30+ addAuthCheck)

31+import Servant.Server.Internal.ServantErr (ServantErr)

32+

33+-- * General Auth

34+

35+-- | Specify the type of data returned after we've authenticated a request.

36+-- quite often this is some `User` datatype.

37+--

38+-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

39+type family AuthServerData a :: *

40+

41+-- | Handlers for AuthProtected resources

42+--

43+-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

44+newtype AuthHandler r usr = AuthHandler

45+ { unAuthHandler :: r -> ExceptT ServantErr IO usr }

46+ deriving (Generic, Typeable)

47+

48+-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

49+mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr

50+mkAuthHandler = AuthHandler

51+

52+-- | Known orphan instance.

53+instance ( HasServer api context

54+ , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))

55+ )

56+ => HasServer (AuthProtect tag :> api) context where

57+

58+ type ServerT (AuthProtect tag :> api) m =

59+ AuthServerData (AuthProtect tag) -> ServerT api m

60+

61+ route Proxy context subserver = WithRequest $ \ request ->

62+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)

63+ where

64+ authHandler = unAuthHandler (getContextEntry context)

65+ authCheck = fmap (either FailFatal Route) . runExceptT . authHandler

66+

servant-server/src/Servant/Server/Internal.hs+2−20

@@ -10,13 +10,11 @@

1010{-# LANGUAGE ScopedTypeVariables #-}

1111{-# LANGUAGE TypeFamilies #-}

1212{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

1413

1514#include "overlapping-compat.h"

1615

1716module Servant.Server.Internal

1817 ( module Servant.Server.Internal

19− , module Servant.Server.Internal.Auth

2018 , module Servant.Server.Internal.Context

2119 , module Servant.Server.Internal.BasicAuth

2220 , module Servant.Server.Internal.Router

@@ -27,7 +25,7 @@ module Servant.Server.Internal

2725#if !MIN_VERSION_base(4,8,0)

2826import Control.Applicative ((<$>))

2927#endif

30−import Control.Monad.Trans.Except (ExceptT, runExceptT)

28+import Control.Monad.Trans.Except (ExceptT)

3129import qualified Data.ByteString as B

3230import qualified Data.ByteString.Char8 as BC8

3331import qualified Data.ByteString.Lazy as BL

@@ -52,7 +50,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe,

5250 parseQueryParamMaybe,

5351 parseUrlPieceMaybe)

5452

55−import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture,

53+import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

5654 Verb, ReflectMethod(reflectMethod),

5755 IsSecure(..), Header,

5856 QueryFlag, QueryParam, QueryParams,

@@ -66,7 +64,6 @@ import Servant.API.ContentTypes (AcceptHeader (..),

6664import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

6765 getResponse)

6866

69−import Servant.Server.Internal.Auth

7067import Servant.Server.Internal.Context

7168import Servant.Server.Internal.BasicAuth

7269import Servant.Server.Internal.Router

@@ -456,8 +453,6 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where

456453 route Proxy context subserver = WithRequest $ \req ->

457454 route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)

458455

459−-- * Basic Authentication

460−

461456-- | Basic Authentication

462457instance ( KnownSymbol realm

463458 , HasServer api context

@@ -487,19 +482,6 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP

487482

488483-- * General Authentication

489484

490−instance ( HasServer api context

491− , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))

492− )

493− => HasServer (AuthProtect tag :> api) context where

494−

495− type ServerT (AuthProtect tag :> api) m =

496− AuthServerData (AuthProtect tag) -> ServerT api m

497−

498− route Proxy context subserver = WithRequest $ \ request ->

499− route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)

500− where

501− authHandler = unAuthHandler (getContextEntry context)

502− authCheck = fmap (either FailFatal Route) . runExceptT . authHandler

503485

504486-- * contexts

505487

servant-server/src/Servant/Server/Internal/Auth.hsdeleted−32

@@ -1,32 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE OverloadedStrings #-}

5−{-# LANGUAGE TypeFamilies #-}

6−

7−module Servant.Server.Internal.Auth where

8−

9−import Control.Monad.Trans.Except (ExceptT)

10−import Data.Typeable (Typeable)

11−import GHC.Generics (Generic)

12−

13−import Servant.Server.Internal.ServantErr (ServantErr)

14−

15−-- * General Auth

16−

17−-- | Specify the type of data returned after we've authenticated a request.

18−-- quite often this is some `User` datatype.

19−--

20−-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

21−type family AuthServerData a :: *

22−

23−-- | Handlers for AuthProtected resources

24−--

25−-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

26−newtype AuthHandler r usr = AuthHandler

27− { unAuthHandler :: r -> ExceptT ServantErr IO usr }

28− deriving (Generic, Typeable)

29−

30−-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

31−mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr

32−mkAuthHandler = AuthHandler

servant-server/test/Servant/ServerSpec.hs+2−2

@@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect,

4949 Raw, RemoteHost, ReqBody,

5050 StdMethod (..), Verb, addHeader)

5151import Servant.API.Internal.Test.ComprehensiveAPI

52−import Servant.Server (ServantErr (..), Server, err404,

52+import Servant.Server (ServantErr (..), Server, err401, err404,

5353 serve, serveWithContext, Context((:.), EmptyContext))

5454import Test.Hspec (Spec, context, describe, it,

5555 shouldBe, shouldContain)

@@ -60,7 +60,7 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,

6060

6161import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),

6262 BasicAuthResult(Authorized,Unauthorized))

63−import Servant.Server.Internal.Auth

63+import Servant.Server.Experimental.Auth

6464 (AuthHandler, AuthServerData,

6565 mkAuthHandler)

6666import Servant.Server.Internal.RoutingApplication

servant/servant.cabal+1−1

@@ -30,6 +30,7 @@ library

3030 Servant.API.BasicAuth

3131 Servant.API.Capture

3232 Servant.API.ContentTypes

33+ Servant.API.Experimental.Auth

3334 Servant.API.Header

3435 Servant.API.HttpVersion

3536 Servant.API.Internal.Test.ComprehensiveAPI

@@ -43,7 +44,6 @@ library

4344 Servant.API.Vault

4445 Servant.API.Verbs

4546 Servant.API.WithNamedContext

46− Servant.API.Experimental.Auth

4747 Servant.Utils.Links

4848 build-depends:

4949 base >=4.7 && <5

servant/src/Servant/API.hs+6−4

@@ -40,9 +40,6 @@ module Servant.API (

4040 -- * Response Headers

4141 module Servant.API.ResponseHeaders,

4242

43− -- * General Authentication

44− module Servant.API.Auth,

45−

4643 -- * Untyped endpoints

4744 module Servant.API.Raw,

4845 -- | Plugging in a wai 'Network.Wai.Application', serving directories

@@ -51,6 +48,11 @@ module Servant.API (

5148 module Web.HttpApiData,

5249 -- | Classes and instances for types that can be converted to and from HTTP API data.

5350

51+

52+ -- * Experimental modules

53+ module Servant.API.Experimental.Auth,

54+ -- | General Authentication

55+

5456 -- * Utilities

5557 module Servant.Utils.Links,

5658 -- | Type-safe internal URIs

@@ -58,13 +60,13 @@ module Servant.API (

5860

5961import Servant.API.Alternative ((:<|>) (..))

6062import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))

61−import Servant.API.Auth (AuthProtect)

6263import Servant.API.Capture (Capture)

6364import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

6465 FromFormUrlEncoded (..), JSON,

6566 MimeRender (..), NoContent (NoContent),

6667 MimeUnrender (..), OctetStream,

6768 PlainText, ToFormUrlEncoded (..))

69+import Servant.API.Experimental.Auth (AuthProtect)

6870import Servant.API.Header (Header (..))

6971import Servant.API.HttpVersion (HttpVersion (..))

7072import Servant.API.IsSecure (IsSecure (..))

servant/src/Servant/Experimental/API/Auth.hs → servant/src/Servant/API/Experimental/Auth.hsrenamed+1−1

@@ -2,7 +2,7 @@

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE KindSignatures #-}

44{-# LANGUAGE PolyKinds #-}

5−module Servant.API.Auth where

5+module Servant.API.Experimental.Auth where

77import Data.Typeable (Typeable)