From 110196e23fbe2acb07d57cc22a2a97b0575d0c32 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Wed, 7 Oct 2015 21:07:07 +0200
Subject: [PATCH] Fix path concatenation, Eq instance, for BaseUrl

---
 servant-client/src/Servant/Common/BaseUrl.hs      | 11 +++++++++--
 servant-client/test/Servant/Common/BaseUrlSpec.hs | 10 ++++++----
 2 files changed, 15 insertions(+), 6 deletions(-)

diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs
index 03ca21ed..5c3c190a 100644
--- a/servant-client/src/Servant/Common/BaseUrl.hs
+++ b/servant-client/src/Servant/Common/BaseUrl.hs
@@ -32,12 +32,19 @@ data BaseUrl = BaseUrl
   , baseUrlHost   :: String   -- ^ host (eg "haskell.org")
   , baseUrlPort   :: Int      -- ^ port (eg 80)
   , baseUrlPath   :: String   -- ^ path (eg "/a/b/c")
-  } deriving (Show, Eq, Ord, Generic)
+  } deriving (Show, Ord, Generic)
+
+instance Eq BaseUrl where
+    BaseUrl a b c path == BaseUrl a' b' c' path'
+        = a == a' && b == b' && c == c' && s path == s path'
+        where s ('/':x) = x
+              s x       = x
 
 showBaseUrl :: BaseUrl -> String
 showBaseUrl (BaseUrl urlscheme host port path) =
-  schemeString ++ "//" ++ host ++ portString ++ path
+  schemeString ++ "//" ++ host ++ (portString </> path)
     where
+      a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
       schemeString = case urlscheme of
         Http  -> "http:"
         Https -> "https:"
diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client/test/Servant/Common/BaseUrlSpec.hs
index 788daa02..afe541ba 100644
--- a/servant-client/test/Servant/Common/BaseUrlSpec.hs
+++ b/servant-client/test/Servant/Common/BaseUrlSpec.hs
@@ -22,7 +22,9 @@ spec = do
     it "shows the path of a BaseUrl" $ do
       showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api"
     it "shows the path of an https BaseUrl" $ do
-      showBaseUrl (BaseUrl Https "foo.com" 80 "api") `shouldBe` "https://foo.com/api"
+      showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api"
+    it "handles leading slashes in path" $ do
+      showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api"
 
   describe "httpBaseUrl" $ do
     it "allows to construct default http BaseUrls" $ do
@@ -34,8 +36,8 @@ spec = do
         deepseq (fmap show (parse string )) True
 
     it "is the inverse of showBaseUrl" $ do
-      property $ \ baseUrl ->
-        counterexample (showBaseUrl baseUrl) $ parse (showBaseUrl baseUrl) === Just baseUrl
+      property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $
+        parse (showBaseUrl baseUrl) === Just baseUrl
 
     context "trailing slashes" $ do
       it "allows trailing slashes" $ do
@@ -55,7 +57,7 @@ spec = do
       parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")
 
     it "rejects ftp urls" $ do
-      (parse "ftp://foo.com") `shouldBe` Nothing
+      parse "ftp://foo.com" `shouldBe` Nothing
 
 instance Arbitrary BaseUrl where
   arbitrary = BaseUrl <$>