diff --git a/postgresql-types.cabal b/postgresql-types.cabal --- a/postgresql-types.cabal +++ b/postgresql-types.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: postgresql-types -version: 0.1.2 +version: 0.1.3 category: PostgreSQL, Codecs synopsis: Precise PostgreSQL types representation and driver-agnostic codecs description: @@ -110,6 +110,7 @@ PostgresqlTypes.Char PostgresqlTypes.Cidr PostgresqlTypes.Circle + PostgresqlTypes.Citext PostgresqlTypes.Date PostgresqlTypes.Float4 PostgresqlTypes.Float8 @@ -134,11 +135,11 @@ PostgresqlTypes.Polygon PostgresqlTypes.Range PostgresqlTypes.Text - PostgresqlTypes.Tsvector PostgresqlTypes.Time PostgresqlTypes.Timestamp PostgresqlTypes.Timestamptz PostgresqlTypes.Timetz + PostgresqlTypes.Tsvector PostgresqlTypes.Uuid PostgresqlTypes.Varbit PostgresqlTypes.Varchar @@ -216,6 +217,7 @@ PostgresqlTypes.CharSpec PostgresqlTypes.CidrSpec PostgresqlTypes.CircleSpec + PostgresqlTypes.CitextSpec PostgresqlTypes.DateSpec PostgresqlTypes.Float4Spec PostgresqlTypes.Float8Spec @@ -241,10 +243,10 @@ PostgresqlTypes.RangeSpec PostgresqlTypes.TextSpec PostgresqlTypes.TimeSpec - PostgresqlTypes.TsvectorSpec PostgresqlTypes.TimestampSpec PostgresqlTypes.TimestamptzSpec PostgresqlTypes.TimetzSpec + PostgresqlTypes.TsvectorSpec PostgresqlTypes.UuidSpec PostgresqlTypes.VarbitSpec PostgresqlTypes.VarcharSpec diff --git a/src/library/PostgresqlTypes.hs b/src/library/PostgresqlTypes.hs --- a/src/library/PostgresqlTypes.hs +++ b/src/library/PostgresqlTypes.hs @@ -16,6 +16,7 @@ Varchar, Char, Bpchar, + Citext, -- * Boolean Type Bool, @@ -77,6 +78,7 @@ import PostgresqlTypes.Char import PostgresqlTypes.Cidr import PostgresqlTypes.Circle +import PostgresqlTypes.Citext import PostgresqlTypes.Date import PostgresqlTypes.Float4 import PostgresqlTypes.Float8 diff --git a/src/library/PostgresqlTypes/Citext.hs b/src/library/PostgresqlTypes/Citext.hs new file mode 100644 --- /dev/null +++ b/src/library/PostgresqlTypes/Citext.hs @@ -0,0 +1,92 @@ +module PostgresqlTypes.Citext + ( Citext, + + -- * Accessors + toText, + + -- * Constructors + normalizeFromText, + refineFromText, + ) +where + +import qualified Data.Attoparsec.Text as Attoparsec +import Data.String +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import PostgresqlTypes.Algebra +import PostgresqlTypes.Prelude hiding (Text) +import PostgresqlTypes.Via +import qualified PtrPeeker +import qualified PtrPoker.Write as Write +import qualified Test.QuickCheck as QuickCheck +import qualified TextBuilder + +-- | PostgreSQL @citext@ type. Case-insensitive variable-length character string. +-- Requires the @citext@ extension to be installed in PostgreSQL. +-- +-- [PostgreSQL docs](https://www.postgresql.org/docs/18/citext.html). +-- +-- The value is stored as UTF-8 text, identical to @text@. Case-insensitivity +-- is a property of comparisons, not of storage. NUL characters are not allowed. +newtype Citext = Citext Text.Text + deriving newtype (Eq, Ord, Hashable) + deriving (Show, Read, IsString) via (ViaIsScalar Citext) + +instance Arbitrary Citext where + arbitrary = + Citext <$> do + charList <- QuickCheck.listOf do + QuickCheck.suchThat arbitrary (\char -> char /= '\NUL') + pure (Text.pack charList) + shrink (Citext base) = + Citext . Text.pack <$> shrink (Text.unpack base) + +instance IsScalar Citext where + schemaName = Tagged Nothing + typeName = Tagged "citext" + baseOid = Tagged Nothing + arrayOid = Tagged Nothing + typeParams = Tagged [] + binaryEncoder (Citext base) = Write.textUtf8 base + binaryDecoder = do + bytes <- PtrPeeker.remainderAsByteString + case Text.Encoding.decodeUtf8' bytes of + Left e -> + pure + ( Left + ( DecodingError + { location = [], + reason = + ParsingDecodingErrorReason + (fromString (show e)) + bytes + } + ) + ) + Right base -> pure (Right (Citext base)) + textualEncoder (Citext base) = TextBuilder.text base + textualDecoder = Citext <$> Attoparsec.takeText + +-- * Accessors + +-- | Extract the underlying 'Data.Text.Text' value. +toText :: Citext -> Text.Text +toText (Citext t) = t + +-- * Constructors + +-- | Construct a PostgreSQL 'Citext' from a 'Data.Text.Text' value. +-- +-- Strips null characters to ensure PostgreSQL compatibility. +normalizeFromText :: Text.Text -> Citext +normalizeFromText = Citext . Text.replace "\NUL" "" + +-- | Construct a PostgreSQL 'Citext' from a 'Data.Text.Text' value. +-- +-- Returns 'Nothing' if the text contains null characters (not supported by PostgreSQL). +refineFromText :: Text.Text -> Maybe Citext +refineFromText text = + if Text.elem '\NUL' text + then Nothing + else Just (Citext text) diff --git a/src/library/PostgresqlTypes/Inet.hs b/src/library/PostgresqlTypes/Inet.hs --- a/src/library/PostgresqlTypes/Inet.hs +++ b/src/library/PostgresqlTypes/Inet.hs @@ -148,7 +148,7 @@ <*> PtrPeeker.beUnsignedInt4 <*> pure (fromIntegral netmask) _ -> do - throwError (DecodingError ["address-family"] (UnexpectedValueDecodingErrorReason "2 or 10" (TextBuilder.toText (TextBuilder.decimal family)))) + throwError (DecodingError ["address-family"] (UnexpectedValueDecodingErrorReason "2 or 3" (TextBuilder.toText (TextBuilder.decimal family)))) textualEncoder = \case V4Inet addr netmask -> diff --git a/src/library/PostgresqlTypes/Money.hs b/src/library/PostgresqlTypes/Money.hs --- a/src/library/PostgresqlTypes/Money.hs +++ b/src/library/PostgresqlTypes/Money.hs @@ -44,8 +44,10 @@ textualEncoder (Money x) = -- Format as currency with 2 decimal places and $ symbol -- PostgreSQL's money type typically displays with currency symbol - let isNegative = x < 0 - absValue = abs x + -- Use Integer to avoid abs overflow on minBound @Int64 + let value = fromIntegral x :: Integer + isNegative = value < 0 + absValue = abs value dollars = quot absValue 100 cents = rem absValue 100 centsText = diff --git a/src/library/PostgresqlTypes/Time.hs b/src/library/PostgresqlTypes/Time.hs --- a/src/library/PostgresqlTypes/Time.hs +++ b/src/library/PostgresqlTypes/Time.hs @@ -55,10 +55,9 @@ m <- twoDigits -- Seconds are optional s <- Attoparsec.option 0 (Attoparsec.char ':' *> parseSeconds) - if h < 25 && m < 60 && s < 61_000_000 - then - let microseconds = fromIntegral h * 3600_000_000 + fromIntegral m * 60_000_000 + s - in pure (Time microseconds) + let microseconds = fromIntegral h * 3600_000_000 + fromIntegral m * 60_000_000 + s + if h <= 24 && m < 60 && s < 61_000_000 && microseconds >= 0 && microseconds <= 86_400_000_000 + then pure (Time microseconds) else fail "Invalid time" where twoDigits = do diff --git a/src/unit-tests/PostgresqlTypes/CitextSpec.hs b/src/unit-tests/PostgresqlTypes/CitextSpec.hs new file mode 100644 --- /dev/null +++ b/src/unit-tests/PostgresqlTypes/CitextSpec.hs @@ -0,0 +1,75 @@ +module PostgresqlTypes.CitextSpec (spec) where + +import Data.Data (Proxy (Proxy)) +import Data.Maybe +import qualified Data.Text as Text +import qualified PostgresqlTypes.Citext as Citext +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import qualified UnitTests.Scripts as Scripts +import Prelude + +spec :: Spec +spec = do + describe "Show/Read laws" do + Scripts.testShowRead (Proxy @Citext.Citext) + + describe "IsScalar laws" do + Scripts.testIsScalar (Proxy @Citext.Citext) + + describe "Constructors" do + describe "normalizeFromText" do + it "strips null characters" do + let pgText = Citext.normalizeFromText "hello\NULworld" + Citext.toText pgText `shouldBe` "helloworld" + + it "preserves text without null characters" do + let pgText = Citext.normalizeFromText "hello world" + Citext.toText pgText `shouldBe` "hello world" + + it "handles multiple null characters" do + let pgText = Citext.normalizeFromText "\NULa\NULb\NULc\NUL" + Citext.toText pgText `shouldBe` "abc" + + it "handles empty text" do + let pgText = Citext.normalizeFromText "" + Citext.toText pgText `shouldBe` "" + + describe "refineFromText" do + it "rejects text with null characters" do + Citext.refineFromText "hello\NULworld" `shouldBe` Nothing + + it "accepts text without null characters" do + let result = Citext.refineFromText "hello world" + result `shouldSatisfy` isJust + fmap Citext.toText result `shouldBe` Just "hello world" + + it "accepts empty text" do + let result = Citext.refineFromText "" + result `shouldSatisfy` isJust + + describe "Accessors" do + describe "toText" do + it "extracts text value" do + let pgText = Citext.normalizeFromText "test" + Citext.toText pgText `shouldBe` "test" + + describe "Property Tests" do + it "normalizeFromText is idempotent" do + property \(t :: Text.Text) -> + let normalized1 = Citext.normalizeFromText t + normalized2 = Citext.normalizeFromText (Citext.toText normalized1) + in normalized1 === normalized2 + + describe "refineFromText" do + it "succeeds for text without nulls" do + property \(pgText :: Citext.Citext) -> + let t = Citext.toText pgText + refined = Citext.refineFromText t + in refined === Just pgText + + it "rejects text with nulls" do + property \(NonEmpty prefix, NonEmpty suffix) -> + let textWithNull = Text.pack prefix <> "\NUL" <> Text.pack suffix + in Citext.refineFromText textWithNull === Nothing diff --git a/src/unit-tests/PostgresqlTypes/MoneySpec.hs b/src/unit-tests/PostgresqlTypes/MoneySpec.hs --- a/src/unit-tests/PostgresqlTypes/MoneySpec.hs +++ b/src/unit-tests/PostgresqlTypes/MoneySpec.hs @@ -1,11 +1,15 @@ module PostgresqlTypes.MoneySpec (spec) where +import qualified Data.Attoparsec.Text import Data.Data (Proxy (Proxy)) import Data.Int +import qualified PostgresqlTypes.Algebra import qualified PostgresqlTypes.Money as Money import Test.Hspec import Test.QuickCheck +import qualified TextBuilder import qualified UnitTests.Scripts as Scripts +import Prelude spec :: Spec spec = do @@ -34,6 +38,19 @@ it "extracts Int64 value representing cents" do let pgMoney = Money.fromInt64 9999 Money.toInt64 pgMoney `shouldBe` 9999 + + describe "Edge Cases" do + it "textual encoder handles minBound @Int64 correctly" do + let pgMoney = Money.fromInt64 (minBound @Int64) + encoded = TextBuilder.toText (PostgresqlTypes.Algebra.textualEncoder pgMoney) + decoded = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @Money.Money) encoded + decoded `shouldBe` Right pgMoney + + it "textual encoder handles maxBound @Int64 correctly" do + let pgMoney = Money.fromInt64 (maxBound @Int64) + encoded = TextBuilder.toText (PostgresqlTypes.Algebra.textualEncoder pgMoney) + decoded = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @Money.Money) encoded + decoded `shouldBe` Right pgMoney describe "Property Tests" do it "roundtrips through toInt64 and fromInt64" do diff --git a/src/unit-tests/PostgresqlTypes/TimeSpec.hs b/src/unit-tests/PostgresqlTypes/TimeSpec.hs --- a/src/unit-tests/PostgresqlTypes/TimeSpec.hs +++ b/src/unit-tests/PostgresqlTypes/TimeSpec.hs @@ -1,8 +1,11 @@ module PostgresqlTypes.TimeSpec (spec) where +import qualified Data.Attoparsec.Text import Data.Data (Proxy (Proxy)) +import Data.Either (isLeft, isRight) import Data.Maybe import qualified Data.Time as Time +import qualified PostgresqlTypes.Algebra import qualified PostgresqlTypes.Time as PgTime import Test.Hspec import Test.QuickCheck @@ -62,6 +65,32 @@ let pgTime = PgTime.normalizeFromMicroseconds 43_200_000_000 -- noon tod = PgTime.toTimeOfDay pgTime tod `shouldBe` Time.TimeOfDay 12 0 0 + + describe "Edge Cases" do + it "textual decoder accepts 24:00:00" do + let result = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @PgTime.Time) "24:00:00" + result `shouldSatisfy` isRight + fmap PgTime.toMicroseconds result `shouldBe` Right 86_400_000_000 + + it "textual decoder rejects 24:00:01" do + let result = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @PgTime.Time) "24:00:01" + result `shouldSatisfy` isLeft + + it "textual decoder rejects 24:01:00" do + let result = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @PgTime.Time) "24:01:00" + result `shouldSatisfy` isLeft + + it "textual decoder rejects 24:30:00" do + let result = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @PgTime.Time) "24:30:00" + result `shouldSatisfy` isLeft + + it "textual decoder rejects 24:00:00.000001" do + let result = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @PgTime.Time) "24:00:00.000001" + result `shouldSatisfy` isLeft + + it "textual decoder accepts 23:59:59.999999" do + let result = Data.Attoparsec.Text.parseOnly (PostgresqlTypes.Algebra.textualDecoder @PgTime.Time) "23:59:59.999999" + result `shouldSatisfy` isRight describe "Property Tests" do it "roundtrips through toMicroseconds and normalizeFromMicroseconds" do