diff --git a/packstream-bolt.cabal b/packstream-bolt.cabal --- a/packstream-bolt.cabal +++ b/packstream-bolt.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.1. +-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: packstream-bolt -version: 0.1.0.0 +version: 0.1.0.1 synopsis: PackStream binary serialization format description: Implementation of the PackStream binary serialization format, used as the wire format by Neo4j's BOLT protocol. @@ -85,6 +85,48 @@ , text >=2.0 && <2.2 , text-show >=3.10 && <3.12 , time >=1.11 && <1.15 + , unordered-containers ==0.2.* + , vector ==0.13.* + default-language: GHC2021 + if flag(dev) + ghc-options: -Werror + +test-suite packstream-bolt-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_packstream_bolt + hs-source-dirs: + test + default-extensions: + DataKinds + DefaultSignatures + DeriveAnyClass + DerivingVia + DuplicateRecordFields + FunctionalDependencies + GADTs + LambdaCase + MultiWayIf + OverloadedRecordDot + OverloadedStrings + PartialTypeSignatures + RecordWildCards + RoleAnnotations + TypeFamilies + UnboxedSums + UnboxedTuples + UnliftedDatatypes + UnliftedNewtypes + ViewPatterns + ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-safe-haskell-mode -Wno-name-shadowing -Wno-overlapping-patterns -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-orphans + build-depends: + QuickCheck + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , packstream-bolt + , sandwich + , text >=2.0 && <2.2 , unordered-containers ==0.2.* , vector ==0.13.* default-language: GHC2021 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,191 @@ +module Main where + +import Test.Sandwich + +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import qualified Data.ByteString as BS +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V + +import Data.PackStream (pack, unpack) +import Data.PackStream.Ps (Ps(..)) +import Data.PackStream.Integer (ToPSInteger(..)) +import Test.QuickCheck (Arbitrary(..), Gen, oneof, + quickCheckResult, isSuccess, + withMaxSuccess, chooseInt) + + +-- = Helpers + +-- | Like 'listOf' but keeps the size small to avoid deep nesting. +listOfSmall :: Gen a -> Gen [a] +listOfSmall g = do + n <- chooseInt (0, 3) + sequence (replicate n g) + +-- | Generate a finite (non-NaN, non-Infinite) Double. +arbitraryFiniteDouble :: Gen Double +arbitraryFiniteDouble = do + d <- arbitrary + pure $ if isNaN d || isInfinite d then 0.0 else d + +-- | Arbitrary Ps value (no PsStructure — tag namespace is application-defined). +instance Arbitrary Ps where + arbitrary = oneof + [ pure PsNull + , PsBoolean <$> arbitrary + , PsInteger . toPSInteger <$> (arbitrary :: Gen Int64) + , PsFloat <$> arbitraryFiniteDouble + , PsString . T.pack <$> arbitrary + , PsBytes . BS.pack <$> arbitrary + , PsList . V.fromList <$> listOfSmall arbitrary + , PsDictionary . H.fromList <$> listOfSmall ((,) <$> (T.pack <$> arbitrary) <*> arbitrary) + ] + +-- | Assert a QuickCheck result, failing the sandwich test on property failure. +assertQC r + | isSuccess r = pure () + | otherwise = expectationFailure $ "QuickCheck: " <> show r + + +-- = Unit tests: PackStream round-trips + +packstreamRoundTripTests :: TopSpec +packstreamRoundTripTests = describe "PackStream round-trips" $ do + it "round-trips PsNull" $ do + unpack (pack PsNull) `shouldBe` Right PsNull + + it "round-trips PsBoolean True" $ do + unpack (pack (PsBoolean True)) `shouldBe` Right (PsBoolean True) + + it "round-trips PsBoolean False" $ do + unpack (pack (PsBoolean False)) `shouldBe` Right (PsBoolean False) + + it "round-trips PsInteger small" $ do + unpack (pack (PsInteger 42)) `shouldBe` Right (PsInteger 42) + + it "round-trips PsInteger negative" $ do + unpack (pack (PsInteger (-100))) `shouldBe` Right (PsInteger (-100)) + + it "round-trips PsInteger zero" $ do + unpack (pack (PsInteger 0)) `shouldBe` Right (PsInteger 0) + + it "round-trips PsFloat" $ do + unpack (pack (PsFloat 3.14)) `shouldBe` Right (PsFloat 3.14) + + it "round-trips PsString" $ do + unpack (pack (PsString "hello world")) `shouldBe` Right (PsString "hello world") + + it "round-trips PsString empty" $ do + unpack (pack (PsString "")) `shouldBe` Right (PsString "") + + it "round-trips PsString unicode" $ do + unpack (pack (PsString "\x1F600 emoji")) `shouldBe` Right (PsString "\x1F600 emoji") + + it "round-trips PsList empty" $ do + unpack (pack (PsList V.empty)) `shouldBe` Right (PsList V.empty) + + it "round-trips PsList with values" $ do + let v = PsList $ V.fromList [PsInteger 1, PsString "two", PsBoolean True] + unpack (pack v) `shouldBe` Right v + + it "round-trips PsDictionary empty" $ do + unpack (pack (PsDictionary H.empty)) `shouldBe` Right (PsDictionary H.empty) + + it "round-trips PsDictionary with entries" $ do + let d = PsDictionary $ H.fromList [("key", PsString "value"), ("num", PsInteger 42)] + unpack (pack d) `shouldBe` Right d + + it "round-trips nested structures" $ do + let nested = PsList $ V.fromList + [ PsDictionary $ H.fromList [("a", PsInteger 1)] + , PsList $ V.fromList [PsNull, PsBoolean False] + ] + unpack (pack nested) `shouldBe` Right nested + + -- Integer range boundary tests + it "round-trips PsInteger tiny positive (127)" $ do + unpack (pack (PsInteger 127)) `shouldBe` Right (PsInteger 127) + + it "round-trips PsInteger tiny negative (-16)" $ do + unpack (pack (PsInteger (-16))) `shouldBe` Right (PsInteger (-16)) + + it "round-trips PsInteger INT_8 range (128)" $ do + unpack (pack (PsInteger 128)) `shouldBe` Right (PsInteger 128) + + it "round-trips PsInteger INT_8 range (-128)" $ do + unpack (pack (PsInteger (-128))) `shouldBe` Right (PsInteger (-128)) + + it "round-trips PsInteger INT_16 range (1000)" $ do + unpack (pack (PsInteger 1000)) `shouldBe` Right (PsInteger 1000) + + it "round-trips PsInteger INT_32 range (100000)" $ do + unpack (pack (PsInteger 100000)) `shouldBe` Right (PsInteger 100000) + + it "round-trips PsInteger INT_64 range (maxBound)" $ do + let big = PsInteger 9223372036854775807 + unpack (pack big) `shouldBe` Right big + + it "round-trips PsInteger INT_64 range (minBound)" $ do + let small = PsInteger (-9223372036854775808) + unpack (pack small) `shouldBe` Right small + + -- Bytes tests + it "round-trips PsBytes empty" $ do + unpack (pack (PsBytes "")) `shouldBe` Right (PsBytes "") + + it "round-trips PsBytes with data" $ do + let bs = PsBytes "\x00\x01\x02\xFF" + unpack (pack bs) `shouldBe` Right bs + + -- Structure tests + it "round-trips PsStructure empty fields" $ do + let s = PsStructure 0x01 V.empty + unpack (pack s) `shouldBe` Right s + + it "round-trips PsStructure with one field" $ do + let s = PsStructure 0x01 $ V.singleton $ PsDictionary $ H.fromList + [("user_agent", PsString "bolty/2.0"), ("scheme", PsString "none")] + unpack (pack s) `shouldBe` Right s + + it "round-trips PsStructure with multiple fields" $ do + let s = PsStructure 0x4E $ V.fromList + [ PsInteger 1 + , PsList (V.fromList [PsString "Person"]) + , PsDictionary (H.fromList [("name", PsString "Alice")]) + , PsString "4:abc:1" + ] + unpack (pack s) `shouldBe` Right s + + -- Larger collection tests + it "round-trips PsList with 16 elements (LIST_8)" $ do + let v = PsList $ V.fromList [PsInteger (fromIntegral i) | i <- [0..15 :: Int]] + unpack (pack v) `shouldBe` Right v + + it "round-trips Text via PackStream class" $ do + let txt = "hello" :: T.Text + unpack (pack txt) `shouldBe` Right (PsString txt) + + it "round-trips Bool via PackStream class" $ do + unpack (pack True) `shouldBe` Right (PsBoolean True) + + +-- = QuickCheck property tests + +quickcheckTests :: TopSpec +quickcheckTests = describe "QuickCheck: pack/unpack round-trip" $ do + + it "Ps round-trips through pack/unpack (1000 cases)" $ do + r <- liftIO $ quickCheckResult $ withMaxSuccess 1000 $ \(ps :: Ps) -> + unpack (pack ps) == Right ps + assertQC r + + +-- = Main + +main :: IO () +main = runSandwichWithCommandLineArgs defaultOptions $ do + packstreamRoundTripTests + quickcheckTests