diff --git a/hpgsql-tests/LibPqConnStringParsingSpec.hs b/hpgsql-tests/LibPqConnStringParsingSpec.hs new file mode 100644 index 0000000..e5b7945 --- /dev/null +++ b/hpgsql-tests/LibPqConnStringParsingSpec.hs @@ -0,0 +1,389 @@ +module LibPqConnStringParsingSpec + ( spec, + ) +where + +import Control.Monad (forM_) +import qualified Data.Char as Char +import Data.Hashable (Hashable, hash) +import Data.List (sortOn) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) +import Data.Word (Word16) +import Hedgehog (Gen, forAll, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Hpgsql.Connection (ConnectionString (..), parseLibpqConnectionString, renderLibpqConnectionString) +import Network.URI + ( URI (..), + URIAuth (..), + escapeURIString, + isUnescapedInURIComponent, + uriToString, + ) +import Test.Hspec +import Test.Hspec.Hedgehog (hedgehog) + +-- This test suite was copied over from my other project, codd, and changed to use +-- hedgehog instead of quickcheck, plus a few tests removed because they didn't make sense here. +-- It would be nice to produce "options" fields for the connection strings too, these tests still +-- produce them as empty. + +spec :: Spec +spec = do + describe "Connection string parsing" $ do + it "Some hard coded connection strings" $ do + -- These are hard coded connection strings that I've tested with psql at some point + let stringsAndExpectedConnInfos = + [ ( "postgresql://postgres@localhost/some%20thing%20%2F%3F%3A%40", + ConnectionString + { hostname = "localhost", + port = 5432, + user = "postgres", + password = "", + database = "some thing /?:@", + options = "" + } + ), + ( "postgresql://some%20thing%20%2F%3F%3A%40:passwdsome%20thing%20%2F%3F%3A%40@localhost:1/some%20thing%20%2F%3F%3A%40", + ConnectionString + { hostname = "localhost", + port = 1, + user = "some thing /?:@", + password = "passwdsome thing /?:@", + database = "some thing /?:@", + options = "" + } + ), + -- Only mandatory arguments + ( "postgresql://postgres@[::1]/somedb", + ConnectionString + { hostname = "::1", + port = 5432, + user = "postgres", + password = "", + database = "somedb", + options = "" + } + ), + ( "dbname='some thing /?:@' user='some thing /?:@' host = localhost ", + ConnectionString + { hostname = "localhost", + port = 5432, + user = "some thing /?:@", + password = "", + database = "some thing /?:@", + options = "" + } + ), + ( "dbname='some thing /?:@'\nuser='some thing /?:@' password='passwdsome thing /?:@' port=1 host = localhost\n", + ConnectionString + { hostname = "localhost", + port = 1, + user = "some thing /?:@", + password = "passwdsome thing /?:@", + database = "some thing /?:@", + options = "" + } + ), + ( "\ndbname=codd-experiments \t\n user=postgres port=5433 host=::1\n", + ConnectionString + { hostname = "::1", + port = 5433, + user = "postgres", + password = "", + database = "codd-experiments", + options = "" + } + ), + -- Only mandatory arguments + ( "dbname=codd-experiments\tuser=postgres\rhost=127.0.0.1", + ConnectionString + { hostname = "127.0.0.1", + port = 5432, + user = "postgres", + password = "", + database = "codd-experiments", + options = "" + } + ), + -- I didn't really test this with psql, but IIUC = signs should be accepted as parts of values + ( "dbname=codd-experiments\t user= post=gres password='abc = def' host=127.0.0.1", + ConnectionString + { hostname = "127.0.0.1", + port = 5432, + user = "post=gres", + password = "abc = def", + database = "codd-experiments", + options = "" + } + ) + ] + forM_ stringsAndExpectedConnInfos $ \(connString, expectedConnInfo) -> do + parseLibpqConnectionString + connString + `shouldBe` Right expectedConnInfo + + it "Randomized valid connection strings" $ hedgehog $ do + connGen <- forAll genConnStringGen + let expectedConn = connInfoFromConnStringGen connGen + parseLibpqConnectionString (renderConnStringGen connGen) === Right expectedConn + -- Round-tripping with `renderLibpqConnectionString` + parseLibpqConnectionString (decodeUtf8 $ renderLibpqConnectionString expectedConn) === Right expectedConn + +newtype ObjName = ObjName {unObjName :: Text} + deriving newtype (Eq, Ord, Show, Hashable) + +validLowerFirstChars :: [Char] +validLowerFirstChars = '_' : ['a' .. 'z'] + +validUpperFirstChars :: [Char] +validUpperFirstChars = ['A' .. 'Z'] + +genObjName :: Gen ObjName +genObjName = + ObjName . Text.pack + <$> Gen.frequency + [(100, genLower), (5, genMixed)] + where + validLowerOtherChars = validLowerFirstChars ++ "0123456789$" + validUpperOtherChars = validUpperFirstChars ++ "0123456789$" + + genLower = do + c <- Gen.element validLowerFirstChars + -- Max Length 63 bytes of UTF8-Encoded name + r <- Gen.list (Range.linear 0 62) $ Gen.element validLowerOtherChars + pure $ c : r + genMixed = do + c <- Gen.element $ validLowerFirstChars ++ validUpperFirstChars + -- Max Length 63 bytes of UTF8-Encoded name + r <- + Gen.list (Range.linear 0 62) $ + Gen.element $ + validLowerOtherChars + ++ validUpperOtherChars + pure $ c : r + +data HostString = Hostname Text | HostUnixSocket Text + deriving stock (Show) + +originalHost :: HostString -> Text +originalHost (Hostname t) = t +originalHost (HostUnixSocket t) = t + +genHostString :: Gen HostString +genHostString = + Gen.element + [ Hostname "127.0.0.1", + Hostname "200.200.100.100", + Hostname "hostnodots", + Hostname "some.host.name", + Hostname "::1", + Hostname "2800:3f0:4001:822::200e", + Hostname "2a03:2880:f105:283:face:b00c:0:25de", + HostUnixSocket "/var/lib/postgresql" + ] + +data ConnStringType = URIpostgres | Kwvps + deriving stock (Bounded, Enum, Show) + +getURIConnString :: + Text -> ObjName -> Text -> HostString -> Word16 -> ObjName -> Text +getURIConnString (Text.unpack -> uriScheme) (Text.unpack . unObjName -> usr) (Text.unpack -> pwd) host port (Text.unpack . unObjName -> dbName) = + Text.pack $ uriToString id uri "" + where + uri = + URI + { uriScheme, + uriAuthority = + Just + URIAuth + { uriUserInfo = + encodeURIComponent usr + <> ( if pwd == "" + then "" + else ':' : encodeURIComponent pwd + ) + <> "@", + uriRegName = Text.unpack $ escapeHost host, + uriPort = ':' : show port + }, + uriPath = '/' : encodeURIComponent dbName, + uriQuery = "", + uriFragment = "" + } + +encodeURIComponent :: String -> String +encodeURIComponent = escapeURIString isUnescapedInURIComponent + +data KwvpConnGen = KwvpConnGen + { -- | Shuffles the relative order of keyword/value pairs in the generated connection string. + shuffleIdx :: Int, + -- | The boolean dictates quoting when quoting is optional. + -- The Int represents extra spaces around this kwvp. These will be added one by one + -- left-to-right everywhere they are acceptable until a limit of 4 (therefore ignoring > 4 spaces). + user :: (ObjName, Bool, Int), + kwvp_password :: Maybe (Text, Bool, Int), + host :: (HostString, Bool, Int), + kwvp_port :: Maybe (Word16, Bool, Int), + dbname :: (ObjName, Bool, Int) + } + deriving stock (Show) + +getKeywordValuePairConnString :: KwvpConnGen -> Text +getKeywordValuePairConnString KwvpConnGen {..} = + Text.intercalate " " $ + map (\(kw, v) -> kw <> "=" <> v) mixedKwvps + where + mixedKwvps = + sortOn ((`mod` max 1 shuffleIdx) . hash) $ + catMaybes + [ Just $ addExtraSpaces user ("user", quoteIfNeeded unObjName user), + Just $ + addExtraSpaces + host + ("host", quoteIfNeeded originalHost host), + Just $ + addExtraSpaces dbname ("dbname", quoteIfNeeded unObjName dbname), + (\p -> addExtraSpaces p ("password", quoteIfNeeded id p)) + <$> kwvp_password, + (\p -> addExtraSpaces p ("port", quoteIfNeeded (Text.pack . show) p)) + <$> kwvp_port + ] + addExtraSpaces (_, _, spaces) (k, v) + | spaces <= 0 = (k, v) + | spaces == 1 = (" " <> k, v) + | spaces == 2 = (" " <> k <> " ", v) + | spaces == 3 = (" " <> k <> " ", " " <> v) + | otherwise = (" " <> k <> " ", " " <> v <> " ") + quoteIfNeeded un (v, force, _) = + if needsQuoting (un v) || force + then + "'" + <> Text.replace "'" "\\'" (Text.replace "\\" "\\\\" (un v)) + <> "'" + else un v + needsQuoting v = + "'" + `Text.isInfixOf` v + || "\\" + `Text.isInfixOf` v + || Text.any Char.isSpace v + || v + == "" + +escapeHost :: HostString -> Text +escapeHost (Hostname host) = + -- bracket-escape IPv6 addresses + if ":" `Text.isInfixOf` host then "[" <> host <> "]" else host +escapeHost (HostUnixSocket socketpath) = Text.pack $ encodeURIComponent $ Text.unpack socketpath + +newtype ConnStringGen = ConnStringGen (Either KwvpConnGen (Text, ObjName, Text, HostString, Word16, ObjName)) + +instance Show ConnStringGen where + show (ConnStringGen kwvpOrUriScheme) = Text.unpack $ + case kwvpOrUriScheme of + Left kwvpConnGen -> getKeywordValuePairConnString kwvpConnGen + Right (uriScheme, usr, pwd, host, port, dbName) -> + getURIConnString uriScheme usr pwd host port dbName + +renderConnStringGen :: ConnStringGen -> Text +renderConnStringGen (ConnStringGen kwvpOrUriScheme) = + case kwvpOrUriScheme of + Left kwvpConnGen -> getKeywordValuePairConnString kwvpConnGen + Right (uriScheme, usr, pwd, host, port, dbName) -> + getURIConnString uriScheme usr pwd host port dbName + +connInfoFromConnStringGen :: ConnStringGen -> ConnectionString +connInfoFromConnStringGen (ConnStringGen kwvpOrUriScheme) = + case kwvpOrUriScheme of + Left KwvpConnGen {user = (user, _, _), host = (host, _, _), dbname = (dbname, _, _), kwvp_password, kwvp_port} -> + ConnectionString + { hostname = originalHost host, + port = case kwvp_port of + Nothing -> 5432 + Just (p, _, _) -> p, + user = unObjName user, + password = case kwvp_password of + Nothing -> "" + Just (p, _, _) -> p, + database = unObjName dbname, + options = "" + } + Right (_uriScheme, user, password, host, port, dbname) -> + ConnectionString + { hostname = originalHost host, + port = port, + user = unObjName user, + password = password, + database = unObjName dbname, + options = "" + } + +genConnStringGen :: Gen ConnStringGen +genConnStringGen = do + usr <- genObjName + pwd <- + Gen.choice + [ pure "", + Gen.list (Range.linear 0 100) (Gen.element [' ' .. '~']) + ] + host <- genHostString + port <- Gen.choice [pure 5432, Gen.word16 Range.linearBounded] + dbName <- genObjName + + let connInfo = + ConnectionString + { hostname = originalHost host, + port, + user = unObjName usr, + password = Text.pack pwd, + database = unObjName dbName, + options = "" + } + connStringType <- Gen.enumBounded @_ @ConnStringType + case connStringType of + Kwvps -> do + shuffleIdx <- Gen.int Range.linearBounded + b1 <- Gen.bool + s1 <- Gen.int Range.linearBounded + b2 <- Gen.bool + s2 <- Gen.int Range.linearBounded + b3 <- Gen.bool + s3 <- Gen.int Range.linearBounded + b4 <- Gen.bool + s4 <- Gen.int Range.linearBounded + b5 <- Gen.bool + s5 <- Gen.int Range.linearBounded + withPwd <- + if connInfo.password == "" + then Gen.bool + else pure True + withPort <- + if port == 5432 + then Gen.bool + else pure True + pure $ + ConnStringGen $ + Left $ + KwvpConnGen + { shuffleIdx, + user = (usr, b1, s1), + kwvp_password = + if withPwd + then Just (Text.pack pwd, b2, s2) + else Nothing, + host = (host, b3, s3), + kwvp_port = + if withPort + then Just (port, b4, s4) + else Nothing, + dbname = (dbName, b5, s5) + } + URIpostgres -> do + uriScheme <- Gen.element ["postgres:", "postgresql:"] + pure $ + ConnStringGen $ + Right (uriScheme, usr, Text.pack pwd, host, port, dbName) diff --git a/hpgsql-tests/hpgsql-tests.cabal b/hpgsql-tests/hpgsql-tests.cabal index 8b13ea3..4a16b6b 100644 --- a/hpgsql-tests/hpgsql-tests.cabal +++ b/hpgsql-tests/hpgsql-tests.cabal @@ -31,6 +31,7 @@ executable hpgsql-tests DbUtils DocumentationExamplesSpec EncodingDecodingSpec + LibPqConnStringParsingSpec NotificationsSpec ParsingSpec PipelineSpec @@ -84,10 +85,12 @@ executable hpgsql-tests , bytestring , case-insensitive , containers + , hashable , hedgehog , hpgsql , hspec , hspec-hedgehog + , network-uri , postgresql-simple , random , safe-exceptions