From 231124521c8f8338caa70460278ea2b220972cc6 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Fri, 9 Feb 2018 13:44:25 +0200
Subject: [PATCH] Make empty request path = slash. Fixes #781

---
 servant-client-core/servant-client-core.cabal |  9 ++-
 .../Servant/Client/Core/Internal/Request.hs   | 19 +++--
 .../Client/Core/Internal/HasClientSpec.hs     | 73 +++++++++++++++++++
 3 files changed, 92 insertions(+), 9 deletions(-)
 create mode 100644 servant-client-core/test/Servant/Client/Core/Internal/HasClientSpec.hs

diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal
index 5d0ce62f..a20b5f34 100644
--- a/servant-client-core/servant-client-core.cabal
+++ b/servant-client-core/servant-client-core.cabal
@@ -85,17 +85,22 @@ test-suite spec
   main-is:             Spec.hs
   other-modules:
       Servant.Client.Core.Internal.BaseUrlSpec
+      Servant.Client.Core.Internal.HasClientSpec
 
   -- Dependencies inherited from the library. No need to specify bounds.
   build-depends:
       base
     , base-compat
+    , bytestring
+    , servant
     , servant-client-core
+    , text
 
   -- Additonal dependencies
   build-depends:
-      deepseq    >= 1.3.0.2 && <1.5
-    , hspec      >= 2.4.4   && <2.5
+      deepseq    >= 1.3.0.2 && < 1.5
+    , free       >= 4.12.4  && < 5.1
+    , hspec      >= 2.4.4   && < 2.5
     , QuickCheck >= 2.10.1  && < 2.12
 
   build-tool-depends:
diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs
index 50aadda3..59b39b2a 100644
--- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs
+++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs
@@ -32,6 +32,7 @@ import           Network.HTTP.Types      (Header, HeaderName, HttpVersion,
 import           Web.HttpApiData         (ToHttpApiData, toEncodedUrlPiece,
                                           toHeader)
 
+
 -- | A type representing possible errors in a request
 --
 -- Note that this type substantially changed in 0.12.
@@ -79,18 +80,22 @@ newtype StreamingResponse = StreamingResponse { runStreamingResponse :: forall a
 -- A GET request to the top-level path
 defaultRequest :: Request
 defaultRequest = Request
-  { requestPath = ""
+  { requestPath        = "/"
   , requestQueryString = Seq.empty
-  , requestBody = Nothing
-  , requestAccept = Seq.empty
-  , requestHeaders = Seq.empty
+  , requestBody        = Nothing
+  , requestAccept      = Seq.empty
+  , requestHeaders     = Seq.empty
   , requestHttpVersion = http11
-  , requestMethod = methodGet
+  , requestMethod      = methodGet
   }
 
 appendToPath :: Text -> Request -> Request
-appendToPath p req
-  = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
+appendToPath p req = req { requestPath = path' }
+  where
+    path = requestPath req
+    path'
+        | Builder.toLazyByteString path == "/" = path <> toEncodedUrlPiece p
+        | otherwise                            = path <> "/" <> toEncodedUrlPiece p
 
 appendToQueryString :: Text       -- ^ param name
                     -> Maybe Text -- ^ param value
diff --git a/servant-client-core/test/Servant/Client/Core/Internal/HasClientSpec.hs b/servant-client-core/test/Servant/Client/Core/Internal/HasClientSpec.hs
new file mode 100644
index 00000000..d2d23d23
--- /dev/null
+++ b/servant-client-core/test/Servant/Client/Core/Internal/HasClientSpec.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE FlexibleContexts, DeriveFunctor, GeneralizedNewtypeDeriving, DataKinds, TypeOperators, OverloadedStrings #-}
+{-# OPTIONS_GHC -Werror #-}
+module Servant.Client.Core.Internal.HasClientSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Free (Free (..), liftF)
+import Servant.API
+import Servant.Client.Core
+import Data.Text (Text)
+import Data.Proxy (Proxy (..))
+import Servant.API.Internal.Test.ComprehensiveAPI
+import Test.Hspec
+
+import qualified Data.ByteString.Builder as B
+
+-- This declaration simply checks that all instances are in place.
+_ = client comprehensiveAPI
+
+spec :: Spec
+spec = describe "Servant.Client" $ do
+    issue781trailingSlashSpec
+
+type Issue781 = Get '[JSON] Text
+    :<|> "foo" :> "bar" :> Get '[JSON] Text 
+
+issue781 :: Proxy Issue781
+issue781 = Proxy
+
+issue781trailingSlashSpec :: Spec
+issue781trailingSlashSpec = describe "issue 781: trailing slash in baseurl" $ do
+    it "Empty request has / as a path" $ do
+        B.toLazyByteString . requestPath <$> matchSingleRequest emptyCli
+            `shouldBe` Just "/"
+
+    it "Path components are intercalated with /" $ do
+        B.toLazyByteString . requestPath <$> matchSingleRequest concatCli
+            `shouldBe` Just "/foo/bar"
+  where
+    emptyCli :<|> concatCli = client issue781
+
+-------------------------------------------------------------------------------
+-- Client
+-------------------------------------------------------------------------------
+
+client :: HasClient ClientM api => Proxy api -> Client ClientM api
+client api = api `clientIn` (Proxy :: Proxy ClientM)
+
+data ClientF a
+    = SingleRequest Request (Response -> a)
+    | StreamingRequest Request (StreamingResponse -> a)
+    | Throw ServantError
+  deriving (Functor)
+
+newtype ClientM a = ClientM { unClientM :: Free ClientF a }
+  deriving (Functor, Applicative, Monad)
+
+-- | Extract 'Request' from first 'SingleRequest'
+matchSingleRequest :: ClientM a -> Maybe Request
+matchSingleRequest (ClientM (Free (SingleRequest req _))) = Just req
+matchSingleRequest _ = Nothing
+
+instance RunClient ClientM where
+    runRequest req        = ClientM $ liftF $ SingleRequest req id
+    streamingRequest req  = ClientM $ liftF $ StreamingRequest req id
+    throwServantError err = ClientM $ liftF $ Throw err
+
+    -- catch is not algebraic
+    catchServantError x' handler = ClientM (go (unClientM x')) where
+        go x@(Pure _)         = x
+        go (Free (Throw err)) = unClientM (handler err)
+        go (Free f')          = Free (fmap go f')