From ffeeffe7459625f6ca2c787551c4be9f63e55dee Mon Sep 17 00:00:00 2001
From: aaron levin <aaron.levin@soundcloud.com>
Date: Sat, 9 Jan 2016 17:34:27 +0100
Subject: [PATCH] Add auth support for servant-client

---
 servant-client/servant-client.cabal       |  3 ++
 servant-client/src/Servant/Client.hs      | 16 ++++++++++
 servant-client/src/Servant/Common/Auth.hs | 38 +++++++++++++++++++++++
 3 files changed, 57 insertions(+)
 create mode 100644 servant-client/src/Servant/Common/Auth.hs

diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal
index 087920dc..04765daf 100644
--- a/servant-client/servant-client.cabal
+++ b/servant-client/servant-client.cabal
@@ -27,6 +27,7 @@ source-repository head
 library
   exposed-modules:
     Servant.Client
+    Servant.Common.Auth
     Servant.Common.BaseUrl
     Servant.Common.Req
   build-depends:
@@ -34,6 +35,7 @@ library
     , aeson
     , attoparsec
     , bytestring
+    , base64-bytestring
     , exceptions
     , http-api-data >= 0.1  && < 0.3
     , http-client
@@ -68,6 +70,7 @@ test-suite spec
     , transformers-compat
     , aeson
     , bytestring
+    , base64-bytestring
     , deepseq
     , hspec == 2.*
     , http-client
diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index 4eac1b2d..c2f692d4 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -37,6 +37,7 @@ import           Network.HTTP.Media
 import qualified Network.HTTP.Types         as H
 import qualified Network.HTTP.Types.Header  as HTTP
 import           Servant.API
+import           Servant.Common.Auth
 import           Servant.Common.BaseUrl
 import           Servant.Common.Req
 
@@ -407,6 +408,21 @@ instance HasClient api => HasClient (IsSecure :> api) where
   clientWithRoute Proxy req baseurl manager =
     clientWithRoute (Proxy :: Proxy api) req baseurl manager
 
+instance HasClient api => HasClient (BasicAuth tag realm usr :> api) where
+  type Client (BasicAuth tag realm usr :> api) = BasicAuthData -> Client api
+
+  clientWithRoute Proxy req baseurl manager val =
+    clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager
+
+instance ( HasClient api
+         , AuthenticateClientRequest (AuthProtect tag)
+         ) => HasClient (AuthProtect tag :> api) where
+  type Client (AuthProtect tag :> api)
+    = ClientAuthType (AuthProtect tag) -> Client api
+
+  clientWithRoute Proxy req baseurl manager val =
+    clientWithRoute (Proxy :: Proxy api) (authReq val req) baseurl manager
+
 
 {- Note [Non-Empty Content Types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/servant-client/src/Servant/Common/Auth.hs b/servant-client/src/Servant/Common/Auth.hs
new file mode 100644
index 00000000..75a36881
--- /dev/null
+++ b/servant-client/src/Servant/Common/Auth.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+-- | Authentication for clients
+
+module Servant.Common.Auth (
+    AuthenticateClientRequest ( ClientAuthType, authReq )
+  , BasicAuthData (BasicAuthData, username, password)
+  , basicAuthReq
+  ) where
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Base64  (encode)
+import Data.Monoid ((<>))
+import Data.Text.Encoding (decodeUtf8)
+import Servant.Common.Req (addHeader, Req)
+
+
+-- | A simple datatype to hold data required to decorate a request
+data BasicAuthData = BasicAuthData { username :: ByteString
+                                   , password :: ByteString
+                                   }
+
+-- | 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
+
+-- | Class to represent the ability to authenticate a 'Request'
+-- object. For example, we may add special headers to the 'Request'.
+class AuthenticateClientRequest a where
+  data ClientAuthType a :: *
+  authReq :: ClientAuthType a -> Req -> Req