16e7234 · typeable/servant

servant-client/CHANGELOG.md+2

compare with master

unifiedsplit

@@ -9,6 +9,8 @@ HEAD

9* Client functions now consider any 2xx successful.

10* Remove matrix params.

11* Added support for Basic authentication

12+* Add generalized authentication support via the `AuthClientData` type family and

13+ `AuthenticateReq` data type

12

14

130.4.1

150.4.1

14-----

16-----

servant-client/servant-client.cabal+1

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

27library

28 exposed-modules:

29 Servant.Client

30+ Servant.Client.Experimental.Auth

30 Servant.Common.BaseUrl

31 Servant.Common.BaseUrl

31 Servant.Common.BasicAuth

32 Servant.Common.BasicAuth

32 Servant.Common.Req

33 Servant.Common.Req

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

@@ -15,8 +15,11 @@

15-- querying functions for each endpoint just from the type representing your

16-- API.

17module Servant.Client

18+ ( AuthClientData

19+ , AuthenticateReq(..)

18− ( client

20+ , client

19 , HasClient(..)

21 , HasClient(..)

22+ , mkAuthenticateReq

20 , ServantError(..)

23 , ServantError(..)

21 , module Servant.Common.BaseUrl

24 , module Servant.Common.BaseUrl

22 ) where

25 ) where

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

36import qualified Network.HTTP.Types as H

39import qualified Network.HTTP.Types as H

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

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

38import Servant.API

41import Servant.API

42+import Servant.Client.Experimental.Auth

39import Servant.Common.BaseUrl

43import Servant.Common.BaseUrl

40import Servant.Common.BasicAuth

44import Servant.Common.BasicAuth

41import Servant.Common.Req

45import Servant.Common.Req

@@ -424,6 +428,13 @@ instance HasClient subapi =>

424 type Client (WithNamedContext name context subapi) = Client subapi

428 type Client (WithNamedContext name context subapi) = Client subapi

425 clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

429 clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

426

430

431+instance ( HasClient api

432+ ) => HasClient (AuthProtect tag :> api) where

433+ type Client (AuthProtect tag :> api)

434+ = AuthenticateReq (AuthProtect tag) -> Client api

435+

436+ clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) =

437+ clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager

427

438

428-- * Basic Authentication

439-- * Basic Authentication

429

440

servant-client/src/Servant/Client/Experimental/Auth.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TypeSynonymInstances #-}

3+{-# LANGUAGE TypeFamilies #-}

4+

5+-- | Authentication for clients

6+

7+module Servant.Client.Experimental.Auth (

8+ AuthenticateReq(AuthenticateReq, unAuthReq)

9+ , AuthClientData

10+ , mkAuthenticateReq

11+ ) where

12+

13+import Servant.Common.Req (Req)

14+

15+-- | For a resource protected by authentication (e.g. AuthProtect), we need

16+-- to provide the client with some data used to add authentication data

17+-- to a request

18+--

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

20+type family AuthClientData a :: *

21+

22+-- | For better type inference and to avoid usage of a data family, we newtype

23+-- wrap the combination of some 'AuthClientData' and a function to add authentication

24+-- data to a request

25+--

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

27+newtype AuthenticateReq a =

28+ AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }

29+

30+-- | Handy helper to avoid wrapping datatypes in tuples everywhere.

31+--

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

33+mkAuthenticateReq :: AuthClientData a

34+ -> (AuthClientData a -> Req -> Req)

35+ -> AuthenticateReq a

36+mkAuthenticateReq val func = AuthenticateReq (val, func)

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

@@ -12,6 +12,7 @@

12{-# LANGUAGE RecordWildCards #-}

13{-# LANGUAGE StandaloneDeriving #-}

14{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE TypeOperators #-}

16{-# LANGUAGE TypeOperators #-}

16{-# LANGUAGE UndecidableInstances #-}

17{-# LANGUAGE UndecidableInstances #-}

17{-# OPTIONS_GHC -fcontext-stack=100 #-}

18{-# OPTIONS_GHC -fcontext-stack=100 #-}

@@ -41,7 +42,8 @@ import Network.HTTP.Media

41import Network.HTTP.Types (Status (..), badRequest400,

42import Network.HTTP.Types (Status (..), badRequest400,

42 methodGet, ok200, status400)

43 methodGet, ok200, status400)

43import Network.Socket

44import Network.Socket

44−import Network.Wai (Application, responseLBS)

45+import Network.Wai (Application, Request,

46+ requestHeaders, responseLBS)

45import Network.Wai.Handler.Warp

47import Network.Wai.Handler.Warp

46import System.IO.Unsafe (unsafePerformIO)

48import System.IO.Unsafe (unsafePerformIO)

47import Test.Hspec

49import Test.Hspec

@@ -53,6 +55,8 @@ import Servant.API

53import Servant.API.Internal.Test.ComprehensiveAPI

55import Servant.API.Internal.Test.ComprehensiveAPI

54import Servant.Client

56import Servant.Client

55import Servant.Server

57import Servant.Server

58+import Servant.Server.Experimental.Auth

59+import qualified Servant.Common.Req as SCR

56

60

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

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

58_ = client comprehensiveAPI

62_ = client comprehensiveAPI

@@ -63,6 +67,7 @@ spec = describe "Servant.Client" $ do

63 failSpec

67 failSpec

64 wrappedApiSpec

68 wrappedApiSpec

65 basicAuthSpec

69 basicAuthSpec

70+ genAuthSpec

66

71

67-- * test data types

72-- * test data types

68

73

@@ -149,8 +154,7 @@ failServer = serve failApi (

149 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")

154 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")

150 )

155 )

151

156

152−

153−-- * auth stuff

157+-- * basic auth stuff

154

158

155type BasicAuthAPI =

159type BasicAuthAPI =

156 BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person

160 BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person

@@ -166,11 +170,35 @@ basicAuthHandler =

166 else return Unauthorized

170 else return Unauthorized

167 in BasicAuthCheck check

171 in BasicAuthCheck check

168

172

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

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

170−serverContext = basicAuthHandler :. EmptyContext

174+basicServerContext = basicAuthHandler :. EmptyContext

171

175

172basicAuthServer :: Application

176basicAuthServer :: Application

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

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

178+

179+-- * general auth stuff

180+

181+type GenAuthAPI =

182+ AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person

183+

184+genAuthAPI :: Proxy GenAuthAPI

185+genAuthAPI = Proxy

186+

187+type instance AuthServerData (AuthProtect "auth-tag") = ()

188+type instance AuthClientData (AuthProtect "auth-tag") = ()

189+

190+genAuthHandler :: AuthHandler Request ()

191+genAuthHandler =

192+ let handler req = case lookup "AuthHeader" (requestHeaders req) of

193+ Nothing -> throwE (err401 { errBody = "Missing auth header" })

194+ Just _ -> return ()

195+ in mkAuthHandler handler

196+

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

198+genAuthServerContext = genAuthHandler :. EmptyContext

199+

200+genAuthServer :: Application

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

174

202

175{-# NOINLINE manager #-}

203{-# NOINLINE manager #-}

176manager :: C.Manager

204manager :: C.Manager

@@ -333,6 +361,23 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d

333 Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)

361 Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)

334 responseStatus `shouldBe` Status 403 "Forbidden"

362 responseStatus `shouldBe` Status 403 "Forbidden"

335

363

364+genAuthSpec :: Spec

365+genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

366+ context "Authentication works when requests are properly authenticated" $ do

367+

368+ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

369+ let getProtected = client genAuthAPI baseUrl manager

370+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)

371+ (left show <$> runExceptT (getProtected authRequest)) `shouldReturn` Right alice

372+

373+ context "Authentication is rejected when requests are not authenticated properly" $ do

374+

375+ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

376+ let getProtected = client genAuthAPI baseUrl manager

377+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)

378+ Left FailureResponse{..} <- runExceptT (getProtected authRequest)

379+ responseStatus `shouldBe` (Status 401 "Unauthorized")

380+

336-- * utils

381-- * utils

337

382

338startWaiApp :: Application -> IO (ThreadId, BaseUrl)

383startWaiApp :: Application -> IO (ThreadId, BaseUrl)

servant-examples/auth-combinator/auth-combinator.hs+89−61

@@ -9,56 +9,54 @@

9{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE UndecidableInstances #-}

11

12+import Control.Monad.Trans.Except (ExceptT, throwE)

12−import Data.Aeson

13+import Data.Aeson hiding ((.:))

13−import Data.ByteString (ByteString)

14+import Data.ByteString (ByteString)

14−import Data.IORef

15+import Data.Monoid ((<>))

15−import Data.Text (Text)

16+import Data.Map (Map, fromList)

17+import qualified Data.Map as Map

18+import Data.Text (Text)

16import GHC.Generics

19import GHC.Generics

17import Network.Wai

20import Network.Wai

18import Network.Wai.Handler.Warp

21import Network.Wai.Handler.Warp

19import Servant

22import Servant

20−import Servant.Server.Internal

23+import Servant.Server.Experimental.Auth

21−

24+

22−-- Pretty much stolen/adapted from

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

23−-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs

26+-- authentication support. Our basic authentication scheme is trivial: we

24−

27+-- look for a cookie named "servant-auth-cookie" and its value will contain

25−type DBConnection = IORef [ByteString]

28+-- a key, which we use to lookup a User. Obviously this is an absurd example,

26−type DBLookup = DBConnection -> ByteString -> IO Bool

29+-- but we pick something simple and non-standard to show you how to extend

27−

30+-- servant's support for authentication.

28−initDB :: IO DBConnection

31+

29−initDB = newIORef ["good password"]

32+-- | A user type that we "fetch from the database" after

30−

33+-- performing authentication

31−isGoodCookie :: DBLookup

34+newtype User = User { unUser :: Text }

32−isGoodCookie ref password = do

35+

33− allowed <- readIORef ref

36+-- | A (pure) database mapping keys to users.

34− return (password `elem` allowed)

37+database :: Map ByteString User

35−

38+database = fromList [ ("key1", User "Anne Briggs")

36−data AuthProtected

39+ , ("key2", User "Bruce Cockburn")

37−

40+ , ("key3", User "Ghédalia Tazartès")

38−instance (HasContextEntry context DBConnection, HasServer rest context)

41+ ]

39− => HasServer (AuthProtected :> rest) context where

42+

40−

43+-- | A method that, when given a password, will return a User.

41− type ServerT (AuthProtected :> rest) m = ServerT rest m

44+-- This is our bespoke (and bad) authentication logic.

42−

45+lookupUser :: ByteString -> ExceptT ServantErr IO User

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

46+lookupUser key = case Map.lookup key database of

44− route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request

47+ Nothing -> throwE (err403 { errBody = "Invalid Cookie" })

45− where

48+ Just usr -> return usr

49+

50+-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User

51+-- we look for a Cookie and pass the value of the cookie to `lookupUser`.

52+authHandler :: AuthHandler Request User

53+authHandler =

46− cookieCheck req = case lookup "Cookie" (requestHeaders req) of

54+ let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of

47− Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }

55+ Nothing -> throwE (err401 { errBody = "Missing auth header" })

48− Just v -> do

56+ Just authCookieKey -> lookupUser authCookieKey

49− let dbConnection = getContextEntry context

57+ in mkAuthHandler handler

50− authGranted <- isGoodCookie dbConnection v

58+

51− if authGranted

59+-- | Data types that will be returned from various api endpoints

52− then return $ Route ()

53− else return $ FailFatal err403 { errBody = "Invalid cookie" }

54−

55−type PrivateAPI = Get '[JSON] [PrivateData]

56−

57−type PublicAPI = Get '[JSON] [PublicData]

58−

59−type API = "private" :> AuthProtected :> PrivateAPI

60− :<|> PublicAPI

61−

62newtype PrivateData = PrivateData { ssshhh :: Text }

60newtype PrivateData = PrivateData { ssshhh :: Text }

63 deriving (Eq, Show, Generic)

61 deriving (Eq, Show, Generic)

64

62

@@ -69,28 +67,58 @@ newtype PublicData = PublicData { somedata :: Text }

69

67

70instance ToJSON PublicData

68instance ToJSON PublicData

71

69

70+-- | Our private API that we want to be auth-protected.

71+type PrivateAPI = Get '[JSON] [PrivateData]

72+

73+-- | Our public API that doesn't have any protection

74+type PublicAPI = Get '[JSON] [PublicData]

75+

76+-- | Our API, with auth-protection

77+type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI

78+ :<|> "public" :> PublicAPI

79+

80+-- | A value holding our type-level API

72api :: Proxy API

81api :: Proxy API

73api = Proxy

82api = Proxy

74

83

84+-- | We need to specify the data returned after authentication

85+type instance AuthServerData (AuthProtect "cookie-auth") = User

86+

87+-- | The context that will be made available to request handlers. We supply the

88+-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance

89+-- of 'AuthProtect' can extract the handler and run it on the request.

90+serverContext :: Context (AuthHandler Request User ': '[])

91+serverContext = authHandler :. EmptyContext

92+

93+-- | Our API, where we provide all the author-supplied handlers for each end

94+-- point. Note that 'privateDataFunc' is a function that takes 'User' as an

95+-- argument. We dont' worry about the authentication instrumentation here,

96+-- that is taken care of by supplying context

75server :: Server API

97server :: Server API

76−server = return prvdata :<|> return pubdata

98+server = privateDataFunc :<|> return publicData

77

99

100+ where privateDataFunc (User name) =

78− where prvdata = [PrivateData "this is a secret"]

101+ return [PrivateData ("this is a secret: " <> name)]

79− pubdata = [PublicData "this is a public piece of data"]

102+ publicData = [PublicData "this is a public piece of data"]

80

103

104+-- | run our server

81main :: IO ()

105main :: IO ()

82−main = do

83− dbConnection <- initDB

84− let context = dbConnection :. EmptyContext

85− run 8080 (serveWithContext api context server)

106+main = run 8080 (serveWithContext api serverContext server)

107+

108+{- Sample Session:

109+

110+$ curl -XGET localhost:8080/private

111+Missing auth header

112+>>>>>>> modify auth-combinator example for gen auth

113+>>>>>>> 8246c1f... modify auth-combinator example for gen auth

86

114

87−{- Sample session:

115+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"

116+[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]

117+

118+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"

119+Invalid Cookie

120+

88−$ curl http://localhost:8080/

121+$ curl -XGET localhost:8080/public

89[{"somedata":"this is a public piece of data"}]

122[{"somedata":"this is a public piece of data"}]

90−$ curl http://localhost:8080/private

91−Missing auth header.

92−$ curl -H "Cookie: good password" http://localhost:8080/private

93−[{"ssshhh":"this is a secret"}]

94−$ curl -H "Cookie: bad password" http://localhost:8080/private

95−Invalid cookie.

96-}

123-}

124+

servant-examples/servant-examples.cabal+2

@@ -112,10 +112,12 @@ executable auth-combinator

112 aeson >= 0.8

113 , base >= 4.7 && < 5

114 , bytestring

115+ , containers

115 , http-types

116 , http-types

116 , servant == 0.5.*

117 , servant == 0.5.*

117 , servant-server == 0.5.*

118 , servant-server == 0.5.*

118 , text

119 , text

120+ , transformers

119 , wai

121 , wai

120 , warp

122 , warp

121 hs-source-dirs: auth-combinator

123 hs-source-dirs: auth-combinator

servant-server/CHANGELOG.md+1

@@ -12,6 +12,7 @@ HEAD

12* Redefined constructors of `RouteResult`.

13* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)

14* Added support for Basic Authentication

15+* Add generalized authentication support via the `AuthServerData` type family and `AuthHandler` handler

15

16

160.4.1

170.4.1

17-----

18-----

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

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

36 exposed-modules:

37 Servant

38 Servant.Server

39+ Servant.Server.Experimental.Auth

39 Servant.Server.Internal

40 Servant.Server.Internal

40− Servant.Server.Internal.Context

41 Servant.Server.Internal.BasicAuth

42+ Servant.Server.Internal.Context

42 Servant.Server.Internal.Enter

43 Servant.Server.Internal.Enter

43 Servant.Server.Internal.Router

44 Servant.Server.Internal.Router

44 Servant.Server.Internal.RoutingApplication

45 Servant.Server.Internal.RoutingApplication

servant-server/src/Servant/Server.hs+5−1

@@ -45,11 +45,15 @@ module Servant.Server

45 , NamedContext(..)

46 , descendIntoNamedContext

47

48−

49 -- * Basic Authentication

48 -- * Basic Authentication

50 , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)

49 , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)

51 , BasicAuthResult(..)

50 , BasicAuthResult(..)

52

51

52+ -- * General Authentication

53+ -- , AuthHandler(unAuthHandler)

54+ -- , AuthServerData

55+ -- , mkAuthHandler

56+

53 -- * Default error type

57 -- * Default error type

54 , ServantErr(..)

58 , ServantErr(..)

55 -- ** 3XX

59 -- ** 3XX

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+3−2

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

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

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

455

456−-- * Basic Authentication

457−

458-- | Basic Authentication

456-- | Basic Authentication

459instance ( KnownSymbol realm

457instance ( KnownSymbol realm

460 , HasServer api context

458 , HasServer api context

@@ -482,6 +480,9 @@ pathIsEmpty = go . pathInfo

482ct_wildcard :: B.ByteString

480ct_wildcard :: B.ByteString

483ct_wildcard = "*" <> "/" <> "*" -- Because CPP

481ct_wildcard = "*" <> "/" <> "*" -- Because CPP

484

482

483+-- * General Authentication

484+

485+

485-- * contexts

486-- * contexts

486

487

487instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)

488instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)

servant-server/test/Servant/ServerSpec.hs+42−4

@@ -31,14 +31,15 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,

31 methodHead, methodPatch,

32 methodPost, methodPut, ok200,

33 parseQuery)

34−import Network.Wai (Application, Request, pathInfo,

34+import Network.Wai (Application, Request, requestHeaders, pathInfo,

35 queryString, rawQueryString,

36 responseBuilder, responseLBS)

37import Network.Wai.Internal (Response (ResponseBuilder))

38import Network.Wai.Test (defaultRequest, request,

39 runSession, simpleBody,

40 simpleHeaders, simpleStatus)

41+import Servant.API ((:<|>) (..), (:>), AuthProtect,

41−import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData),

42+ BasicAuth, BasicAuthData(BasicAuthData),

42 Capture, Delete, Get, Header (..),

43 Capture, Delete, Get, Header (..),

43 Headers, HttpVersion,

44 Headers, HttpVersion,

44 IsSecure (..), JSON,

45 IsSecure (..), JSON,

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

48 Raw, RemoteHost, ReqBody,

49 Raw, RemoteHost, ReqBody,

49 StdMethod (..), Verb, addHeader)

50 StdMethod (..), Verb, addHeader)

50import Servant.API.Internal.Test.ComprehensiveAPI

51import Servant.API.Internal.Test.ComprehensiveAPI

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

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

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

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

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

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

54 shouldBe, shouldContain)

55 shouldBe, shouldContain)

@@ -59,6 +60,9 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,

59

60

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

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

61 BasicAuthResult(Authorized,Unauthorized))

62 BasicAuthResult(Authorized,Unauthorized))

63+import Servant.Server.Experimental.Auth

64+ (AuthHandler, AuthServerData,

65+ mkAuthHandler)

62import Servant.Server.Internal.RoutingApplication

66import Servant.Server.Internal.RoutingApplication

63 (toApplication, RouteResult(..))

67 (toApplication, RouteResult(..))

64import Servant.Server.Internal.Router

68import Servant.Server.Internal.Router

@@ -90,6 +94,7 @@ spec = do

90 routerSpec

94 routerSpec

91 miscCombinatorSpec

95 miscCombinatorSpec

92 basicAuthSpec

96 basicAuthSpec

97+ genAuthSpec

93

98

94------------------------------------------------------------------------------

99------------------------------------------------------------------------------

95-- * verbSpec {{{

100-- * verbSpec {{{

@@ -534,7 +539,7 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $

534

539

535-- }}}

540-- }}}

536------------------------------------------------------------------------------

541------------------------------------------------------------------------------

537−-- * Authentication {{{

542+-- * Basic Authentication {{{

538------------------------------------------------------------------------------

543------------------------------------------------------------------------------

539

544

540type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal

545type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal

@@ -564,6 +569,39 @@ basicAuthSpec = do

564 it "returns 200 with the right password" $ do

569 it "returns 200 with the right password" $ do

565 THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200

570 THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200

566

571

572+-- }}}

573+------------------------------------------------------------------------------

574+-- * General Authentication {{{

575+------------------------------------------------------------------------------

576+

577+type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal

578+authApi :: Proxy GenAuthAPI

579+authApi = Proxy

580+authServer :: Server GenAuthAPI

581+authServer = const (return tweety)

582+

583+type instance AuthServerData (AuthProtect "auth") = ()

584+

585+genAuthContext :: Context '[ AuthHandler Request () ]

586+genAuthContext =

587+ let authHandler = (\req ->

588+ if elem ("Auth", "secret") (requestHeaders req)

589+ then return ()

590+ else throwE err401

591+ )

592+ in mkAuthHandler authHandler :. EmptyContext

593+

594+genAuthSpec :: Spec

595+genAuthSpec = do

596+ describe "Servant.API.Auth" $ do

597+ with (return (serveWithContext authApi genAuthContext authServer)) $ do

598+

599+ context "Custom Auth Protection" $ do

600+ it "returns 401 when missing headers" $ do

601+ get "/auth" `shouldRespondWith` 401

602+ it "returns 200 with the right header" $ do

603+ THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200

604+

567-- }}}

605-- }}}

568------------------------------------------------------------------------------

606------------------------------------------------------------------------------

569-- * Test data types {{{

607-- * Test data types {{{

servant/CHANGELOG.md+1

@@ -11,6 +11,7 @@ HEAD

11* Add new `Verbs` combinator, and make all existing and new verb combinators

12type synonyms of it.

13* Add `BasicAuth` combinator to support Basic authentication

14+* Add generalized authentication support

14

15

150.4.2

160.4.2

16-----

17-----

servant/servant.cabal+1

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

30 Servant.API.BasicAuth

31 Servant.API.Capture

32 Servant.API.ContentTypes

33+ Servant.API.Experimental.Auth

33 Servant.API.Header

34 Servant.API.Header

34 Servant.API.HttpVersion

35 Servant.API.HttpVersion

35 Servant.API.Internal.Test.ComprehensiveAPI

36 Servant.API.Internal.Test.ComprehensiveAPI

servant/src/Servant/API.hs+6

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

48 module Web.HttpApiData,

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

50

51+

52+ -- * Experimental modules

53+ module Servant.API.Experimental.Auth,

54+ -- | General Authentication

55+

51 -- * Utilities

56 -- * Utilities

52 module Servant.Utils.Links,

57 module Servant.Utils.Links,

53 -- | Type-safe internal URIs

58 -- | Type-safe internal URIs

@@ -61,6 +66,7 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,

61 MimeRender (..), NoContent (NoContent),

66 MimeRender (..), NoContent (NoContent),

62 MimeUnrender (..), OctetStream,

67 MimeUnrender (..), OctetStream,

63 PlainText, ToFormUrlEncoded (..))

68 PlainText, ToFormUrlEncoded (..))

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

64import Servant.API.Header (Header (..))

70import Servant.API.Header (Header (..))

65import Servant.API.HttpVersion (HttpVersion (..))

71import Servant.API.HttpVersion (HttpVersion (..))

66import Servant.API.IsSecure (IsSecure (..))

72import Servant.API.IsSecure (IsSecure (..))

servant/src/Servant/API/Experimental/Auth.hsnew file+14

@@ -0,0 +1,14 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE PolyKinds #-}

5+module Servant.API.Experimental.Auth where

6+

7+import Data.Typeable (Typeable)

8+

9+-- | A generalized Authentication combinator. Use this if you have a

10+-- non-standard authentication technique.

11+--

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

13+data AuthProtect (tag :: k) deriving (Typeable)

14+