23da487 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Add general auth support to servant-client

23da487aaron levin11 years ago

servant-client/servant-client.cabal+1

compare with master

unifiedsplit

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

27library

28 exposed-modules:

29 Servant.Client

30+ Servant.Common.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.Common.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/Common/Auth.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TypeSynonymInstances #-}

3+{-# LANGUAGE TypeFamilies #-}

5+-- | Authentication for clients

7+module Servant.Common.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+type family AuthClientData a :: *

19+

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

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

22+-- data to a request

23+newtype AuthenticateReq a =

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

25+

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

27+mkAuthenticateReq :: AuthClientData a

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

29+ -> AuthenticateReq a

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

servant-client/test/Servant/ClientSpec.hs+47−3

@@ -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,7 @@ 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 qualified Servant.Common.Req as SCR

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

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

58_ = client comprehensiveAPI

61_ = client comprehensiveAPI

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

63 failSpec

66 failSpec

64 wrappedApiSpec

67 wrappedApiSpec

65 basicAuthSpec

68 basicAuthSpec

69+ genAuthSpec

67-- * test data types

71-- * test data types

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

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

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

150 )

154 )

151

155

152−

153−-- * auth stuff

156+-- * basic auth stuff

154

157

155type BasicAuthAPI =

158type BasicAuthAPI =

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

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

@@ -172,6 +175,30 @@ serverContext = basicAuthHandler :. EmptyContext

172basicAuthServer :: Application

175basicAuthServer :: Application

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

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

174

177

178+-- * general auth stuff

179+

180+type GenAuthAPI =

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

182+

183+genAuthAPI :: Proxy GenAuthAPI

184+genAuthAPI = Proxy

185+

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

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

188+

189+genAuthHandler :: AuthHandler Request ()

190+genAuthHandler =

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

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

193+ Just _ -> return ()

194+ in mkAuthHandler handler

195+

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

197+serverConfig = genAuthHandler :. EmptyConfig

198+

199+genAuthServer :: Application

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

201+

175{-# NOINLINE manager #-}

202{-# NOINLINE manager #-}

176manager :: C.Manager

203manager :: C.Manager

177manager = unsafePerformIO $ C.newManager C.defaultManagerSettings

204manager = unsafePerformIO $ C.newManager C.defaultManagerSettings

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

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

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

334 responseStatus `shouldBe` Status 403 "Forbidden"

361 responseStatus `shouldBe` Status 403 "Forbidden"

335

362

363+genAuthSpec :: Spec

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

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

366+

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

368+ let getProtected = client genAuthAPI baseUrl manager

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

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

371+

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

373+

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

375+ let getProtected = client genAuthAPI baseUrl manager

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

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

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

379+

336-- * utils

380-- * utils

337

381

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

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