From d2f8e96012014bdab55201d015339481bf5be4d2 Mon Sep 17 00:00:00 2001
From: Amar <amar@capital-match.com>
Date: Fri, 22 Apr 2016 22:00:13 +0800
Subject: [PATCH] Implement `staticClient` which supplies a static argument to
 `Client a` structure

---
 servant-client/src/Servant/Client.hs      | 21 +++++++++++++++++++++
 servant-client/test/Servant/ClientSpec.hs |  5 +++++
 2 files changed, 26 insertions(+)

diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index ee27846c..98742d3e 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -8,7 +8,9 @@
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE MultiParamTypeClasses#-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 
 #include "overlapping-compat.h"
 -- | This module provides 'client' which can automatically generate
@@ -18,6 +20,7 @@ module Servant.Client
   ( AuthClientData
   , AuthenticateReq(..)
   , client
+  , staticClient
   , HasClient(..)
   , ClientM
   , mkAuthenticateReq
@@ -60,6 +63,24 @@ import           Servant.Common.Req
 client :: HasClient layout => Proxy layout -> Client layout
 client p = clientWithRoute p defReq
 
+newtype InjectArg arg = InjectArg { getInjectedArg :: arg }
+
+class HasArgument s arg result | s arg -> result, s result -> arg where
+  supplyArgument :: arg -> s -> result
+
+
+instance (HasArgument left arg left1, HasArgument right arg right1) => HasArgument (left :<|> right) arg (left1 :<|> right1) where
+  supplyArgument arg (left :<|> right) = supplyArgument arg left :<|> supplyArgument arg right
+
+instance (HasArgument rest arg rest') => HasArgument (a -> rest) arg (a -> rest') where
+  supplyArgument arg f = \a -> supplyArgument arg (f a)
+
+instance HasArgument  (arg -> rest) (InjectArg arg) rest where
+  supplyArgument (InjectArg arg) f = f arg
+
+staticClient :: (HasClient layout, HasArgument (Client layout) (InjectArg BaseUrl) result) => Proxy layout -> BaseUrl -> result
+staticClient p baseUrl = supplyArgument (InjectArg baseUrl) $ client p
+
 -- | This class lets us define how each API combinator
 -- influences the creation of an HTTP request. It's mostly
 -- an internal class, you can just use 'client'.
diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs
index c41b4093..7ae894b7 100644
--- a/servant-client/test/Servant/ClientSpec.hs
+++ b/servant-client/test/Servant/ClientSpec.hs
@@ -296,6 +296,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
             return $
               result === Right (cap, num, flag, body)
 
+    describe "staticClient" $ do
+      it "allows to pass in the BaseUrl to staticClient" $ \(_, baseUrl) -> do
+        let getGet' :: C.Manager -> ClientM Person
+            getGet' :<|> _ = staticClient api baseUrl
+        (left show <$> runExceptT (getGet' manager)) `shouldReturn` Right alice
 
 wrappedApiSpec :: Spec
 wrappedApiSpec = describe "error status codes" $ do