Add basic-auth support to servant-client

servant-client/servant-client.cabal

@@ -28,11 +28,13 @@ library
   exposed-modules:
     Servant.Client
     Servant.Common.BaseUrl
+    Servant.Common.BasicAuth
     Servant.Common.Req
   build-depends:
       base >=4.7 && <5
     , aeson
     , attoparsec
+    , base64-bytestring
     , bytestring
     , exceptions
     , http-api-data >= 0.1  && < 0.3

servant-client/src/Servant/Client.hs

@@ -37,6 +37,7 @@ import qualified Network.HTTP.Types         as H
 import qualified Network.HTTP.Types.Header  as HTTP
 import           Servant.API
 import           Servant.Common.BaseUrl
+import           Servant.Common.BasicAuth
 import           Servant.Common.Req
 
 -- * Accessing APIs as a Client
@@ -424,6 +425,15 @@ instance HasClient subapi =>
   clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
 
 
+-- * Basic Authentication
+
+instance HasClient api => HasClient (BasicAuth realm usr :> api) where
+  type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
+
+  clientWithRoute Proxy req baseurl manager val =
+    clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager
+
+
 {- Note [Non-Empty Content Types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Rather than have

servant-client/src/Servant/Common/BasicAuth.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+-- | Basic Authentication for clients
+
+module Servant.Common.BasicAuth (
+    basicAuthReq
+  ) where
+
+import Data.ByteString.Base64 (encode)
+import Data.Monoid ((<>))
+import Data.Text.Encoding (decodeUtf8)
+import Servant.Common.Req (addHeader, Req)
+import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
+
+-- | Authenticate a request using Basic Authentication
+basicAuthReq :: BasicAuthData -> Req -> Req
+basicAuthReq (BasicAuthData user pass) req =
+    let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
+    in addHeader "Authorization" authText req

servant-client/test/Servant/ClientSpec.hs

@@ -62,6 +62,7 @@ spec = describe "Servant.Client" $ do
     sucessSpec
     failSpec
     wrappedApiSpec
+    basicAuthSpec
 
 -- * test data types
 
@@ -148,6 +149,29 @@ failServer = serve failApi (
   :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
  )
 
+
+-- * auth stuff
+
+type BasicAuthAPI =
+       BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
+
+basicAuthAPI :: Proxy BasicAuthAPI
+basicAuthAPI = Proxy
+
+basicAuthHandler :: BasicAuthCheck ()
+basicAuthHandler =
+  let check (BasicAuthData username password) =
+        if username == "servant" && password == "server"
+        then return (Authorized ())
+        else return Unauthorized
+  in BasicAuthCheck check
+
+serverConfig :: Config '[ BasicAuthCheck () ]
+serverConfig = basicAuthHandler :. EmptyConfig
+
+basicAuthServer :: Application
+basicAuthServer = serve basicAuthAPI serverConfig (const (return alice))
+
 {-# NOINLINE manager #-}
 manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@@ -292,6 +316,22 @@ data WrappedApi where
                  HasClient api, Client api ~ ExceptT ServantError IO ()) =>
     Proxy api -> WrappedApi
 
+basicAuthSpec :: Spec
+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let getBasic = client basicAuthAPI baseUrl manager
+      let basicAuthData = BasicAuthData "servant" "server"
+      (left show <$> runExceptT (getBasic basicAuthData)) `shouldReturn` Right alice
+
+  context "Authentication is rejected when requests are not authenticated properly" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let getBasic = client basicAuthAPI baseUrl manager
+      let basicAuthData = BasicAuthData "not" "password"
+      Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)
+      responseStatus `shouldBe` Status 403 "Forbidden"
 
 -- * utils