Add auth tests to servant-client

servant-client/src/Servant/Client.hs

@@ -15,8 +15,12 @@
 -- querying functions for each endpoint just from the type representing your
 -- API.
 module Servant.Client
-  ( client
+  ( AuthClientData
+  , AuthenticateReq(..)
+  , BasicAuthData(..)
+  , client
   , HasClient(..)
+  , mkAuthenticateReq
   , ServantError(..)
   , module Servant.Common.BaseUrl
   ) where

servant-client/test/Servant/ClientSpec.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE StandaloneDeriving     #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE UndecidableInstances   #-}
 {-# OPTIONS_GHC -fcontext-stack=100 #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -27,7 +28,7 @@ import           Control.Arrow              (left)
 import           Control.Concurrent         (forkIO, killThread, ThreadId)
 import           Control.Exception          (bracket)
 import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
-import           Data.Aeson
+import           Data.Aeson                 hiding ((.:))
 import           Data.Char                  (chr, isPrint)
 import           Data.Foldable              (forM_)
 import           Data.Monoid                hiding (getLast)
@@ -40,7 +41,7 @@ import           Network.HTTP.Media
 import           Network.HTTP.Types         (Status (..), badRequest400,
                                              methodGet, ok200, status400)
 import           Network.Socket
-import           Network.Wai                (Application, responseLBS)
+import           Network.Wai                (Application, Request, requestHeaders, responseLBS)
 import           Network.Wai.Handler.Warp
 import           System.IO.Unsafe           (unsafePerformIO)
 import           Test.Hspec
@@ -51,12 +52,14 @@ import           Test.QuickCheck
 import           Servant.API
 import           Servant.Client
 import           Servant.Server
+import qualified Servant.Common.Req as SCR
 
 spec :: Spec
 spec = describe "Servant.Client" $ do
     sucessSpec
     failSpec
     wrappedApiSpec
+    authSpec
 
 -- * test data types
 
@@ -106,9 +109,11 @@ type Api =
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
   :<|> "deleteContentType" :> Delete '[JSON] ()
+
 api :: Proxy Api
 api = Proxy
 
+
 server :: Application
 server = serve api EmptyConfig (
        return alice
@@ -143,6 +148,45 @@ failServer = serve failApi EmptyConfig (
   :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
  )
 
+--  auth stuff
+type AuthAPI =
+       BasicAuth "basic-tag" "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
+  :<|> AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
+
+authAPI :: Proxy AuthAPI
+authAPI = Proxy
+
+type instance AuthReturnType (AuthProtect "auth-tag") = ()
+type instance AuthClientData (AuthProtect "auth-tag") = ()
+
+basicAuthHandler :: BasicAuthCheck ()
+basicAuthHandler =
+  let check username password =
+        if username == "servant" && password == "server"
+        then return (Authorized ())
+        else return Unauthorized
+  in BasicAuthCheck check
+
+authHandler :: AuthHandler Request ()
+authHandler =
+  let handler req = case lookup "AuthHeader" (requestHeaders req) of
+        Nothing -> throwE (err401 { errBody = "Missing auth header"
+                                  , errReasonPhrase = "denied!"
+                                  })
+        Just _ -> return ()
+  in mkAuthHandler handler
+
+serverConfig :: Config '[ ConfigEntry "basic-tag" (BasicAuthCheck ())
+                        , ConfigEntry "auth-tag" (AuthHandler Request ())
+                        ]
+serverConfig = basicAuthHandler .: authHandler .: EmptyConfig
+
+authServer :: Application
+authServer = serve authAPI serverConfig (const (return alice) :<|> const (return alice))
+
+{-
+     -}
+
 {-# NOINLINE manager #-}
 manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@@ -282,6 +326,36 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
           InvalidContentTypeHeader "fooooo" _ -> return ()
           _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
 
+authSpec :: Spec
+authSpec = beforeAll (startWaiApp authServer) $ afterAll endWaiApp $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let (getBasic :<|> _) = client authAPI baseUrl manager
+      let authData = BasicAuthData "servant" "server"
+      (left show <$> runExceptT (getBasic authData)) `shouldReturn` Right alice
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+      let (_ :<|> getProtected) = client authAPI baseUrl manager
+      let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "AuthHeader" ("cool" :: String) req)
+      (left show <$> runExceptT (getProtected authRequest)) `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 authAPI baseUrl manager
+      let authData = BasicAuthData "not" "password"
+      Left FailureResponse{..} <- runExceptT (getBasic authData)
+      responseStatus `shouldBe` Status 403 "Forbidden"
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+      let (_ :<|> getProtected) = client authAPI baseUrl manager
+      let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "Wrong" ("header" :: String) req)
+      Left FailureResponse{..} <- runExceptT (getProtected authRequest)
+      responseStatus `shouldBe` (Status 401 "denied")
+
+-- * utils
+
 data WrappedApi where
   WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a
                  , HasCfg api '[], HasClient api
@@ -289,8 +363,6 @@ data WrappedApi where
     Proxy api -> WrappedApi
 
 
--- * utils
-
 startWaiApp :: Application -> IO (ThreadId, BaseUrl)
 startWaiApp app = do
     (port, socket) <- openTestSocket