Make empty request path = slash. Fixes #781

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:

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,7 +80,7 @@ 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
@@ -89,8 +90,12 @@ defaultRequest = Request
   }
 
 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

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')