git.iko.soy/typeable/servant
on master help sign in
Add general auth support to servant-client
commit23da4879eff37dd2abf54009f954b7c42b714c0f authoraaron levin <aaron.levin@soundcloud.com> dateWed 17 Feb 2016, 21:45 (11 years ago) parent0461c46
4 files changed+90−4
compare with master
unifiedsplit
servant-client/servant-client.cabal+1 servant-client/src/Servant/Client.hs+12−1 servant-client/src/Servant/Common/Auth.hs+30 servant-client/test/Servant/ClientSpec.hs+47−3
servant-client/servant-client.cabal+1
@@ -27,6 +27,7 @@ source-repository head
2727library
2828 exposed-modules:
2929 Servant.Client
30+ Servant.Common.Auth
3031 Servant.Common.BaseUrl
3132 Servant.Common.BasicAuth
3233 Servant.Common.Req
servant-client/src/Servant/Client.hs+12−1
@@ -15,8 +15,11 @@
1515-- querying functions for each endpoint just from the type representing your
1616-- API.
1717module Servant.Client
18− ( client
18+ ( AuthClientData
19+ , AuthenticateReq(..)
20+ , client
1921 , HasClient(..)
22+ , mkAuthenticateReq
2023 , ServantError(..)
2124 , module Servant.Common.BaseUrl
2225 ) where
@@ -36,6 +39,7 @@ import Network.HTTP.Media
3639import qualified Network.HTTP.Types as H
3740import qualified Network.HTTP.Types.Header as HTTP
3841import Servant.API
42+import Servant.Common.Auth
3943import Servant.Common.BaseUrl
4044import Servant.Common.BasicAuth
4145import Servant.Common.Req
@@ -424,6 +428,13 @@ instance HasClient subapi =>
424428 type Client (WithNamedContext name context subapi) = Client subapi
425429 clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
426430
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
427438
428439-- * Basic Authentication
429440
servant-client/src/Servant/Common/Auth.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TypeSynonymInstances #-}
3+{-# LANGUAGE TypeFamilies #-}
4+
5+-- | Authentication for clients
6+
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 @@
1212{-# LANGUAGE RecordWildCards #-}
1313{-# LANGUAGE StandaloneDeriving #-}
1414{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE TypeFamilies #-}
1516{-# LANGUAGE TypeOperators #-}
1617{-# LANGUAGE UndecidableInstances #-}
1718{-# OPTIONS_GHC -fcontext-stack=100 #-}
@@ -41,7 +42,8 @@ import Network.HTTP.Media
4142import Network.HTTP.Types (Status (..), badRequest400,
4243 methodGet, ok200, status400)
4344import Network.Socket
44−import Network.Wai (Application, responseLBS)
45+import Network.Wai (Application, Request,
46+ requestHeaders, responseLBS)
4547import Network.Wai.Handler.Warp
4648import System.IO.Unsafe (unsafePerformIO)
4749import Test.Hspec
@@ -53,6 +55,7 @@ import Servant.API
5355import Servant.API.Internal.Test.ComprehensiveAPI
5456import Servant.Client
5557import Servant.Server
58+import qualified Servant.Common.Req as SCR
5659
5760-- This declaration simply checks that all instances are in place.
5861_ = client comprehensiveAPI
@@ -63,6 +66,7 @@ spec = describe "Servant.Client" $ do
6366 failSpec
6467 wrappedApiSpec
6568 basicAuthSpec
69+ genAuthSpec
6670
6771-- * test data types
6872
@@ -149,8 +153,7 @@ failServer = serve failApi (
149153 :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
150154 )
151155
152−
153−-- * auth stuff
156+-- * basic auth stuff
154157
155158type BasicAuthAPI =
156159 BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
@@ -172,6 +175,30 @@ serverContext = basicAuthHandler :. EmptyContext
172175basicAuthServer :: Application
173176basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice))
174177
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+
175202{-# NOINLINE manager #-}
176203manager :: C.Manager
177204manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@@ -333,6 +360,23 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
333360 Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)
334361 responseStatus `shouldBe` Status 403 "Forbidden"
335362
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+
336380-- * utils
337381
338382startWaiApp :: Application -> IO (ThreadId, BaseUrl)