diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,48 @@ # Revision history for pgmq-core +## 0.5.0.0 -- 2026-08-06 + +### Breaking Changes + +* Queue names are now validated consistently at every entry path. `parseQueueName` rejects + the empty string and any character outside lowercase ASCII letters, digits, and + underscore — previously uppercase was accepted and the empty string passed every check. + `FromJSON QueueName` is now a hand-written instance that validates via `parseQueueName`; + it was newtype-derived, accepting any string of any length, so configuration-loaded + names bypassed validation entirely. + + Lowercase-only is a correctness requirement, not a style choice. pgmq's SQL lowercases + physical table names while `pgmq.meta` stores the caller's original casing, and the + notification trigger looks up the lowercased name. `MyQueue` and `myqueue` were + therefore two logical queues silently interleaving in one physical table: dropping + either destroyed the other's messages, and a mixed-case notification throttle was never + matched by the trigger. Rejection was chosen over normalization because normalizing + would silently join pre-existing mixed-case metadata and make the parsed name disagree + with what the caller wrote. + + **Upgrade note**: `listQueues` re-validates names read back from the database, so a + deployment whose `pgmq.meta` still contains mixed-case rows must run the transactional + remediation in `docs/design/016-queue-name-validation.md` — which preserves topic + bindings and notification configuration — before upgrading. Do not update or delete + `pgmq.meta` rows by hand: both child foreign keys cascade on delete. + +### New Features + +* `notifyChannelName :: QueueName -> Text` returns the LISTEN/NOTIFY channel a queue's + insert notifications arrive on (`pgmq.q_.INSERT`). It is now the + contract; do not assemble the name by hand. It lives here rather than in pgmq-hasql + because a LISTEN consumer needs a raw connection anyway and may not depend on + pgmq-hasql at all. +* `UnvalidatedQueue`, a queue listing row whose name is plain `Text`. pgmq's server-side + validator checks only name length, so any client sharing the database can create a name + `parseQueueName` rejects; this type is what the lenient pgmq-hasql and pgmq-effectful + listings decode into. + +### Other Changes + +* New `pgmq-core-test` suite pinning both queue-name entry paths, `parseQueueName` and + `FromJSON`. + ## 0.4.0.1 -- 2026-07-14 * Version bump only — coordinated release with pgmq-migration 0.4.0.1. diff --git a/pgmq-core.cabal b/pgmq-core.cabal --- a/pgmq-core.cabal +++ b/pgmq-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: pgmq-core -version: 0.4.0.1 +version: 0.5.0.0 synopsis: Core types for pgmq-hs, a Haskell client for PGMQ description: Core types and type classes for pgmq-hs, a Haskell client library @@ -41,3 +41,22 @@ hs-source-dirs: src default-language: GHC2024 + +test-suite pgmq-core-test + import: warnings + default-language: GHC2024 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: QueueNameSpec + default-extensions: + ImportQualifiedPost + OverloadedStrings + + build-depends: + , aeson ^>=2.2 + , base >=4.18 && <5 + , pgmq-core + , tasty ^>=1.5 + , tasty-hunit ^>=0.10 + , text ^>=2.1 diff --git a/src/Pgmq/Types.hs b/src/Pgmq/Types.hs --- a/src/Pgmq/Types.hs +++ b/src/Pgmq/Types.hs @@ -6,6 +6,7 @@ MessageId (..), Message (..), Queue (..), + UnvalidatedQueue (..), QueueName, parseQueueName, queueNameToText, @@ -21,12 +22,16 @@ TopicBinding (..), RoutingMatch (..), TopicSendResult (..), + + -- * Notifications (pgmq 1.11.0+) NotifyInsertThrottle (..), + notifyChannelName, ) where -import Data.Aeson (FromJSON, ToJSON, Value) -import Data.Char (isAlphaNum, isAscii) +import Data.Aeson (FromJSON (..), ToJSON, Value) +import Data.Aeson qualified as Aeson +import Data.Char (isAlphaNum, isAscii, isDigit, isLower) import Data.Int (Int32, Int64) import Data.Text (Text) import Data.Text qualified as T @@ -56,6 +61,23 @@ } deriving stock (Eq, Generic, Show) +-- | A row of @pgmq.list_queues()@ with the queue name left unvalidated. +-- +-- Queues are created by every client that shares the database, and the +-- server accepts names 'parseQueueName' rejects (its only check is length). +-- This shape exists so state inspection — notably pgmq-config's reconciler — +-- can observe such foreign queues without failing to decode them. +-- 'unvalidatedName' may therefore hold any server-accepted name; do not feed +-- it into APIs expecting a validated 'QueueName' without going through +-- 'parseQueueName'. +data UnvalidatedQueue = UnvalidatedQueue + { unvalidatedName :: !Text, + unvalidatedCreatedAt :: !UTCTime, + unvalidatedIsPartitioned :: !Bool, + unvalidatedIsUnlogged :: !Bool + } + deriving stock (Eq, Generic, Show) + -- | https://pgmq.github.io/pgmq/api/sql/types/ -- Note: headers field added in pgmq 1.5.0 -- Note: lastReadAt field added in pgmq 1.10.0 @@ -71,13 +93,20 @@ deriving stock (Eq, Generic, Show) newtype QueueName = QueueName Text - deriving newtype (Eq, Ord, FromJSON, ToJSON) + deriving newtype (Eq, Ord, ToJSON) deriving stock (Show, Generic) instance Lift QueueName where lift (QueueName t) = [|QueueName t|] liftTyped (QueueName t) = [||QueueName t||] +-- | Validates via 'parseQueueName', so JSON- and config-loaded names get +-- exactly the same checks as programmatic construction. A derived instance +-- would bypass the smart constructor entirely. +instance FromJSON QueueName where + parseJSON = Aeson.withText "QueueName" $ \t -> + either (fail . show) pure (parseQueueName t) + queueNameToText :: QueueName -> Text queueNameToText (QueueName t) = t @@ -87,16 +116,43 @@ | InvalidTopicPattern Text deriving stock (Show, Generic) --- Adopted from https://github.com/tembo-io/pgmq/blob/e4d4b84bf302df77be2d1f877c5cf8ef8861bfc7/pgmq-rs/src/util.rs#L94 +-- | Parse a queue name: non-empty, at most 47 characters, drawn from lowercase +-- ASCII letters, digits, and underscore only. +-- +-- Lowercase-only is a correctness requirement, not a style choice. pgmq's SQL +-- lowercases /physical/ table names (@pgmq.format_table_name@) but stores the +-- caller's /original/ casing in @pgmq.meta@, and the notification trigger looks +-- up the /lowercased/ name extracted from the physical table. A mixed-case name +-- therefore aliases: @MyQueue@ and @myqueue@ are two metadata identities +-- sharing one physical table (interleaved messages; dropping either destroys +-- the other's data), and notification throttles configured under a mixed-case +-- name are never matched by the trigger. Rejecting anything but lowercase makes +-- all three representations agree. Names are deliberately not normalized: +-- silent lowercasing would re-introduce the aliasing against pre-existing +-- mixed-case metadata and make the parsed name disagree with what the caller +-- wrote. +-- +-- Upgrade note: a database that already contains mixed-case rows in +-- @pgmq.meta@ will fail @listQueues@ decoding under this stricter parser (the +-- decoder re-validates names read back from the database). Run the mixed-case +-- remediation described in @docs/design/016-queue-name-validation.md@ before +-- upgrading such a deployment. +-- +-- Length check adopted from +-- https://github.com/tembo-io/pgmq/blob/e4d4b84bf302df77be2d1f877c5cf8ef8861bfc7/pgmq-rs/src/util.rs#L94 parseQueueName :: Text -> Either PgmqError QueueName parseQueueName t + | T.null t = Left $ InvalidQueueName "The queue name is empty." | not isShortEnough = Left $ InvalidQueueName "The queue name is too long." - | not hasValidCharacters = Left $ InvalidQueueName "The queue name contains invalid characters." + | not hasValidCharacters = + Left $ + InvalidQueueName + "The queue name contains invalid characters (allowed: lowercase ASCII letters, digits, underscore)." | otherwise = Right $ QueueName t where isShortEnough = T.length t <= maxQueueNameLength hasValidCharacters = T.all isValidChar t - isValidChar c = (isAscii c && isAlphaNum c) || c == '_' + isValidChar c = (isAscii c && (isLower c || isDigit c)) || c == '_' -- PostgreSQL identifier length information -- https://www.postgresql.org/docs/current/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS @@ -169,3 +225,19 @@ throttleLastNotifiedAt :: !UTCTime } deriving stock (Eq, Generic, Show) + +-- | The LISTEN\/NOTIFY channel on which pgmq raises insert notifications for a +-- queue, once @pgmq.enable_notify_insert@ has installed the trigger. The format +-- is @pgmq.q_\.INSERT@: the physical table name (the +-- @q_@ prefix, lowercased by pgmq's @format_table_name@) bracketed by the +-- @pgmq.@ schema tag and the trigger operation. +-- +-- Because the name contains dots, LISTEN requires it double-quoted: +-- +-- > LISTEN "pgmq.q_myqueue.INSERT" +-- +-- NOTIFY is fire-and-forget. Notifications are not queued for disconnected +-- listeners, and a configured throttle interval suppresses them by design. +-- Consumers must keep a poll fallback regardless of LISTEN. +notifyChannelName :: QueueName -> Text +notifyChannelName q = "pgmq.q_" <> T.toLower (queueNameToText q) <> ".INSERT" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import QueueNameSpec qualified +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "pgmq-core" + [ QueueNameSpec.tests + ] diff --git a/test/QueueNameSpec.hs b/test/QueueNameSpec.hs new file mode 100644 --- /dev/null +++ b/test/QueueNameSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | PGH-7: queue names must be rejected consistently at every entry path. +-- +-- The unexported @QueueName@ constructor leaves exactly two runtime ways to +-- build one: 'parseQueueName' and 'Data.Aeson.FromJSON'. Both must enforce the +-- same contract — non-empty, at most 47 characters, lowercase ASCII letters, +-- digits, and underscore only. Lowercase-only matters because pgmq's SQL +-- lowercases physical table names while @pgmq.meta@ stores the caller's +-- original casing: a mixed-case name aliases another queue's physical table +-- and configures notification throttles the trigger can never match. The +-- @FromJSON@ instance was previously newtype-derived and accepted anything, +-- which is the bypass these tests pin shut. +module QueueNameSpec (tests) where + +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Data.Text qualified as T +import Pgmq.Types (PgmqError (..), QueueName, parseQueueName, queueNameToText) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "QueueName validation" + [ parseAcceptance, + parseRejection, + jsonPath + ] + +parseAcceptance :: TestTree +parseAcceptance = + testGroup + "parseQueueName accepts" + [ testCase "a typical lowercase name" $ do + qn <- assertParses "my_queue_123" + assertEqual "round-trips through queueNameToText" "my_queue_123" (queueNameToText qn), + testCase "a 47-character lowercase name (the maximum)" $ do + qn <- assertParses (T.replicate 47 "a") + assertEqual "length preserved" 47 (T.length (queueNameToText qn)) + ] + +parseRejection :: TestTree +parseRejection = + testGroup + "parseQueueName rejects" + [ testCase "an uppercase name" $ + assertRejects "MyQueue" "invalid characters", + testCase "the empty string" $ + assertRejects "" "empty", + testCase "a 48-character name" $ + assertRejects (T.replicate 48 "a") "too long", + testCase "a hyphenated name" $ + assertRejects "bad-name" "invalid characters", + testCase "a name with punctuation" $ + assertRejects "queue!" "invalid characters" + ] + +jsonPath :: TestTree +jsonPath = + testGroup + "FromJSON validates via parseQueueName" + [ testCase "a lowercase name decodes and round-trips through ToJSON" $ + case Aeson.fromJSON (Aeson.String "myqueue") :: Aeson.Result QueueName of + Aeson.Error err -> assertFailure $ "Expected Success, got Error: " <> err + Aeson.Success qn -> assertEqual "ToJSON round-trip" (Aeson.String "myqueue") (Aeson.toJSON qn), + testCase "an uppercase name is rejected" $ assertJsonRejects "MyQueue", + testCase "the empty string is rejected" $ assertJsonRejects "", + testCase "an overlong name is rejected" $ assertJsonRejects (T.replicate 60 "x"), + testCase "a hyphenated name is rejected" $ assertJsonRejects "bad-name" + ] + +assertParses :: Text -> IO QueueName +assertParses t = + case parseQueueName t of + Left err -> assertFailure $ "Expected Right, got: " <> show err + Right qn -> pure qn + +-- | The rejection must be an 'InvalidQueueName' whose message names the actual +-- problem, so callers surface something diagnosable. +assertRejects :: Text -> String -> IO () +assertRejects t expectedFragment = + case parseQueueName t of + Right _ -> assertFailure $ "Expected rejection of " <> show t + Left err@(InvalidQueueName msg) -> + assertBool + ("Expected message mentioning " <> show expectedFragment <> ", got: " <> show err) + (T.pack expectedFragment `T.isInfixOf` msg) + Left err -> assertFailure $ "Expected InvalidQueueName, got: " <> show err + +assertJsonRejects :: Text -> IO () +assertJsonRejects t = + case Aeson.fromJSON (Aeson.String t) :: Aeson.Result QueueName of + Aeson.Error _ -> pure () + Aeson.Success qn -> + assertFailure $ "Expected FromJSON rejection of " <> show t <> ", got: " <> show (queueNameToText qn)