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 <$>