From 1eeaec3685b5d496f0f168bbe868748869588a87 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Fri, 21 Aug 2026 17:51:52 +0200 Subject: [PATCH 1/2] Propagate failures of fromKeyValueParams This function will fail once we enforce the hosts to ports mapping rules. So, it needs to be able to communicate failure and force callers to deal with them. --- src/library/PostgresqlConnectionString/Parsers.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/library/PostgresqlConnectionString/Parsers.hs b/src/library/PostgresqlConnectionString/Parsers.hs index 79a3137..5af6402 100644 --- a/src/library/PostgresqlConnectionString/Parsers.hs +++ b/src/library/PostgresqlConnectionString/Parsers.hs @@ -78,10 +78,10 @@ getUriConnectionString = do getKeyValueConnectionString :: P ConnectionString getKeyValueConnectionString = - fromKeyValueParams <$> getKeyValueParams + fromKeyValueParams =<< getKeyValueParams -fromKeyValueParams :: Map.Map Text Text -> ConnectionString -fromKeyValueParams params = +fromKeyValueParams :: Map.Map Text Text -> P ConnectionString +fromKeyValueParams params = do -- Extract known connection parameters let user = Map.lookup "user" params password = Map.lookup "password" params @@ -112,7 +112,7 @@ fromKeyValueParams params = pairs = zipWith (\host mPort -> (host, mPort)) hostList portList' in map (\(host, mPortText) -> Host host (mPortText >>= parsePort)) pairs - in ConnectionString user password hosts dbname remainingParams + pure (ConnectionString user password hosts dbname remainingParams) where parsePort :: Text -> Maybe Word16 parsePort t = case reads (Text.unpack t) of From 7ea58b355b49802b987dd13c7c26346167bb62f7 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Thu, 20 Aug 2026 17:57:37 +0200 Subject: [PATCH 2/2] Fix port to host assignments according to the spec The cases for specified `port` values are: - 0: default port for all hosts - 1: specified port for all hosts - n: one port per host (counts must match) See https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-MULTIPLE-HOSTS --- src/library-tests/Main.hs | 121 ++++++++++++++++-- .../PostgresqlConnectionString/Parsers.hs | 37 ++++-- 2 files changed, 138 insertions(+), 20 deletions(-) diff --git a/src/library-tests/Main.hs b/src/library-tests/Main.hs index aa24bf7..ce742c1 100644 --- a/src/library-tests/Main.hs +++ b/src/library-tests/Main.hs @@ -442,16 +442,114 @@ main = hspec do Left err -> expectationFailure ("URL roundtrip parse error: " <> Text.unpack err) Right cs2 -> cs2 `shouldBe` cs + it "postgresql://a,b,c (default for all hosts)" do + let input = "postgresql://a,b,c" + case ConnectionString.parse input of + Left err -> expectationFailure (Text.unpack err) + Right cs -> + ConnectionString.toHosts cs + `shouldBe` [("a", Nothing), ("b", Nothing), ("c", Nothing)] + it "host=host1,host2,host3 port=1,2,3" do let input = "host=host1,host2,host3 port=1,2,3" case ConnectionString.parse input of Left err -> expectationFailure ("Parse error: " <> Text.unpack err) - Right cs -> do - -- In keyword/value format, multiple hosts are separated by commas in the value - -- This is a special case that may not be supported yet - -- For now, just verify it parses - let hosts = ConnectionString.toHosts cs - length hosts `shouldSatisfy` (> 0) + Right cs -> + ConnectionString.toHosts cs + `shouldBe` [("host1", Just 1), ("host2", Just 2), ("host3", Just 3)] + + it "host=a,b,c port=1,2,3 (don't depend on specific hostname pattern)" do + let input = "host=a,b,c port=1,2,3" + case ConnectionString.parse input of + Left err -> expectationFailure ("Parse error: " <> Text.unpack err) + Right cs -> + ConnectionString.toHosts cs + `shouldBe` [("a", Just 1), ("b", Just 2), ("c", Just 3)] + + it "host=host1,host2 port=1,2" do + let input = "host=host1,host2 port=1,2" + case ConnectionString.parse input of + Left err -> expectationFailure ("Parse error: " <> Text.unpack err) + Right cs -> + ConnectionString.toHosts cs `shouldBe` [("host1", Just 1), ("host2", Just 2)] + + it "host=host1,host2 port=1 (single port applies to all hosts)" do + let input = "host=host1,host2 port=1" + case ConnectionString.parse input of + Left err -> expectationFailure ("Parse error: " <> Text.unpack err) + Right cs -> + ConnectionString.toHosts cs `shouldBe` [("host1", Just 1), ("host2", Just 1)] + + it "host=host1,host2,host3 port=1 (single port applies to all hosts)" do + let input = "host=host1,host2,host3 port=1" + case ConnectionString.parse input of + Left err -> expectationFailure ("Parse error: " <> Text.unpack err) + Right cs -> + ConnectionString.toHosts cs `shouldBe` [("host1", Just 1), ("host2", Just 1), ("host3", Just 1)] + + it "host=a,b,c port=1 (don't depend on specific hostname pattern)" do + let input = "host=a,b,c port=1" + case ConnectionString.parse input of + Left err -> expectationFailure ("Parse error: " <> Text.unpack err) + Right cs -> + ConnectionString.toHosts cs `shouldBe` [("a", Just 1), ("b", Just 1), ("c", Just 1)] + + it "rejects host=host1,host2,host3 port=1,2 (port count mismatch)" do + let input = "host=host1,host2,host3 port=1,2" + case ConnectionString.parse input of + Left err -> Text.unpack err `shouldContain` "could not match 2 port numbers to 3 hosts" + Right _ -> expectationFailure "Expected port count mismatch to be rejected" + + it "rejects host=host1,host2 port=1,2,3 (port count mismatch)" do + let input = "host=host1,host2 port=1,2,3" + case ConnectionString.parse input of + Left err -> Text.unpack err `shouldContain` "could not match 3 port numbers to 2 hosts" + Right _ -> expectationFailure "Expected port count mismatch to be rejected" + + it "rejects port=1,2 without host (port count mismatch)" do + let input = "port=1,2" + case ConnectionString.parse input of + Left err -> Text.unpack err `shouldContain` "could not match 2 port numbers to 1 hosts" + Right _ -> expectationFailure "Expected port count mismatch to be rejected" + + it "host=a,b,c (default for all hosts)" do + let input = "host=a,b,c" + case ConnectionString.parse input of + Left err -> expectationFailure (Text.unpack err) + Right cs -> + ConnectionString.toHosts cs + `shouldBe` [("a", Nothing), ("b", Nothing), ("c", Nothing)] + + it "host=a,b port=,2 (leading empty item selects default)" do + let input = "host=a,b port=,2" + case ConnectionString.parse input of + Left err -> expectationFailure (Text.unpack err) + Right cs -> + ConnectionString.toHosts cs `shouldBe` [("a", Nothing), ("b", Just 2)] + + it "host=a,b,c port=1,,3 (middle empty item selects default)" do + let input = "host=a,b,c port=1,,3" + case ConnectionString.parse input of + Left err -> expectationFailure (Text.unpack err) + Right cs -> + ConnectionString.toHosts cs + `shouldBe` [("a", Just 1), ("b", Nothing), ("c", Just 3)] + + it "host=a,b,c port=1,, (trailing empty items select default)" do + let input = "host=a,b,c port=1,," + case ConnectionString.parse input of + Left err -> expectationFailure (Text.unpack err) + Right cs -> + ConnectionString.toHosts cs + `shouldBe` [("a", Just 1), ("b", Nothing), ("c", Nothing)] + + it "host=a,b port='' (empty string selects default)" do + let input = "host=a,b port=''" + case ConnectionString.parse input of + Left err -> expectationFailure (Text.unpack err) + Right cs -> + ConnectionString.toHosts cs + `shouldBe` [("a", Nothing), ("b", Nothing)] describe "equivalence tests of the internal representation" do it "postgresql://host1:1,host2:2,host3:3/ is equivalent to host=host1,host2,host3 port=1,2,3" do @@ -460,19 +558,22 @@ main = hspec do case (ConnectionString.parse url, ConnectionString.parse kv) of (Right cs1, Right cs2) -> do -- They should represent the same connection - -- At minimum, they should have the same number of hosts - length (ConnectionString.toHosts cs1) `shouldBe` length (ConnectionString.toHosts cs2) + let hosts1 = ConnectionString.toHosts cs1 + hosts2 = ConnectionString.toHosts cs2 + hosts1 `shouldBe` [("host1", Just 1), ("host2", Just 2), ("host3", Just 3)] + hosts1 `shouldBe` hosts2 (Left err, _) -> expectationFailure ("URL parse error: " <> Text.unpack err) (_, Left err) -> expectationFailure ("KV parse error: " <> Text.unpack err) - it "postgresql://host1:1,host2:2,host3/ is equivalent to host=host1,host2,host3 port=1,2" do + it "postgresql://host1:1,host2:2,host3/ is equivalent to host=host1,host2,host3 port=1,2," do let url = "postgresql://host1:1,host2:2,host3/" - kv = "host=host1,host2,host3 port=1,2" + kv = "host=host1,host2,host3 port=1,2," case (ConnectionString.parse url, ConnectionString.parse kv) of (Right cs1, Right cs2) -> do -- They should represent the same connection let hosts1 = ConnectionString.toHosts cs1 hosts2 = ConnectionString.toHosts cs2 + hosts1 `shouldBe` [("host1", Just 1), ("host2", Just 2), ("host3", Nothing)] hosts1 `shouldBe` hosts2 (Left err, _) -> expectationFailure ("URL parse error: " <> Text.unpack err) (_, Left err) -> expectationFailure ("KV parse error: " <> Text.unpack err) diff --git a/src/library/PostgresqlConnectionString/Parsers.hs b/src/library/PostgresqlConnectionString/Parsers.hs index 5af6402..f561423 100644 --- a/src/library/PostgresqlConnectionString/Parsers.hs +++ b/src/library/PostgresqlConnectionString/Parsers.hs @@ -3,7 +3,6 @@ module PostgresqlConnectionString.Parsers where import qualified Data.CharSet as CharSet -import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified PercentEncoding @@ -98,19 +97,37 @@ fromKeyValueParams params = do ) params - -- Parse hosts if present - handle comma-separated hosts and ports - hosts = case hostText of + -- Validate the port count against the host count. A single port applies to + -- all hosts; any other count must match exactly (mirrors libpq's "could not + -- match N port numbers to M hosts" error). + let hostCount = maybe 1 (length . Text.splitOn ",") hostText + case portText of + Just portValue -> + let portCount = length (Text.splitOn "," portValue) + in unless (portCount == 1 || portCount == hostCount) $ + fail + ( "could not match " + <> show portCount + <> " port numbers to " + <> show hostCount + <> " hosts" + ) + Nothing -> pure () + + -- Parse hosts if present - handle comma-separated hosts and ports + let hosts = case hostText of Nothing -> [] Just h -> let hostList = Text.splitOn "," h portList = maybe [] (Text.splitOn ",") portText - -- Pair up hosts with ports, padding with Nothing if needed - -- Exception: if just one port is provided, use it for all hosts - portList' - | length portList == 1 = repeat (fmap fst (List.uncons portList)) - | otherwise = (map Just portList) ++ repeat Nothing - pairs = zipWith (\host mPort -> (host, mPort)) hostList portList' - in map (\(host, mPortText) -> Host host (mPortText >>= parsePort)) pairs + -- A single port applies to all hosts; otherwise the lists match + -- in length. An absent port uses the default port for every + -- host. + ports = case portList of + [] -> repeat Nothing + [single] -> repeat (Just single) + list -> map Just list + in zipWith (\host mPortText -> Host host (mPortText >>= parsePort)) hostList ports pure (ConnectionString user password hosts dbname remainingParams) where