diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,52 @@ +Apache License +Version 2.0, January 2004 +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: + + You must give any other recipients of the Work or Derivative Works a copy of this License; and + You must cause any modified files to carry prominent notices stating that You changed the files; and + You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and + If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. + + You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. + +5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bolty.cabal b/bolty.cabal new file mode 100644 --- /dev/null +++ b/bolty.cabal @@ -0,0 +1,217 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: bolty +version: 0.1.0.0 +synopsis: Haskell driver for Neo4j (BOLT protocol 4.4-5.4) +description: Native Haskell driver for Neo4j graph database using the BOLT protocol. + Supports BOLT versions 4.4 through 5.4 with connection pooling, + routing, transactions, retry logic, and streaming results. +category: Database +homepage: https://github.com/philippedev101/bolty#readme +bug-reports: https://github.com/philippedev101/bolty/issues +author: philippedev101 +maintainer: philippedev101@gmail.com +copyright: (c) 2023-2026 philippedev101 +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.6.7 || == 9.8.4 || == 9.10.3 || == 9.12.3 +extra-source-files: + readme.md + changelog.md + +source-repository head + type: git + location: https://github.com/philippedev101/bolty + +flag dev + description: Turn on -Werror and other developer flags + manual: True + default: False + +library + exposed-modules: + Database.Bolty + Database.Bolty.Decode + Database.Bolty.Pool + Database.Bolty.Record + Database.Bolty.ResultSet + Database.Bolty.Routing + Database.Bolty.Session + Database.Bolty.Logging + Database.Bolty.Notification + Database.Bolty.Plan + Database.Bolty.Stats + Database.Bolty.Connection + Database.Bolty.Connection.Config + Database.Bolty.Connection.Connection + Database.Bolty.Connection.Instances + Database.Bolty.Connection.Pipe + Database.Bolty.Connection.Server + Database.Bolty.Connection.Type + Database.Bolty.Connection.Version + Database.Bolty.Message.Request + Database.Bolty.Message.Response + Database.Bolty.Util + Database.Bolty.Value.Helpers + Database.Bolty.Value.Type + other-modules: + Paths_bolty + hs-source-dirs: + src + 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-prepositive-qualified-module -Wno-safe -Wno-unsafe + build-depends: + aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , crypton-connection >=0.3 && <0.5 + , data-default >=0.7 && <0.9 + , extra >=1.7 && <1.9 + , mtl >=2.2 && <2.4 + , network >=3.1 && <3.3 + , packstream ==0.1.* + , persist ==1.0.* + , resource-pool ==0.4.* + , scientific ==0.3.* + , split ==0.2.* + , text >=2.0 && <2.2 + , text-show >=3.10 && <3.12 + , time >=1.11 && <1.15 + , unordered-containers ==0.2.* + , uuid-types ==1.0.* + , validation-selective ==0.2.* + , vector ==0.13.* + , word8 ==0.1.* + default-language: GHC2021 + if flag(dev) + ghc-options: -Werror + +test-suite bolty-integration + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_bolty + hs-source-dirs: + integration + 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-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-unused-imports -Wno-unused-packages + build-depends: + base >=4.18 && <5 + , bolty + , bytestring >=0.11 && <0.13 + , crypton-connection >=0.3 && <0.5 + , data-default >=0.7 && <0.9 + , extra >=1.7 && <1.9 + , mtl >=2.2 && <2.4 + , network >=3.1 && <3.3 + , packstream + , persist ==1.0.* + , sandwich + , split ==0.2.* + , text >=2.0 && <2.2 + , text-show >=3.10 && <3.12 + , unordered-containers + , validation-selective ==0.2.* + , vector + , word8 ==0.1.* + default-language: GHC2021 + if flag(dev) + ghc-options: -Werror + +test-suite bolty-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_bolty + 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-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N -Wno-missing-export-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-unused-imports -Wno-unused-packages + build-depends: + base >=4.18 && <5 + , bolty + , bytestring >=0.11 && <0.13 + , crypton-connection >=0.3 && <0.5 + , data-default >=0.7 && <0.9 + , extra >=1.7 && <1.9 + , mtl >=2.2 && <2.4 + , network >=3.1 && <3.3 + , packstream + , persist ==1.0.* + , sandwich + , split ==0.2.* + , text >=2.0 && <2.2 + , text-show >=3.10 && <3.12 + , unordered-containers + , validation-selective ==0.2.* + , vector + , word8 ==0.1.* + default-language: GHC2021 + if flag(dev) + ghc-options: -Werror diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,22 @@ +# Changelog for `bolty` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## 0.1.0.0 + +- Initial release +- BOLT protocol versions 4.4 through 5.4 +- Connection pooling via resource-pool +- Routing support with TTL-based caching +- Transaction support with automatic retry logic +- All Neo4j graph types: Node, Relationship, Path +- All Neo4j temporal types: Date, Time, LocalTime, DateTime, DateTimeZoneId, LocalDateTime, Duration +- Spatial types: Point2D, Point3D +- Typed record decoding with FromBolt/ToBolt typeclasses +- ResultSet with groupByField +- Query plan and profile parsing +- TLS support via crypton-connection diff --git a/integration/Main.hs b/integration/Main.hs new file mode 100644 --- /dev/null +++ b/integration/Main.hs @@ -0,0 +1,1607 @@ +module Main where + +import Control.Exception (SomeException, fromException, try) +import Control.Monad.IO.Class (liftIO) +import Test.Sandwich + +import Data.Default (def) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Validation as Val +import System.Environment (lookupEnv) + +import Data.Int (Int64) +import Data.IORef (newIORef, readIORef, writeIORef) +import Database.Bolty +import Database.Bolty.Connection (queryIO, queryPIO, queryIO') +import Database.Bolty.Message.Response (SuccessPull(..)) +import qualified Database.Bolty.Message.Response as Resp +import Database.Bolty.Decode (DecodeError(..)) +import Database.Bolty.Logging (QueryLog(..)) +import Database.Bolty.Notification (Notification(..), Severity(..)) +import Database.Bolty.Stats (QueryStats(..)) +import Database.Bolty.Value.Type (Node(..), Relationship(..), Path(..) + , Date(..), Time(..), LocalTime(..) + , DateTime(..), DateTimeZoneId(..) + , LocalDateTime(..), Duration(..) + , Point2D(..), Point3D(..)) +import Database.Bolty.Value.Helpers (supportsLogonLogoff, versionMajor, versionMinor) +import Data.PackStream.Ps (Ps(..)) + + +-- ================================================================ +-- Test types +-- ================================================================ + +-- | Example type used to test 'FromBolt' decoding. +data PersonResult = PersonResult T.Text Int64 + deriving (Show, Eq) + +instance FromBolt PersonResult where + rowDecoder = PersonResult + <$> field "name" Database.Bolty.text + <*> field "age" int64 + + +-- ================================================================ +-- Config helpers +-- ================================================================ + +-- | Neo4j 5 config: reads NEO4J_HOST/NEO4J_PORT, defaults to 127.0.0.1:7687 +neo4j5Config :: IO Config +neo4j5Config = do + h <- maybe "127.0.0.1" T.pack <$> lookupEnv "NEO4J_HOST" + p <- maybe 7687 read <$> lookupEnv "NEO4J_PORT" + pure def + { host = h + , port = p + , scheme = Basic "neo4j" "testpassword" + , use_tls = False + } + +-- | Neo4j 4.4 config: reads NEO4J_HOST/NEO4J_44_PORT, defaults to 127.0.0.1:7688 +neo4j44Config :: IO Config +neo4j44Config = do + h <- maybe "127.0.0.1" T.pack <$> lookupEnv "NEO4J_HOST" + p <- maybe 7688 read <$> lookupEnv "NEO4J_44_PORT" + pure def + { host = h + , port = p + , scheme = Basic "neo4j" "testpassword" + , use_tls = False + } + +-- | Config for the no-auth Neo4j instance (port 7689) +noAuthConfig :: IO Config +noAuthConfig = do + h <- maybe "127.0.0.1" T.pack <$> lookupEnv "NEO4J_HOST" + p <- maybe 7689 read <$> lookupEnv "NEO4J_NOAUTH_PORT" + pure def + { host = h + , port = p + , scheme = None + , use_tls = False + } + +-- | Validate a config or fail +mkGetConfig :: IO Config -> IO ValidatedConfig +mkGetConfig mkConfig = do + cfg <- mkConfig + case validateConfig cfg of + Val.Failure errs -> fail $ "Config invalid: " <> show errs + Val.Success vc -> pure vc + +-- | Connect, run action, close +mkWithConn :: IO Config -> (Connection -> IO a) -> IO a +mkWithConn mkConfig f = do + cfg <- mkGetConfig mkConfig + conn <- connect cfg + result <- f conn + close conn + pure result + + +-- ================================================================ +-- Core test suite — runs against any Neo4j version +-- ================================================================ + +coreTestSuite :: String -> IO Config -> TopSpec +coreTestSuite label mkConfig = do + let getConf = mkGetConfig mkConfig + let wp :: (Connection -> IO a) -> IO a + wp = mkWithConn mkConfig + + describe (label ++ " - Basic queries") $ do + + it "connects and disconnects" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + liftIO $ close pipe + + it "runs RETURN 1 and gets result" $ do + result <- liftIO $ wp $ \p -> queryIO p "RETURN 1 AS n" + V.length result `shouldBe` 1 + let record = V.head result + V.length record `shouldBe` 1 + case asInt (V.head record) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head record) + + it "runs RETURN with string" $ do + result <- liftIO $ wp $ \p -> queryIO p "RETURN 'hello' AS greeting" + V.length result `shouldBe` 1 + case asText (V.head $ V.head result) of + Just t -> t `shouldBe` "hello" + Nothing -> expectationFailure $ "Expected text, got: " <> show (V.head $ V.head result) + + it "runs UNWIND to get multiple rows" $ do + result <- liftIO $ wp $ \p -> queryIO p "UNWIND range(1, 5) AS n RETURN n" + V.length result `shouldBe` 5 + + it "runs query with full metadata" $ do + result <- liftIO $ wp $ \p -> queryIO' p "RETURN 42 AS answer" + V.length (Resp.records result) `shouldBe` 1 + + + describe (label ++ " - Parameterized queries") $ do + + it "passes integer parameter" $ do + result <- liftIO $ wp $ \p -> + queryPIO p "RETURN $x AS n" (H.singleton "x" (PsInteger 42)) + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure $ "Expected 42, got: " <> show (V.head $ V.head result) + + it "passes string parameter" $ do + result <- liftIO $ wp $ \p -> + queryPIO p "RETURN $name AS name" (H.singleton "name" (PsString "Neo")) + case asText (V.head $ V.head result) of + Just t -> t `shouldBe` "Neo" + Nothing -> expectationFailure $ "Expected 'Neo'" + + it "passes boolean parameter" $ do + result <- liftIO $ wp $ \p -> + queryPIO p "RETURN $b AS b" (H.singleton "b" (PsBoolean True)) + case asBool (V.head $ V.head result) of + Just b -> b `shouldBe` True + Nothing -> expectationFailure "Expected True" + + it "passes null parameter" $ do + result <- liftIO $ wp $ \p -> + queryPIO p "RETURN $x AS x" (H.singleton "x" PsNull) + case asNull (V.head $ V.head result) of + Just _ -> pure () + Nothing -> expectationFailure "Expected null" + + it "passes float parameter" $ do + result <- liftIO $ wp $ \p -> + queryPIO p "RETURN $x AS x" (H.singleton "x" (PsFloat 3.14)) + case asFloat (V.head $ V.head result) of + Just d -> d `shouldBe` 3.14 + Nothing -> expectationFailure "Expected 3.14" + + it "passes multiple parameters" $ do + result <- liftIO $ wp $ \p -> + queryPIO p "RETURN $a + $b AS sum" + (H.fromList [("a", PsInteger 10), ("b", PsInteger 32)]) + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + + it "passes list parameter" $ do + result <- liftIO $ wp $ \p -> + queryPIO p "UNWIND $xs AS x RETURN x" + (H.singleton "xs" (PsList $ V.fromList [PsInteger 1, PsInteger 2, PsInteger 3])) + V.length result `shouldBe` 3 + + + describe (label ++ " - Transactions") $ do + + it "withTransaction commits on success" $ do + liftIO $ wp $ \p -> + withTransaction p $ \conn -> do + _ <- queryIO conn "CREATE (n:TestCommit {value: 1})" + pure () + result <- liftIO $ wp $ \p -> + queryIO p "MATCH (n:TestCommit) RETURN n.value AS v" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestCommit) DELETE n" >> pure () + + it "withTransaction rolls back on error" $ do + liftIO $ wp $ \p -> queryIO p "CREATE (n:TestRollback {value: 1})" >> pure () + result :: Either SomeException () <- liftIO $ try $ + wp $ \p -> + withTransaction p $ \conn -> do + _ <- queryIO conn "MATCH (n:TestRollback) DELETE n" + _ <- queryIO conn "THIS IS NOT VALID CYPHER" + pure () + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected transaction to fail" + count <- liftIO $ wp $ \p -> + queryIO p "MATCH (n:TestRollback) RETURN count(n) AS c" + case asInt (V.head $ V.head count) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected count 1" + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestRollback) DELETE n" >> pure () + + it "multiple queries in a transaction" $ do + liftIO $ wp $ \p -> + withTransaction p $ \conn -> do + _ <- queryIO conn "CREATE (n:TestMulti {value: 1})" + _ <- queryIO conn "CREATE (n:TestMulti {value: 2})" + _ <- queryIO conn "CREATE (n:TestMulti {value: 3})" + pure () + result <- liftIO $ wp $ \p -> + queryIO p "MATCH (n:TestMulti) RETURN n.value AS v ORDER BY v" + V.length result `shouldBe` 3 + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestMulti) DELETE n" >> pure () + + it "query with parameters inside transaction" $ do + liftIO $ wp $ \p -> + withTransaction p $ \conn -> + queryPIO conn "CREATE (n:TestTxParam {name: $name})" (H.singleton "name" (PsString "alice")) + result <- liftIO $ wp $ \p -> + queryIO p "MATCH (n:TestTxParam) RETURN n.name AS name" + case asText (V.head $ V.head result) of + Just t -> t `shouldBe` "alice" + Nothing -> expectationFailure "Expected 'alice'" + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestTxParam) DELETE n" >> pure () + + + describe (label ++ " - Graph type queries") $ do + + it "returns a Node" $ do + result <- liftIO $ wp $ \p -> + queryIO p "CREATE (n:TestGraphNode {name: 'Alice', age: 30}) RETURN n" + V.length result `shouldBe` 1 + case asNode (V.head $ V.head result) of + Just Node{labels, properties} -> do + V.toList labels `shouldContain` ["TestGraphNode"] + case H.lookup "name" properties of + Just (PsString n) -> n `shouldBe` "Alice" + _ -> expectationFailure "Expected name property" + Nothing -> expectationFailure $ "Expected BoltNode, got: " <> show (V.head $ V.head result) + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestGraphNode) DELETE n" >> pure () + + it "returns a Relationship" $ do + liftIO $ wp $ \p -> + queryIO p "CREATE (a:TestGraphRelA)-[r:KNOWS {since: 2020}]->(b:TestGraphRelB) RETURN r" + result <- liftIO $ wp $ \p -> + queryIO p "MATCH (a:TestGraphRelA)-[r:KNOWS]->(b:TestGraphRelB) RETURN r" + V.length result `shouldBe` 1 + case asRelationship (V.head $ V.head result) of + Just Relationship{type_, properties} -> do + type_ `shouldBe` "KNOWS" + case H.lookup "since" properties of + Just (PsInteger n) -> n `shouldBe` 2020 + _ -> expectationFailure "Expected since property" + Nothing -> expectationFailure $ "Expected BoltRelationship, got: " <> show (V.head $ V.head result) + liftIO $ wp $ \p -> queryIO p "MATCH (a:TestGraphRelA)-[r]->(b:TestGraphRelB) DELETE r, a, b" >> pure () + + it "returns a Path" $ do + liftIO $ wp $ \p -> + queryIO p "CREATE (a:TestPath {name: 'start'})-[:STEP]->(b:TestPath {name: 'end'})" + result <- liftIO $ wp $ \p -> + queryIO p "MATCH p=(a:TestPath)-[*]->(b:TestPath) RETURN p" + V.length result `shouldBe` 1 + case asPath (V.head $ V.head result) of + Just path -> do + V.length (nodes path) `shouldBe` 2 + V.length (rels path) `shouldBe` 1 + Nothing -> expectationFailure $ "Expected BoltPath, got: " <> show (V.head $ V.head result) + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestPath) DETACH DELETE n" >> pure () + + it "returns a Date" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN date('2024-01-15') AS d" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltDate (Date dys) -> dys `shouldBe` 19737 + other -> expectationFailure $ "Expected BoltDate, got: " <> show other + + it "returns a Point2D" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN point({x: 1.0, y: 2.0, srid: 7203}) AS p" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltPoint2D Point2D{srid, x, y} -> do + srid `shouldBe` 7203 + x `shouldBe` 1.0 + y `shouldBe` 2.0 + other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other + + + describe (label ++ " - Temporal and spatial types") $ do + + it "returns a DateTime" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN datetime('2024-01-15T12:30:00Z') AS dt" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltDateTime _ -> pure () + other -> expectationFailure $ "Expected BoltDateTime, got: " <> show other + + it "returns a LocalDateTime" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN localdatetime('2024-01-15T12:30:00') AS ldt" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltLocalDateTime _ -> pure () + other -> expectationFailure $ "Expected BoltLocalDateTime, got: " <> show other + + it "returns a Time" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN time('12:30:00+01:00') AS t" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltTime _ -> pure () + other -> expectationFailure $ "Expected BoltTime, got: " <> show other + + it "returns a LocalTime" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN localtime('12:30:00') AS lt" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltLocalTime _ -> pure () + other -> expectationFailure $ "Expected BoltLocalTime, got: " <> show other + + it "returns a Date (temporal)" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN date('2024-01-15') AS d" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltDate _ -> pure () + other -> expectationFailure $ "Expected BoltDate, got: " <> show other + + it "returns a Duration" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN duration('P1Y2M3DT4H') AS dur" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltDuration _ -> pure () + other -> expectationFailure $ "Expected BoltDuration, got: " <> show other + + it "returns a Point2D (spatial)" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN point({x: 1.0, y: 2.0}) AS p" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltPoint2D _ -> pure () + other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other + + it "returns a Point3D" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN point({x: 1.0, y: 2.0, z: 3.0}) AS p" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltPoint3D _ -> pure () + other -> expectationFailure $ "Expected BoltPoint3D, got: " <> show other + + + describe (label ++ " - Retry transactions") $ do + + it "withRetryTransaction commits on success" $ do + liftIO $ wp $ \p -> + withRetryTransaction defaultRetryConfig p $ \conn -> do + _ <- queryIO conn "CREATE (n:TestRetryCommit {value: 1})" + pure () + result <- liftIO $ wp $ \p -> + queryIO p "MATCH (n:TestRetryCommit) RETURN n.value AS v" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestRetryCommit) DELETE n" >> pure () + + it "withRetryTransaction propagates non-transient errors" $ do + result :: Either SomeException () <- liftIO $ try $ + wp $ \p -> + withRetryTransaction defaultRetryConfig p $ \conn -> do + _ <- queryIO conn "THIS IS NOT VALID CYPHER" + pure () + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected non-transient error to propagate" + + it "withTransaction' works through pool" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + liftIO $ withTransaction' pool $ \conn -> do + _ <- queryIO conn "CREATE (n:TestPoolTx {value: 42})" + pure () + result <- liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestPoolTx) RETURN n.value AS v" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestPoolTx) DELETE n" >> pure () + liftIO $ destroyPool pool + + + describe (label ++ " - Connection health checks") $ do + + it "ping returns True on healthy connection" $ do + result <- liftIO $ wp $ \p -> do + healthy <- ping p + pure healthy + result `shouldBe` True + + it "ping resets state to Ready" $ do + liftIO $ wp $ \p -> do + _ <- queryIO p "RETURN 1 AS n" + healthy <- ping p + healthy `shouldBe` True + result <- queryIO p "RETURN 2 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 2 + Nothing -> fail "Expected 2" + + it "withConnection validates connections" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + result <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 42 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + liftIO $ destroyPool pool + + it "pool survives multiple checkout cycles" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + r1 <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 1 AS n" + r2 <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 2 AS n" + case asInt (V.head $ V.head r1) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + case asInt (V.head $ V.head r2) of + Just n -> n `shouldBe` 2 + Nothing -> expectationFailure "Expected 2" + liftIO $ destroyPool pool + + describe (label ++ " - Pipelining error recovery") $ do + + it "invalid query fails and connection recovers" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + result :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "INVALID CYPHER" + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected failure for invalid Cypher" + -- Connection should still work after error recovery + result2 <- liftIO $ queryIO pipe "RETURN 1 AS n" + V.length result2 `shouldBe` 1 + case asInt (V.head $ V.head result2) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result2) + liftIO $ close pipe + + it "multiple consecutive failures recover" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + -- Run 3 invalid queries in sequence, catching each + _ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "BAD QUERY 1" + _ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "BAD QUERY 2" + _ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "BAD QUERY 3" + -- Connection should still work + result <- liftIO $ queryIO pipe "RETURN 42 AS n" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result) + liftIO $ close pipe + + it "valid query works after error in auto-commit" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + -- First run a valid query to confirm connection works + r1 <- liftIO $ queryIO pipe "RETURN 'before' AS s" + V.length r1 `shouldBe` 1 + -- Trigger an error + _ :: Either SomeException (V.Vector Record) <- liftIO $ try $ queryIO pipe "NOT VALID CYPHER" + -- Run another valid query + r2 <- liftIO $ queryIO pipe "RETURN 'after' AS s" + V.length r2 `shouldBe` 1 + case asText (V.head $ V.head r2) of + Just t -> t `shouldBe` "after" + Nothing -> expectationFailure $ "Expected text, got: " <> show (V.head $ V.head r2) + liftIO $ close pipe + + it "connection recovers after transaction error" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + -- Transaction with invalid query should fail + _ :: Either SomeException () <- liftIO $ try $ + withTransaction pipe $ \conn -> do + _ <- queryIO conn "INVALID CYPHER IN TX" + pure () + -- Same connection should still work for a new transaction + liftIO $ withTransaction pipe $ \conn -> do + r <- queryIO conn "RETURN 'recovered' AS s" + case asText (V.head $ V.head r) of + Just t -> t `shouldBe` "recovered" + Nothing -> expectationFailure $ "Expected text, got: " <> show (V.head $ V.head r) + liftIO $ close pipe + + it "parameterized query error recovers" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + -- Invalid Cypher with parameters + _ :: Either SomeException (V.Vector Record) <- liftIO $ try $ + queryPIO pipe "NOT VALID $param" (H.singleton "param" (PsInteger 1)) + -- Connection should still work + result <- liftIO $ queryPIO pipe "RETURN $x AS n" (H.singleton "x" (PsInteger 99)) + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 99 + Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result) + liftIO $ close pipe + + +-- ================================================================ +-- Connection validation test suite +-- ================================================================ + +validationTestSuite :: String -> IO Config -> TopSpec +validationTestSuite label mkConfig = do + let getConf = mkGetConfig mkConfig + + describe (label ++ " - Connection validation") $ do + + it "AlwaysPing pool works" $ do + cfg <- liftIO getConf + let pc = defaultPoolConfig { validationStrategy = AlwaysPing } + pool <- liftIO $ createPool cfg pc + result <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 1 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ destroyPool pool + + it "NeverPing pool works" $ do + cfg <- liftIO getConf + let pc = defaultPoolConfig { validationStrategy = NeverPing } + pool <- liftIO $ createPool cfg pc + result <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 2 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 2 + Nothing -> expectationFailure "Expected 2" + liftIO $ destroyPool pool + + it "PingIfIdle 0 always pings (acts like AlwaysPing)" $ do + cfg <- liftIO getConf + let pc = defaultPoolConfig { validationStrategy = PingIfIdle 0 } + pool <- liftIO $ createPool cfg pc + result <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 3 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 3 + Nothing -> expectationFailure "Expected 3" + liftIO $ destroyPool pool + + it "PingIfIdle 3600 skips ping for recent connections" $ do + cfg <- liftIO getConf + let pc = defaultPoolConfig { validationStrategy = PingIfIdle 3600 } + pool <- liftIO $ createPool cfg pc + -- First use - will ping since connection is fresh from pool + r1 <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 10 AS n" + -- Second use - should skip ping (connection was just active) + r2 <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 20 AS n" + case asInt (V.head $ V.head r1) of + Just n -> n `shouldBe` 10 + Nothing -> expectationFailure "Expected 10" + case asInt (V.head $ V.head r2) of + Just n -> n `shouldBe` 20 + Nothing -> expectationFailure "Expected 20" + liftIO $ destroyPool pool + + it "pool survives multiple checkouts with AlwaysPing" $ do + cfg <- liftIO getConf + let pc = defaultPoolConfig { validationStrategy = AlwaysPing } + pool <- liftIO $ createPool cfg pc + results <- liftIO $ sequence + [ withConnection pool $ \p -> queryIO p "RETURN 1 AS n" + , withConnection pool $ \p -> queryIO p "RETURN 2 AS n" + , withConnection pool $ \p -> queryIO p "RETURN 3 AS n" + ] + length results `shouldBe` 3 + liftIO $ destroyPool pool + + it "withTransaction' works with NeverPing pool" $ do + cfg <- liftIO getConf + let pc = defaultPoolConfig { validationStrategy = NeverPing } + pool <- liftIO $ createPool cfg pc + liftIO $ withTransaction' pool $ \conn -> do + _ <- queryIO conn "CREATE (n:TestNeverPingTx {value: 1})" + pure () + result <- liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestNeverPingTx) RETURN n.value AS v" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestNeverPingTx) DELETE n" >> pure () + liftIO $ destroyPool pool + + +-- ================================================================ +-- Routing test suite — runs against any Neo4j version +-- ================================================================ + +routingTestSuite :: String -> IO Config -> TopSpec +routingTestSuite label mkBaseConfig = do + let mkRoutingConfig = do + cfg <- mkBaseConfig + pure cfg { routing = Routing } + let getRoutingConf = mkGetConfig mkRoutingConfig + let wrp f = do + cfg <- getRoutingConf + pipe <- connect cfg + result <- f pipe + close pipe + pure result + + describe (label ++ " - Routing") $ do + + it "fetches routing table" $ do + result <- liftIO $ wrp $ \p -> + getRoutingTable p Nothing + (ttl result > 0) `shouldBe` True + (V.length (writers result) > 0) `shouldBe` True + (V.length (readers result) > 0) `shouldBe` True + (V.length (routers result) > 0) `shouldBe` True + + it "routing table addresses contain host:port format" $ do + result <- liftIO $ wrp $ \p -> + getRoutingTable p Nothing + let allAddrs = writers result <> readers result <> routers result + V.forM_ allAddrs $ \addr -> + T.isInfixOf ":" addr `shouldBe` True + + it "withRoutingConnection ReadAccess executes a read query" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + result <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 1 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected integer 1" + liftIO $ destroyRoutingPool rp + + it "withRoutingConnection WriteAccess executes a write query" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + liftIO $ withRoutingConnection rp WriteAccess $ \p -> + queryIO p "CREATE (n:TestRoutingWrite {value: 1})" >> pure () + result <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "MATCH (n:TestRoutingWrite) RETURN n.value AS v" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ withRoutingConnection rp WriteAccess $ \p -> + queryIO p "MATCH (n:TestRoutingWrite) DELETE n" >> pure () + liftIO $ destroyRoutingPool rp + + it "withRoutingTransaction creates and reads back data" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + liftIO $ withRoutingTransaction rp WriteAccess $ \conn -> do + _ <- queryIO conn "CREATE (n:TestRoutingTx {value: 42})" + pure () + result <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "MATCH (n:TestRoutingTx) RETURN n.value AS v" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + liftIO $ withRoutingConnection rp WriteAccess $ \p -> + queryIO p "MATCH (n:TestRoutingTx) DELETE n" >> pure () + liftIO $ destroyRoutingPool rp + + it "routing works after forced table refresh" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + _ <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 1 AS n" + result <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 2 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 2 + Nothing -> expectationFailure "Expected 2" + liftIO $ destroyRoutingPool rp + + +-- ================================================================ +-- Auth scheme tests (Neo4j 5 only — uses no-auth server on port 7689) +-- ================================================================ + +-- | Check if an Error is AuthentificationFailed +isAuthFailed :: SomeException -> Bool +isAuthFailed e = case fromException e of + Just AuthentificationFailed -> True + _ -> False + +authSchemeTests :: TopSpec +authSchemeTests = do + let wpNoAuth = mkWithConn noAuthConfig + + describe "Auth schemes" $ do + + it "connects with None scheme to no-auth server" $ do + result <- liftIO $ wpNoAuth $ \p -> queryIO p "RETURN 1 AS n" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure $ "Expected integer, got: " <> show (V.head $ V.head result) + + it "None scheme fails on auth-required server" $ do + cfg <- liftIO neo4j5Config + let noneConfig = cfg { scheme = None } + case validateConfig noneConfig of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + result :: Either SomeException () <- liftIO $ try $ do + pipe <- connect vc + _ <- queryIO pipe "RETURN 1" + close pipe + case result of + Left e | isAuthFailed e -> pure () + Left e -> expectationFailure $ "Expected AuthentificationFailed, got: " <> show e + Right _ -> expectationFailure "Expected authentication to fail" + + it "Basic auth with wrong password fails" $ do + cfg <- liftIO neo4j5Config + let badConfig = cfg { scheme = Basic "neo4j" "wrongpassword" } + case validateConfig badConfig of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + result :: Either SomeException () <- liftIO $ try $ do + pipe <- connect vc + _ <- queryIO pipe "RETURN 1" + close pipe + case result of + Left e | isAuthFailed e -> pure () + Left e -> expectationFailure $ "Expected AuthentificationFailed, got: " <> show e + Right _ -> expectationFailure "Expected authentication to fail" + + +-- ================================================================ +-- Session test suite — managed transactions with bookmarks +-- ================================================================ + +sessionTestSuite :: String -> IO Config -> TopSpec +sessionTestSuite label mkConfig = do + let getConf = mkGetConfig mkConfig + + describe (label ++ " - Sessions") $ do + + it "writeTransaction commits and returns result" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + session <- liftIO $ createSession pool defaultSessionConfig + result <- liftIO $ writeTransaction session $ \conn -> + queryIO conn "CREATE (n:TestSessionWrite {value: 1}) RETURN n.value AS v" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + -- cleanup + liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestSessionWrite) DELETE n" >> pure () + liftIO $ destroyPool pool + + it "readTransaction executes read query" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + session <- liftIO $ createSession pool defaultSessionConfig + result <- liftIO $ readTransaction session $ \conn -> + queryIO conn "RETURN 42 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + liftIO $ destroyPool pool + + it "writeTransaction rolls back on error" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + session <- liftIO $ createSession pool defaultSessionConfig + -- First create a node to verify rollback later + liftIO $ withConnection pool $ \p -> + queryIO p "CREATE (n:TestSessionRB {value: 1})" >> pure () + -- Transaction that should fail and rollback + result :: Either SomeException () <- liftIO $ try $ + writeTransaction session $ \conn -> do + _ <- queryIO conn "MATCH (n:TestSessionRB) DELETE n" + _ <- queryIO conn "THIS IS NOT VALID CYPHER" + pure () + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected transaction to fail" + -- Node should still exist (rollback) + count <- liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestSessionRB) RETURN count(n) AS c" + case asInt (V.head $ V.head count) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected count 1" + liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestSessionRB) DELETE n" >> pure () + liftIO $ destroyPool pool + + it "writeTransaction produces a bookmark" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + session <- liftIO $ createSession pool defaultSessionConfig + -- Before any transaction, bookmarks should be empty + bms0 <- liftIO $ getLastBookmarks session + bms0 `shouldBe` [] + -- After a write transaction, there should be a bookmark + liftIO $ writeTransaction session $ \conn -> + queryIO conn "CREATE (n:TestSessionBM {value: 1})" >> pure () + bms1 <- liftIO $ getLastBookmarks session + length bms1 `shouldBe` 1 + -- Cleanup + liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestSessionBM) DELETE n" >> pure () + liftIO $ destroyPool pool + + it "bookmarks update after each transaction" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + session <- liftIO $ createSession pool defaultSessionConfig + -- First transaction + liftIO $ writeTransaction session $ \conn -> + queryIO conn "CREATE (n:TestSessionBM2 {value: 1})" >> pure () + bms1 <- liftIO $ getLastBookmarks session + length bms1 `shouldBe` 1 + -- Second transaction + liftIO $ writeTransaction session $ \conn -> + queryIO conn "CREATE (n:TestSessionBM2 {value: 2})" >> pure () + bms2 <- liftIO $ getLastBookmarks session + length bms2 `shouldBe` 1 + -- Bookmark should have changed + (bms1 /= bms2) `shouldBe` True + -- Cleanup + liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestSessionBM2) DELETE n" >> pure () + liftIO $ destroyPool pool + + it "initial bookmarks are passed to first transaction" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + -- First session: create data and get bookmark + session1 <- liftIO $ createSession pool defaultSessionConfig + liftIO $ writeTransaction session1 $ \conn -> + queryIO conn "CREATE (n:TestSessionCross {value: 99})" >> pure () + bms <- liftIO $ getLastBookmarks session1 + -- Second session: use bookmark from first session + let cfg2 = defaultSessionConfig { sessionBookmarks = bms } + session2 <- liftIO $ createSession pool cfg2 + result <- liftIO $ readTransaction session2 $ \conn -> + queryIO conn "MATCH (n:TestSessionCross) RETURN n.value AS v" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 99 + Nothing -> expectationFailure "Expected 99" + -- Cleanup + liftIO $ withConnection pool $ \p -> + queryIO p "MATCH (n:TestSessionCross) DELETE n" >> pure () + liftIO $ destroyPool pool + + +-- ================================================================ +-- Routing session tests +-- ================================================================ + +routingSessionTests :: TopSpec +routingSessionTests = do + let getRoutingConf = mkGetConfig (do cfg <- neo4j5Config; pure cfg { routing = Routing }) + + describe "Routing sessions" $ do + + it "createRoutingSession + writeTransaction works" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + session <- liftIO $ createRoutingSession rp defaultSessionConfig + liftIO $ writeTransaction session $ \conn -> + queryIO conn "CREATE (n:TestRoutingSession {value: 1})" >> pure () + result <- liftIO $ readTransaction session $ \conn -> + queryIO conn "MATCH (n:TestRoutingSession) RETURN n.value AS v" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + -- Cleanup + liftIO $ withRoutingConnection rp WriteAccess $ \p -> + queryIO p "MATCH (n:TestRoutingSession) DELETE n" >> pure () + liftIO $ destroyRoutingPool rp + + it "routing session produces bookmarks" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + session <- liftIO $ createRoutingSession rp defaultSessionConfig + bms0 <- liftIO $ getLastBookmarks session + bms0 `shouldBe` [] + liftIO $ writeTransaction session $ \conn -> + queryIO conn "CREATE (n:TestRoutingSessBM {value: 1})" >> pure () + bms1 <- liftIO $ getLastBookmarks session + length bms1 `shouldBe` 1 + -- Cleanup + liftIO $ withRoutingConnection rp WriteAccess $ \p -> + queryIO p "MATCH (n:TestRoutingSessBM) DELETE n" >> pure () + liftIO $ destroyRoutingPool rp + + +-- ================================================================ +-- Failover tests +-- ================================================================ + +failoverTests :: TopSpec +failoverTests = do + let getRoutingConf = mkGetConfig (do cfg <- neo4j5Config; pure cfg { routing = Routing }) + + describe "Failover" $ do + + it "withRoutingConnection works after cache invalidation" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + -- Normal operation + r1 <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 1 AS n" + case asInt (V.head $ V.head r1) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + -- Invalidate cache and verify it still works (triggers refresh) + liftIO $ invalidateRoutingTable rp + r2 <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 2 AS n" + case asInt (V.head $ V.head r2) of + Just n -> n `shouldBe` 2 + Nothing -> expectationFailure "Expected 2" + liftIO $ destroyRoutingPool rp + + it "withRoutingTransaction works after cache invalidation" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + liftIO $ invalidateRoutingTable rp + liftIO $ withRoutingTransaction rp WriteAccess $ \conn -> do + _ <- queryIO conn "CREATE (n:TestFailoverTx {value: 1})" + pure () + result <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "MATCH (n:TestFailoverTx) RETURN n.value AS v" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ withRoutingConnection rp WriteAccess $ \p -> + queryIO p "MATCH (n:TestFailoverTx) DELETE n" >> pure () + liftIO $ destroyRoutingPool rp + + it "session writeTransaction works after cache invalidation" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + session <- liftIO $ createRoutingSession rp defaultSessionConfig + liftIO $ invalidateRoutingTable rp + liftIO $ writeTransaction session $ \conn -> do + _ <- queryIO conn "CREATE (n:TestFailoverSess {value: 1})" + pure () + result <- liftIO $ readTransaction session $ \conn -> + queryIO conn "MATCH (n:TestFailoverSess) RETURN n.value AS v" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ withRoutingConnection rp WriteAccess $ \p -> + queryIO p "MATCH (n:TestFailoverSess) DELETE n" >> pure () + liftIO $ destroyRoutingPool rp + + it "repeated cache invalidation does not break operations" $ do + cfg <- liftIO getRoutingConf + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + -- Invalidate multiple times + liftIO $ invalidateRoutingTable rp + liftIO $ invalidateRoutingTable rp + liftIO $ invalidateRoutingTable rp + result <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 42 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + liftIO $ destroyRoutingPool rp + + +-- ================================================================ +-- Routing edge case tests (shared, uses Neo4j 5 config) +-- ================================================================ + +routingEdgeCaseTests :: TopSpec +routingEdgeCaseTests = do + let wp5 = mkWithConn neo4j5Config + let getRoutingConf5 = mkGetConfig (do cfg <- neo4j5Config; pure cfg { routing = Routing }) + + describe "Routing edge cases" $ do + + it "getRoutingTable works even without routing flag in HELLO" $ do + -- CE accepts ROUTE even without routing in HELLO + result <- liftIO $ wp5 $ \p -> getRoutingTable p Nothing + (ttl result > 0) `shouldBe` True + + it "createRoutingPool to unreachable host fails" $ do + cfg <- liftIO neo4j5Config + let badCfg = cfg { host = "192.0.2.1", port = 19999, scheme = None } + case validateConfig badCfg of + Val.Failure _ -> expectationFailure "Config should validate" + Val.Success vc -> do + result :: Either SomeException RoutingPool <- liftIO $ try $ + createRoutingPool vc defaultRoutingPoolConfig + case result of + Left _ -> pure () + Right rp -> do + liftIO $ destroyRoutingPool rp + expectationFailure "Expected failure connecting to unreachable host" + + it "routing pool reuses cached table on consecutive calls" $ do + cfg <- liftIO getRoutingConf5 + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + r1 <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 1 AS n" + r2 <- liftIO $ withRoutingConnection rp ReadAccess $ \p -> + queryIO p "RETURN 2 AS n" + case asInt (V.head $ V.head r1) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + case asInt (V.head $ V.head r2) of + Just n -> n `shouldBe` 2 + Nothing -> expectationFailure "Expected 2" + liftIO $ destroyRoutingPool rp + + it "destroyRoutingPool is idempotent" $ do + cfg <- liftIO getRoutingConf5 + rp <- liftIO $ createRoutingPool cfg defaultRoutingPoolConfig + liftIO $ destroyRoutingPool rp + liftIO $ destroyRoutingPool rp + + +-- ================================================================ +-- LOGON/LOGOFF tests (Bolt 5.1+) +-- ================================================================ + +logonLogoffTestSuite :: TopSpec +logonLogoffTestSuite = do + let getConf = mkGetConfig neo4j5Config + let wp :: (Connection -> IO a) -> IO a + wp = mkWithConn neo4j5Config + + describe "LOGON/LOGOFF (Bolt 5.1+)" $ do + + it "connects with 5.1+ handshake (HELLO + LOGON)" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + -- Verify negotiated version is 5.1+ + let ver = connectionVersion pipe + versionMajor ver `shouldBe` 5 + (versionMinor ver >= 1) `shouldBe` True + liftIO $ close pipe + + it "queries work after 5.1+ handshake" $ do + result <- liftIO $ wp $ \p -> queryIO p "RETURN 42 AS n" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + + it "transactions work after 5.1+ handshake" $ do + liftIO $ wp $ \p -> + withTransaction p $ \conn -> do + _ <- queryIO conn "CREATE (n:TestLogonTx {value: 1})" + pure () + result <- liftIO $ wp $ \p -> + queryIO p "MATCH (n:TestLogonTx) RETURN n.value AS v" + V.length result `shouldBe` 1 + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ wp $ \p -> queryIO p "MATCH (n:TestLogonTx) DELETE n" >> pure () + + it "logoff + logon re-authenticates on same connection" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + -- Verify version supports logon/logoff + let ver = connectionVersion pipe + if supportsLogonLogoff ver then do + -- Query before logoff + r1 <- liftIO $ queryIO pipe "RETURN 1 AS n" + case asInt (V.head $ V.head r1) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + -- Logoff and logon again + liftIO $ logoff pipe + liftIO $ logon pipe (Basic "neo4j" "testpassword") + -- Query after re-auth + r2 <- liftIO $ queryIO pipe "RETURN 2 AS n" + case asInt (V.head $ V.head r2) of + Just n -> n `shouldBe` 2 + Nothing -> expectationFailure "Expected 2" + else + pure () -- skip on 5.0 + liftIO $ close pipe + + it "logoff + logon with None scheme on no-auth server" $ do + naCfg <- liftIO $ mkGetConfig noAuthConfig + pipe <- liftIO $ connect naCfg + let ver = connectionVersion pipe + if supportsLogonLogoff ver then do + r1 <- liftIO $ queryIO pipe "RETURN 1 AS n" + case asInt (V.head $ V.head r1) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ logoff pipe + liftIO $ logon pipe None + r2 <- liftIO $ queryIO pipe "RETURN 2 AS n" + case asInt (V.head $ V.head r2) of + Just n -> n `shouldBe` 2 + Nothing -> expectationFailure "Expected 2" + else + pure () + liftIO $ close pipe + + +-- ================================================================ +-- Telemetry tests +-- ================================================================ + +telemetryTestSuite :: TopSpec +telemetryTestSuite = do + let getConf = mkGetConfig neo4j5Config + + describe "Telemetry" $ do + + it "sendTelemetry does not break operations" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + -- Send telemetry (no-op if server doesn't support it) + liftIO $ sendTelemetry pipe ManagedTransactions + -- Verify connection still works + result <- liftIO $ queryIO pipe "RETURN 1 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ close pipe + + it "session telemetry does not break managed transactions" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + session <- liftIO $ createSession pool defaultSessionConfig + result <- liftIO $ writeTransaction session $ \conn -> + queryIO conn "RETURN 42 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 42 + Nothing -> expectationFailure "Expected 42" + -- Second transaction should also work (telemetry already sent) + result2 <- liftIO $ readTransaction session $ \conn -> + queryIO conn "RETURN 99 AS n" + case asInt (V.head $ V.head result2) of + Just n -> n `shouldBe` 99 + Nothing -> expectationFailure "Expected 99" + liftIO $ destroyPool pool + + +-- ================================================================ +-- Query logging integration tests +-- ================================================================ + +setQueryLogger :: Maybe (QueryLog -> QueryMeta -> IO ()) -> Config -> Config +setQueryLogger ql Config{..} = Config { queryLogger = ql, .. } + +loggingTestSuite :: TopSpec +loggingTestSuite = do + + describe "Query logging" $ do + + it "logger callback fires and receives correct cypher" $ do + logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog) + cfg <- liftIO neo4j5Config + let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg + case validateConfig cfgWithLogger of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + pipe <- liftIO $ connect vc + _ <- liftIO $ queryIO pipe "RETURN 1 AS n" + liftIO $ close pipe + logged <- liftIO $ readIORef logRef + case logged of + Nothing -> expectationFailure "Logger should have been called" + Just ql -> qlCypher ql `shouldBe` "RETURN 1 AS n" + + it "logger reports correct row count" $ do + logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog) + cfg <- liftIO neo4j5Config + let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg + case validateConfig cfgWithLogger of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + pipe <- liftIO $ connect vc + _ <- liftIO $ queryIO pipe "UNWIND range(1, 5) AS n RETURN n" + liftIO $ close pipe + logged <- liftIO $ readIORef logRef + case logged of + Nothing -> expectationFailure "Logger should have been called" + Just ql -> qlRowCount ql `shouldBe` 5 + + it "client timing is positive" $ do + logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog) + cfg <- liftIO neo4j5Config + let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg + case validateConfig cfgWithLogger of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + pipe <- liftIO $ connect vc + _ <- liftIO $ queryIO pipe "RETURN 1 AS n" + liftIO $ close pipe + logged <- liftIO $ readIORef logRef + case logged of + Nothing -> expectationFailure "Logger should have been called" + Just ql -> (qlClientTime ql > 0) `shouldBe` True + + it "server timing values are non-negative" $ do + logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog) + cfg <- liftIO neo4j5Config + let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg + case validateConfig cfgWithLogger of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + pipe <- liftIO $ connect vc + _ <- liftIO $ queryIO pipe "RETURN 1 AS n" + liftIO $ close pipe + logged <- liftIO $ readIORef logRef + case logged of + Nothing -> expectationFailure "Logger should have been called" + Just ql -> do + (qlServerFirst ql >= 0) `shouldBe` True + (qlServerLast ql >= 0) `shouldBe` True + + it "logger fires for parameterized queries" $ do + logRef <- liftIO $ newIORef (Nothing :: Maybe QueryLog) + cfg <- liftIO neo4j5Config + let cfgWithLogger = setQueryLogger (Just (\ql _meta -> writeIORef logRef (Just ql))) cfg + case validateConfig cfgWithLogger of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + pipe <- liftIO $ connect vc + _ <- liftIO $ queryPIO pipe "RETURN $x AS n" (H.singleton "x" (PsInteger 42)) + liftIO $ close pipe + logged <- liftIO $ readIORef logRef + case logged of + Nothing -> expectationFailure "Logger should have been called" + Just ql -> do + qlCypher ql `shouldBe` "RETURN $x AS n" + H.member "x" (qlParameters ql) `shouldBe` True + + +-- ================================================================ +-- Notification integration tests +-- ================================================================ + +notificationTestSuite :: TopSpec +notificationTestSuite = do + + describe "Notifications" $ do + + it "notification handler fires for cartesian product warning" $ do + notifsRef <- liftIO $ newIORef ([] :: [Notification]) + cfg <- liftIO neo4j5Config + let cfgWithHandler = cfg { notificationHandler = Just (\n -> do + ns <- readIORef notifsRef + writeIORef notifsRef (n : ns)) } + case validateConfig cfgWithHandler of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + pipe <- liftIO $ connect vc + -- A cartesian product query should produce a notification + _ <- liftIO $ queryIO pipe "MATCH (a), (b) RETURN count(*)" + liftIO $ close pipe + notifs <- liftIO $ readIORef notifsRef + (length notifs > 0) `shouldBe` True + -- At least one should be about cartesian product + let codes = map nCode notifs + any (T.isInfixOf "CartesianProduct") codes `shouldBe` True + + it "parsedNotifications available via queryMeta" $ do + cfg <- liftIO $ mkGetConfig neo4j5Config + pipe <- liftIO $ connect cfg + result <- liftIO $ queryIO' pipe "MATCH (a), (b) RETURN count(*)" + liftIO $ close pipe + let notifs = parsedNotifications (infos result) + (V.length notifs > 0) `shouldBe` True + + it "no notifications for simple query" $ do + notifsRef <- liftIO $ newIORef ([] :: [Notification]) + cfg <- liftIO neo4j5Config + let cfgWithHandler = cfg { notificationHandler = Just (\n -> do + ns <- readIORef notifsRef + writeIORef notifsRef (n : ns)) } + case validateConfig cfgWithHandler of + Val.Failure errs -> liftIO $ fail $ "Config invalid: " <> show errs + Val.Success vc -> do + pipe <- liftIO $ connect vc + _ <- liftIO $ queryIO pipe "RETURN 1 AS n" + liftIO $ close pipe + notifs <- liftIO $ readIORef notifsRef + length notifs `shouldBe` 0 + + +-- ================================================================ +-- Query stats integration tests +-- ================================================================ + +statsTestSuite :: TopSpec +statsTestSuite = do + let wp :: (Connection -> IO a) -> IO a + wp = mkWithConn neo4j5Config + + describe "Query statistics" $ do + + it "CREATE query has nodesCreated == 1" $ do + result <- liftIO $ wp $ \p -> do + r <- queryIO' p "CREATE (n:TestStats {value: 1}) RETURN n" + _ <- queryIO p "MATCH (n:TestStats) DELETE n" + pure r + case parsedStats (infos result) of + Nothing -> expectationFailure "Expected stats for CREATE query" + Just qs -> nodesCreated qs `shouldBe` 1 + + it "read-only query has no stats" $ do + result <- liftIO $ wp $ \p -> queryIO' p "RETURN 1 AS n" + parsedStats (infos result) `shouldBe` Nothing + + it "CREATE + SET has propertiesSet > 0" $ do + result <- liftIO $ wp $ \p -> do + r <- queryIO' p "CREATE (n:TestStats2 {a: 1, b: 2}) RETURN n" + _ <- queryIO p "MATCH (n:TestStats2) DELETE n" + pure r + case parsedStats (infos result) of + Nothing -> expectationFailure "Expected stats" + Just qs -> (propertiesSet qs > 0) `shouldBe` True + + +-- ================================================================ +-- Server hints integration tests +-- ================================================================ + +serverHintTestSuite :: TopSpec +serverHintTestSuite = do + let getConf = mkGetConfig neo4j5Config + + describe "Server hints" $ do + + it "Neo4j 5 reports server idle timeout" $ do + cfg <- liftIO getConf + pipe <- liftIO $ connect cfg + let sto = connectionServerIdleTimeout pipe + liftIO $ close pipe + -- Neo4j 5 should report a timeout (typically 120 seconds) + case sto of + Just secs -> (secs > 0) `shouldBe` True + Nothing -> pure () -- Some Neo4j configs may not send this + + it "pool works with server idle timeout hint" $ do + cfg <- liftIO getConf + pool <- liftIO $ createPool cfg defaultPoolConfig + result <- liftIO $ withConnection pool $ \p -> + queryIO p "RETURN 1 AS n" + case asInt (V.head $ V.head result) of + Just n -> n `shouldBe` 1 + Nothing -> expectationFailure "Expected 1" + liftIO $ destroyPool pool + + +-- ================================================================ +-- Decode integration tests +-- ================================================================ + +decodeTestSuite :: TopSpec +decodeTestSuite = do + let wp :: (Connection -> IO a) -> IO a + wp = mkWithConn neo4j5Config + + describe "Record decoding (integration)" $ do + + it "queryWith decodes RETURN 1 with column 0 int64" $ do + result <- liftIO $ wp $ \p -> runBolt p $ + queryWith (column 0 int64) "RETURN 1 AS n" mempty + case result of + Right v -> do + V.length v `shouldBe` 1 + V.head v `shouldBe` (1 :: Int64) + Left e -> expectationFailure $ "Expected Right, got: " <> show e + + it "queryWith with parameters decodes correctly" $ do + result <- liftIO $ wp $ \p -> runBolt p $ + queryWith (column 0 int64) "RETURN $x AS n" (H.singleton "x" (PsInteger 42)) + case result of + Right v -> V.head v `shouldBe` (42 :: Int64) + Left e -> expectationFailure $ "Expected Right, got: " <> show e + + it "queryWith with field 'name' text" $ do + result <- liftIO $ wp $ \p -> runBolt p $ + queryWith (field "name" Database.Bolty.text) "RETURN 'hello' AS name" mempty + case result of + Right v -> V.head v `shouldBe` "hello" + Left e -> expectationFailure $ "Expected Right, got: " <> show e + + it "queryWith returns Left on type mismatch" $ do + result <- liftIO $ wp $ \p -> runBolt p $ + queryWith (field "n" Database.Bolty.text) "RETURN 1 AS n" mempty + case result of + Left (TypeMismatch _ _) -> pure () + other -> expectationFailure $ "Expected Left TypeMismatch, got: " <> show other + + it "queryWith with multi-column Applicative decoder" $ do + result <- liftIO $ wp $ \p -> runBolt p $ + queryWith ((,) <$> field "name" Database.Bolty.text <*> field "age" int64) + "RETURN 'Alice' AS name, 30 AS age" mempty + case result of + Right v -> V.head v `shouldBe` ("Alice" :: T.Text, 30 :: Int64) + Left e -> expectationFailure $ "Expected Right, got: " <> show e + + it "query with FromBolt instance" $ do + result <- liftIO $ wp $ \p -> runBolt p $ + query "RETURN 'Alice' AS name, 30 AS age" mempty + case result of + Right v -> do + let PersonResult n a = V.head v + n `shouldBe` "Alice" + a `shouldBe` (30 :: Int64) + Left e -> expectationFailure $ "Expected Right, got: " <> show e + + it "queryResult + decodeResultSet for multi-pass decoding" $ do + rs <- liftIO $ wp $ \p -> runBolt p $ + queryResult "RETURN 'Alice' AS name, 30 AS age" mempty + case decodeResultSet (field "name" Database.Bolty.text) rs of + Right names -> V.head names `shouldBe` "Alice" + Left e -> expectationFailure $ "Expected Right, got: " <> show e + case decodeResultSet (field "age" int64) rs of + Right ages -> V.head ages `shouldBe` (30 :: Int64) + Left e -> expectationFailure $ "Expected Right, got: " <> show e + + it "queryMeta returns metadata" $ do + (rs, meta) <- liftIO $ wp $ \p -> runBolt p $ + queryResultMeta "RETURN 1 AS n" mempty + case decodeResultSet (field "n" int64) rs of + Right v -> V.head v `shouldBe` (1 :: Int64) + Left e -> expectationFailure $ "Expected Right, got: " <> show e + -- QueryMeta should have a bookmark + case bookmark meta of + Just _ -> pure () + Nothing -> pure () -- not all servers return bookmarks for auto-commit + + it "BoltM monadic pattern" $ do + liftIO $ wp $ \conn -> runBolt conn $ do + result <- query "RETURN 'hello' AS name, 42 AS age" mempty + case result of + Right v -> liftIO $ V.head v `shouldBe` PersonResult "hello" 42 + Left e -> liftIO $ expectationFailure $ show e + + +-- ================================================================ +-- Temporal type tests — runs against any Neo4j version +-- ================================================================ + +temporalTestSuite :: String -> IO Config -> TopSpec +temporalTestSuite label mkConfig = do + let wp :: (Connection -> IO a) -> IO a + wp = mkWithConn mkConfig + + describe (label ++ " - Temporal types") $ do + + it "returns a DateTime" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN datetime('2024-01-15T12:30:00Z') AS dt" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltDateTime DateTime{seconds, nanoseconds} -> do + (seconds > 0) `shouldBe` True + nanoseconds `shouldBe` 0 + other -> expectationFailure $ "Expected BoltDateTime, got: " <> show other + + it "returns a LocalDateTime" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN localdatetime('2024-01-15T12:30:00') AS ldt" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltLocalDateTime LocalDateTime{seconds, nanoseconds} -> do + (seconds > 0) `shouldBe` True + nanoseconds `shouldBe` 0 + other -> expectationFailure $ "Expected BoltLocalDateTime, got: " <> show other + + it "returns a Time" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN time('12:30:00+01:00') AS t" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltTime Time{nanoseconds, tz_offset_seconds} -> do + (nanoseconds > 0) `shouldBe` True + tz_offset_seconds `shouldBe` 3600 + other -> expectationFailure $ "Expected BoltTime, got: " <> show other + + it "returns a LocalTime" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN localtime('12:30:00') AS lt" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltLocalTime LocalTime{nanoseconds} -> + (nanoseconds > 0) `shouldBe` True + other -> expectationFailure $ "Expected BoltLocalTime, got: " <> show other + + it "returns a Duration" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN duration('P1Y2M3DT4H') AS d" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltDuration _ -> pure () + other -> expectationFailure $ "Expected BoltDuration, got: " <> show other + + it "returns a DateTimeZoneId" $ do + result <- liftIO $ wp $ \p -> + queryIO p "RETURN datetime({year: 2024, month: 1, day: 15, hour: 12, timezone: 'Europe/Paris'}) AS dtz" + V.length result `shouldBe` 1 + case V.head $ V.head result of + BoltDateTimeZoneId DateTimeZoneId{tz_id} -> + tz_id `shouldBe` "Europe/Paris" + other -> expectationFailure $ "Expected BoltDateTimeZoneId, got: " <> show other + + +-- ================================================================ +-- Main +-- ================================================================ + +main :: IO () +main = runSandwichWithCommandLineArgs defaultOptions $ do + -- Core test suite against Neo4j 5 + coreTestSuite "Neo4j 5" neo4j5Config + -- Core test suite against Neo4j 4.4 + coreTestSuite "Neo4j 4.4" neo4j44Config + -- Connection validation tests + validationTestSuite "Neo4j 5" neo4j5Config + validationTestSuite "Neo4j 4.4" neo4j44Config + -- Routing tests against Neo4j 5 + routingTestSuite "Neo4j 5" neo4j5Config + -- Routing tests against Neo4j 4.4 + routingTestSuite "Neo4j 4.4" neo4j44Config + -- Session tests against Neo4j 5 + sessionTestSuite "Neo4j 5" neo4j5Config + -- Session tests against Neo4j 4.4 + sessionTestSuite "Neo4j 4.4" neo4j44Config + -- Routing session tests (Neo4j 5 only - requires routing pool) + routingSessionTests + -- Failover tests (Neo4j 5 only) + failoverTests + -- Auth scheme tests (Neo4j 5 + no-auth server) + authSchemeTests + -- Routing edge cases + routingEdgeCaseTests + -- LOGON/LOGOFF tests (Bolt 5.1+) + logonLogoffTestSuite + -- Telemetry tests + telemetryTestSuite + -- Query logging tests (Neo4j 5) + loggingTestSuite + -- Notification tests (Neo4j 5) + notificationTestSuite + -- Query stats tests (Neo4j 5) + statsTestSuite + -- Server hints tests (Neo4j 5) + serverHintTestSuite + -- Decode tests (Neo4j 5) + decodeTestSuite + -- Temporal type tests + temporalTestSuite "Neo4j 5" neo4j5Config + temporalTestSuite "Neo4j 4.4" neo4j44Config diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,358 @@ +# bolty + +Native Haskell driver for [Neo4j](https://neo4j.com/) using the BOLT protocol (versions 4.4 through 5.4). + +## Features + +- **Connection pooling** with configurable idle timeout, health checks, and validation strategies +- **Cluster routing** — automatic server discovery and read/write splitting for Neo4j causal clusters +- **Sessions** with bookmark-based causal consistency across transactions +- **Transactions** with automatic retry on transient errors (exponential backoff) +- **Type-safe record decoding** — composable `Decode` / `RowDecoder` combinators, or derive via `FromBolt` +- **All Neo4j types** — nodes, relationships, paths, temporal (date, time, datetime, duration), spatial (point2D, point3D) +- **Query metadata** — server timing, query statistics, notifications, EXPLAIN/PROFILE plans +- **TLS support** via `crypton-connection` +- **Multi-auth** — basic, bearer token, Kerberos, custom schemes, plus LOGON/LOGOFF for Bolt 5.1+ + +## Quick start + +```haskell +import qualified Database.Bolty as Bolt +import Data.Default (def) + +main :: IO () +main = do + let cfg = def{ Bolt.scheme = Bolt.Basic "neo4j" "password", Bolt.use_tls = False } + case Bolt.validateConfig cfg of + Failure errs -> mapM_ putStrLn errs + Success vc -> do + conn <- Bolt.connect vc + result <- Bolt.runBolt conn $ + Bolt.queryWith (Bolt.field "greeting" Bolt.text) "RETURN 'hello' AS greeting" mempty + print result -- Right (Vector ["hello"]) + Bolt.close conn +``` + +## Configuration + +Use `Data.Default.def` for sensible defaults and override what you need. The config must be validated before use: + +```haskell +import Data.Default (def) + +cfg = def + { host = "db.example.com" + , port = 7687 + , scheme = Basic "neo4j" "s3cret" + , use_tls = True + , timeout = 5000 -- ms + } + +case validateConfig cfg of + Failure errs -> error (show errs) + Success vc -> connect vc >>= ... +``` + +Default config: `127.0.0.1:7687`, no auth, TLS on, 10s timeout, BOLT 5.4 down to 4.4. + +### Authentication schemes + +```haskell +None -- no auth +Basic "user" "pass" -- username/password +Bearer "jwt-token" -- SSO / JWT token +Kerberos "base64-ticket" -- Kerberos +Custom "scheme" credentials -- custom auth provider +``` + +## The BoltM monad + +Queries run in `BoltM`, a thin `ReaderT Connection IO` wrapper: + +```haskell +runBolt :: Connection -> BoltM a -> IO a +``` + +### Running queries + +```haskell +-- Auto-decode via FromBolt (returns Either DecodeError (Vector a)) +query :: FromBolt a => Text -> HashMap Text Ps -> BoltM (Either DecodeError (Vector a)) + +-- Explicit decoder +queryWith :: RowDecoder a -> Text -> HashMap Text Ps -> BoltM (Either DecodeError (Vector a)) + +-- Raw result set (field names + records) +queryResult :: Text -> HashMap Text Ps -> BoltM ResultSet + +-- Side-effects only, discard results +execute :: Text -> HashMap Text Ps -> BoltM () +``` + +Pass `mempty` for no parameters. + +### Parameters + +```haskell +import Data.PackStream.Ps (Ps(..)) +import qualified Data.HashMap.Lazy as H + +queryWith decoder "MATCH (p:Person) WHERE p.age > $minAge RETURN p.name AS name" + (H.singleton "minAge" (PsInteger 21)) +``` + +## Record decoding + +bolty provides composable, type-safe decoders. A `Decode a` extracts a single value from a `Bolt` cell; a `RowDecoder a` maps column names to decoders for a full row. + +### Primitive decoders + +```haskell +bool :: Decode Bool +int :: Decode Int -- may lose precision from Int64 +int64 :: Decode Int64 +float :: Decode Double +text :: Decode Text +bytes :: Decode ByteString +``` + +### Combining with RowDecoder + +```haskell +data Person = Person { pName :: Text, pAge :: Int64 } + +personDecoder :: RowDecoder Person +personDecoder = Person + <$> field "name" text + <*> field "age" int64 + +result <- runBolt conn $ + queryWith personDecoder "MATCH (p:Person) RETURN p.name AS name, p.age AS age" mempty +``` + +### Node property decoders + +When a query returns full nodes, decode properties from within: + +```haskell +data Person = Person { name :: Text, age :: Int64 } + +personDecoder :: RowDecoder Person +personDecoder = do + n <- field "p" node + pure $ Person + <$> nodeProperty "name" text n + <*> nodeProperty "age" int64 n +``` + +### Other decoders + +```haskell +nullable :: Decode a -> Decode (Maybe a) -- NULL-safe +list :: Decode a -> Decode (Vector a) -- list values +dict :: Decode (HashMap Text Bolt) -- raw dictionary +node :: Decode Node -- graph node +relationship :: Decode Relationship -- graph relationship +path :: Decode Path -- graph path +uuid :: Decode UUID -- UUID from string +utcTime :: Decode UTCTime -- DateTime → UTCTime +day :: Decode Day -- Date → Day +timeOfDay :: Decode TimeOfDay -- LocalTime → TimeOfDay +aesonValue :: Decode Aeson.Value -- Bolt → aeson Value +``` + +### Result sets + +For multi-pass decoding (e.g. denormalized `OPTIONAL MATCH` results): + +```haskell +rs <- runBolt conn $ queryResult "MATCH (p:Person) RETURN p.name AS name, p.age AS age" mempty + +-- Decode all rows +people <- either throwIO pure $ decodeResultSet personDecoder rs + +-- Decode just the first row +first <- either throwIO pure $ decodeHead personDecoder rs + +-- Group by a key field (consecutive grouping) +groups <- either throwIO pure $ groupByField (field "dept" (nullable text)) rs +``` + +## Transactions + +### Basic transactions + +```haskell +withTransaction conn $ \txConn -> do + runBolt txConn $ execute "CREATE (p:Person {name: 'Alice'})" mempty + runBolt txConn $ execute "CREATE (p:Person {name: 'Bob'})" mempty +-- auto-commits on success, rolls back on exception +``` + +### Retry on transient errors + +```haskell +withRetryTransaction defaultRetryConfig conn $ \txConn -> + runBolt txConn $ execute "CREATE (p:Person {name: 'Alice'})" mempty +-- retries up to 5 times with exponential backoff on transient Neo4j errors +``` + +`RetryConfig` controls `maxRetries` (default 5), `initialDelay` (200ms), and `maxDelay` (5s). + +## Connection pooling + +```haskell +pool <- createPool validatedConfig defaultPoolConfig +-- defaultPoolConfig: 10 max connections, 60s idle timeout, PingIfIdle 30s + +withConnection pool $ \conn -> + runBolt conn $ query @Person "MATCH (p:Person) RETURN p" mempty + +-- Convenience: pool + retry transaction in one call +withTransaction' pool $ \conn -> + runBolt conn $ execute "CREATE (n:Test)" mempty + +destroyPool pool +``` + +### Validation strategies + +Control how connections are health-checked on checkout: + +```haskell +AlwaysPing -- send RESET before every use (safest) +PingIfIdle 30 -- only ping if idle > 30 seconds (default, good balance) +NeverPing -- skip health check (fastest, use in trusted environments) +``` + +## Cluster routing + +For Neo4j causal clusters with multiple servers: + +```haskell +let cfg = def{ scheme = Basic "neo4j" "pass", routing = EnableRouting Nothing } + +routingPool <- createRoutingPool validatedConfig defaultRoutingPoolConfig + +-- Writes go to a writer server, reads to a reader +withRoutingTransaction routingPool WriteAccess $ \conn -> + runBolt conn $ execute "CREATE (n:Test)" mempty + +withRoutingTransaction routingPool ReadAccess $ \conn -> + runBolt conn $ queryWith decoder "MATCH (n) RETURN n" mempty + +destroyRoutingPool routingPool +``` + +The routing pool automatically discovers servers via the ROUTE message, caches routing tables with TTL, and retries on different servers when a routing error occurs. + +## Sessions + +Sessions track bookmarks for causal consistency across transactions: + +```haskell +session <- createSession pool defaultSessionConfig + +-- Each transaction's bookmark is automatically passed to the next +writeTransaction session $ \conn -> + runBolt conn $ execute "CREATE (p:Person {name: 'Alice'})" mempty + +readTransaction session $ \conn -> + runBolt conn $ queryWith decoder "MATCH (p:Person) RETURN p" mempty +-- ↑ guaranteed to see Alice because of bookmark chaining + +bookmarks <- getLastBookmarks session +``` + +## Query metadata + +```haskell +(result, meta) <- runBolt conn $ queryMetaWith decoder cypher params +-- meta :: QueryMeta contains: +-- parsedNotifications :: [Notification] -- warnings, deprecations +-- parsedStats :: Maybe QueryStats -- nodes/rels created/deleted +-- parsedPlan :: Maybe PlanNode -- EXPLAIN plan +-- parsedProfile :: Maybe ProfileNode -- PROFILE with execution stats +-- bookmark, db, tFirst, tLast -- timing and metadata + +-- EXPLAIN a query without executing it +plan <- runBolt conn $ queryExplain "MATCH (n) RETURN n" mempty + +-- PROFILE a query with actual execution statistics +(rows, profile) <- runBolt conn $ queryProfile "MATCH (n) RETURN n" mempty +``` + +## Query logging + +```haskell +let cfg = def{ queryLogger = Just $ \ql meta -> do + putStrLn $ "Query: " <> show (qlCypher ql) + putStrLn $ "Rows: " <> show (qlRowCount ql) + putStrLn $ "Time: " <> show (qlClientTime ql) <> "ns" + } +``` + +## Error handling + +```haskell +-- Check if an error is transient (safe to retry) +isTransient :: Error -> Bool + +-- Check if an error is a routing error (server unreachable, etc.) +isRoutingError :: Error -> Bool +``` + +## Bolt value types + +Every cell in a query result is a `Bolt` value: + +| Neo4j type | Bolt constructor | Haskell type inside | +|---|---|---| +| null | `BoltNull` | — | +| boolean | `BoltBoolean` | `Bool` | +| integer | `BoltInteger` | `PSInteger` | +| float | `BoltFloat` | `Double` | +| bytes | `BoltBytes` | `ByteString` | +| string | `BoltString` | `Text` | +| list | `BoltList` | `Vector Bolt` | +| map | `BoltDictionary` | `HashMap Text Bolt` | +| node | `BoltNode` | `Node` (id, labels, properties) | +| relationship | `BoltRelationship` | `Relationship` (id, start, end, type, properties) | +| path | `BoltPath` | `Path` (nodes, rels, indices) | +| date | `BoltDate` | `Date` (days since epoch) | +| time | `BoltTime` | `Time` (nanos, tz offset) | +| local time | `BoltLocalTime` | `LocalTime` (nanos since midnight) | +| datetime | `BoltDateTime` | `DateTime` (seconds, nanos) | +| datetime (zoned) | `BoltDateTimeZoneId` | `DateTimeZoneId` (seconds, nanos, tz name) | +| local datetime | `BoltLocalDateTime` | `LocalDateTime` (seconds, nanos) | +| duration | `BoltDuration` | `Duration` (months, days, seconds, nanos) | +| point (2d) | `BoltPoint2D` | `Point2D` (srid, x, y) | +| point (3d) | `BoltPoint3D` | `Point3D` (srid, x, y, z) | + +## Module structure + +**Public API — import these:** + +| Module | Purpose | +|---|---| +| `Database.Bolty` | Main entry point, re-exports everything | +| `Database.Bolty.Decode` | Record decoders (`Decode`, `RowDecoder`, `FromBolt`) | +| `Database.Bolty.Pool` | Connection pooling | +| `Database.Bolty.Routing` | Cluster routing | +| `Database.Bolty.Session` | Sessions with bookmark management | +| `Database.Bolty.ResultSet` | Multi-pass result set decoding | +| `Database.Bolty.Logging` | Query log types | +| `Database.Bolty.Notification` | Server notifications | +| `Database.Bolty.Plan` | EXPLAIN/PROFILE plan types | +| `Database.Bolty.Stats` | Query statistics types | +| `Database.Bolty.Record` | Record type alias | + +All other modules under `Database.Bolty.Connection.*`, `Database.Bolty.Message.*`, and `Database.Bolty.Value.*` are **internal** — exposed for `bolty-streamly` but not part of the stable API. + +## Supported GHC versions + +9.6.7, 9.8.4, 9.10.3, 9.12.3 + +## License + +Apache-2.0 diff --git a/src/Database/Bolty.hs b/src/Database/Bolty.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty.hs @@ -0,0 +1,354 @@ +-- | Haskell driver for Neo4j over the BOLT protocol (4.4+). +-- +-- This is the main entry point for using bolty. It re-exports everything +-- needed to connect, run queries, manage transactions, and decode results. +-- +-- @ +-- import qualified Database.Bolty as Bolt +-- import Data.Default (def) +-- +-- main :: IO () +-- main = do +-- cfg <- Bolt.'validateConfig' def{ Bolt.'scheme' = Bolt.'Basic' \"neo4j\" \"password\" } +-- conn <- Bolt.'connect' cfg +-- rows <- Bolt.'runBolt' conn $ +-- Bolt.'queryWith' (Bolt.'field' \"n\" Bolt.'node') \"MATCH (n) RETURN n LIMIT 10\" mempty +-- print rows -- Either DecodeError (Vector Node) +-- Bolt.'close' conn +-- @ +module Database.Bolty + ( -- * Configuration + Config(..) + , ValidatedConfig + , validateConfig + , Scheme(..) + , Routing(..) + , UserAgent(..) + , Version(..) + -- * Connection + , Connection + , connect + , close + , reset + , ping + , logon + , logoff + , connectionVersion + , connectionAgent + , connectionId + , connectionTelemetryEnabled + , connectionServerIdleTimeout + -- * Telemetry + , TelemetryApi(..) + , sendTelemetry + -- * Transactions + , withTransaction + , withRetryTransaction + , withTransaction' + -- * Retry configuration + , RetryConfig(..) + , defaultRetryConfig + -- * Error helpers + , isTransient + , isRoutingError + -- * Types + , Bolt(..) + , Record + , Error(..) + -- * Bolt value extractors + , asNull, asBool, asInt, asFloat, asBytes, asText + , asList, asDict, asNode, asRelationship, asPath + -- * Query metadata + , QueryMeta(..) + -- * Connection pooling + , BoltPool + , PoolConfig(..) + , defaultPoolConfig + , ValidationStrategy(..) + , PoolCounters(..) + , createPool + , destroyPool + , withConnection + , poolCounters + -- * Routing + , AccessMode(..) + , RoutingTable(..) + , RoutingPool + , RoutingPoolConfig(..) + , defaultRoutingPoolConfig + , createRoutingPool + , destroyRoutingPool + , withRoutingConnection + , withRoutingTransaction + , invalidateRoutingTable + , getRoutingTable + -- * Sessions + , Session + , SessionConfig(..) + , defaultSessionConfig + , BookmarkManager + , createSession + , createRoutingSession + , readTransaction + , writeTransaction + , getLastBookmarks + -- * Plan / Profile + , PlanNode(..) + , ProfileNode(..) + , queryExplain + , queryProfile + -- * Query logging + , QueryLog(..) + -- * Notifications + , Notification(..) + , Severity(..) + , Position(..) + -- * Query statistics + , QueryStats(..) + -- * BoltM monad + , BoltM + , runBolt + -- * Queries + , query + , queryWith + , queryResult + , queryMeta + , queryMetaWith + , queryResultMeta + , execute + -- * Record decoding + , DecodeError(..) + , Decode(..) + , RowDecoder(..) + , FromBolt(..) + , ToBolt(..) + , Database.Bolty.Decode.bool + , Database.Bolty.Decode.int + , int64 + , Database.Bolty.Decode.float + , Database.Bolty.Decode.text + , Database.Bolty.Decode.bytes + , nullable, list, dict + , Database.Bolty.Decode.uuid + , utcTime, day, timeOfDay + , aesonValue + , nodeProperty, nodePropertyOptional, Database.Bolty.Decode.nodeLabels, Database.Bolty.Decode.nodeProperties + , Database.Bolty.Decode.node + , Database.Bolty.Decode.relationship + , Database.Bolty.Decode.path + , column, field + -- * Result sets + , ResultSet(..) + , decodeResultSet + , decodeHead + , groupByField + -- * PackStream re-exports + , Ps(..) + ) where + +import Database.Bolty.Connection (queryPWithFieldsIO, queryPMetaIO) +import Database.Bolty.Logging (QueryLog(..)) +import Database.Bolty.Plan (PlanNode(..), ProfileNode(..)) +import Database.Bolty.Notification (Notification(..), Severity(..), Position(..)) +import Database.Bolty.Stats (QueryStats(..)) +import Database.Bolty.Decode +import Database.Bolty.Connection.Config (validateConfig) +import qualified Database.Bolty.Connection.Pipe as P +import Database.Bolty.Connection.Pipe (connectionVersion, connectionAgent, + connectionId, connectionTelemetryEnabled, + connectionServerIdleTimeout) +import Database.Bolty.Connection.Type +import Database.Bolty.Message.Request (Begin(Begin), TelemetryApi(..)) +import Database.Bolty.Message.Response +import Database.Bolty.Pool +import Database.Bolty.Record +import Database.Bolty.ResultSet +import Database.Bolty.Routing (AccessMode(..), RoutingPool, RoutingPoolConfig(..), + defaultRoutingPoolConfig, createRoutingPool, + destroyRoutingPool, withRoutingConnection, + withRoutingTransaction, invalidateRoutingTable, + getRoutingTable) +import Database.Bolty.Session (Session, SessionConfig(..), defaultSessionConfig, + BookmarkManager, createSession, createRoutingSession, + readTransaction, writeTransaction, getLastBookmarks) +import Database.Bolty.Value.Type (Bolt(..), asNull, asBool, asInt, asFloat + , asBytes, asText, asList, asDict + , asNode, asRelationship, asPath) +import Database.Bolty.Connection.Version (Version(..)) + +import Data.Kind (Type) +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, fromException, onException, + throwIO, try) +import Control.Monad (void) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Trans (MonadIO(..)) +import Data.Text (Text) +import GHC.Stack (HasCallStack) +import qualified Data.HashMap.Lazy as H +import qualified Data.Vector as V +import Data.PackStream.Ps (Ps(..)) + + +-- | Connect to a Neo4j server using a validated configuration. +connect :: (MonadIO m, HasCallStack) => ValidatedConfig -> m Connection +connect = P.connect + + +-- | Close a connection to a Neo4j server. +close :: (MonadIO m, HasCallStack) => Connection -> m () +close = P.close + + +-- | Reset the connection state after an error. +reset :: (MonadIO m, HasCallStack) => Connection -> m () +reset = P.reset + + +-- | Check if a connection is alive by sending RESET. +-- Returns True if healthy, False otherwise. +ping :: MonadIO m => Connection -> m Bool +ping = P.ping + + +-- | Send LOGON with credentials (Bolt 5.1+). +-- Transitions from Authentication to Ready state. +logon :: (MonadIO m, HasCallStack) => Connection -> Scheme -> m () +logon = P.logon + + +-- | Send LOGOFF (Bolt 5.1+). +-- Transitions from Ready to Authentication state. +logoff :: (MonadIO m, HasCallStack) => Connection -> m () +logoff = P.logoff + + +-- | Send a TELEMETRY message if the server supports it (Bolt 5.4+). +-- No-op if the server does not support telemetry. +sendTelemetry :: (MonadIO m, HasCallStack) => Connection -> TelemetryApi -> m () +sendTelemetry = P.sendTelemetry + + +-- --------------------------------------------------------------------------- +-- BoltM monad +-- --------------------------------------------------------------------------- + +-- | A monad for running queries against a Neo4j connection. +-- Use 'runBolt' to execute a 'BoltM' action with a 'Connection'. +type BoltM :: Type -> Type +type role BoltM nominal +newtype BoltM a = BoltM (ReaderT Connection IO a) + deriving newtype (Functor, Applicative, Monad, MonadIO) + +-- | Run a 'BoltM' action with a 'Connection'. +runBolt :: Connection -> BoltM a -> IO a +runBolt conn (BoltM m) = runReaderT m conn + + +-- --------------------------------------------------------------------------- +-- Queries (BoltM) +-- --------------------------------------------------------------------------- + +-- | Run a Cypher query, decode each record using the 'FromBolt' instance, and +-- return the decoded rows or a 'DecodeError'. Pass 'mempty' for no parameters. +query :: (FromBolt a, HasCallStack) => Text -> H.HashMap Text Ps -> BoltM (Either DecodeError (V.Vector a)) +query = queryWith rowDecoder + +-- | Like 'query', but with an explicit 'RowDecoder' instead of using 'FromBolt'. +queryWith :: HasCallStack => RowDecoder a -> Text -> H.HashMap Text Ps -> BoltM (Either DecodeError (V.Vector a)) +queryWith decoder cypher params = BoltM $ ReaderT $ \conn -> do + (cols, recs) <- queryPWithFieldsIO conn cypher params + pure $ decodeRows decoder cols recs + +-- | Run a Cypher query and return a 'ResultSet' (field names + records). +-- Use 'decodeResultSet' or 'groupByField' for multi-pass decoding. +-- Pass 'mempty' for no parameters. +queryResult :: HasCallStack => Text -> H.HashMap Text Ps -> BoltM ResultSet +queryResult cypher params = BoltM $ ReaderT $ \conn -> do + (fs, rs) <- queryPWithFieldsIO conn cypher params + pure $ ResultSet fs rs + +-- | Run a Cypher query, decode each record using the 'FromBolt' instance, and +-- return the decoded rows paired with server metadata ('QueryMeta'). +-- Pass 'mempty' for no parameters. +queryMeta :: (FromBolt a, HasCallStack) => Text -> H.HashMap Text Ps -> BoltM (Either DecodeError (V.Vector a), QueryMeta) +queryMeta = queryMetaWith rowDecoder + +-- | Like 'queryMeta', but with an explicit 'RowDecoder' instead of using 'FromBolt'. +queryMetaWith :: HasCallStack => RowDecoder a -> Text -> H.HashMap Text Ps -> BoltM (Either DecodeError (V.Vector a), QueryMeta) +queryMetaWith decoder cypher params = BoltM $ ReaderT $ \conn -> do + (fs, rs, qi) <- queryPMetaIO conn cypher params + pure (decodeRows decoder fs rs, qi) + +-- | Run a Cypher query and return a 'ResultSet' paired with server metadata +-- ('QueryMeta' — timing, statistics, notifications, plan/profile). +-- Pass 'mempty' for no parameters. +queryResultMeta :: HasCallStack => Text -> H.HashMap Text Ps -> BoltM (ResultSet, QueryMeta) +queryResultMeta cypher params = BoltM $ ReaderT $ \conn -> do + (fs, rs, qi) <- queryPMetaIO conn cypher params + pure (ResultSet fs rs, qi) + + +-- | Run a Cypher query for side effects only, discarding the result. +-- Pass 'mempty' for no parameters. +execute :: HasCallStack => Text -> H.HashMap Text Ps -> BoltM () +execute cypher params = void $ queryResult cypher params + + +-- | Run EXPLAIN on a Cypher query, returning the query plan without executing it. +queryExplain :: HasCallStack => Text -> H.HashMap Text Ps -> BoltM (Maybe PlanNode) +queryExplain cypher params = do + (_, meta) <- queryResultMeta ("EXPLAIN " <> cypher) params + pure (parsedPlan meta) + + +-- | Run PROFILE on a Cypher query, returning both decoded rows and the profile tree +-- with actual execution statistics (db hits, rows, timing, etc.). +queryProfile :: (FromBolt a, HasCallStack) + => Text -> H.HashMap Text Ps + -> BoltM (Either DecodeError (V.Vector a), ProfileNode) +queryProfile cypher params = do + (result, meta) <- queryMeta ("PROFILE " <> cypher) params + case parsedProfile meta of + Just prof -> pure (result, prof) + Nothing -> error "queryProfile: no profile in response" + + +-- | Run an action inside an explicit transaction. Automatically commits on success +-- and rolls back on failure. +withTransaction :: HasCallStack => Connection -> (Connection -> IO a) -> IO a +withTransaction conn action = do + P.beginTx conn defaultBegin + result <- action conn `onException` P.tryRollback conn + _ <- P.commitTx conn + pure result + where + defaultBegin = Begin V.empty Nothing H.empty 'w' Nothing Nothing + + +-- | Run a transaction with automatic retry on transient failures. +-- Uses exponential backoff between retries. +withRetryTransaction :: HasCallStack + => RetryConfig -> Connection -> (Connection -> IO a) -> IO a +withRetryTransaction RetryConfig{maxRetries, initialDelay, maxDelay} conn action = + go maxRetries initialDelay + where + go 0 _ = withTransaction conn action + go n delay = do + result <- try $ withTransaction conn action + case result of + Right x -> pure x + Left (e :: SomeException) -> case fromException e :: Maybe Error of + Just err | isTransient err -> do + threadDelay delay + go (n - 1) (min maxDelay (delay * 2)) + _ -> throwIO e + + +-- | Convenience: acquire a pooled connection, run a retrying transaction, and release. +withTransaction' :: HasCallStack => BoltPool -> (Connection -> IO a) -> IO a +withTransaction' pool@BoltPool{bpRetryConfig} action = + withConnection pool $ \conn -> + withRetryTransaction bpRetryConfig conn action + + diff --git a/src/Database/Bolty/Connection.hs b/src/Database/Bolty/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection.hs @@ -0,0 +1,250 @@ +-- | Internal module. Not part of the public API. +module Database.Bolty.Connection + ( queryIO + , queryPIO + , queryIO' + , queryPIO' + , queryWithFieldsIO + , queryPWithFieldsIO + , queryPMetaIO + , requestResponseRunIO + , requestResponsePullIO + ) where + +import Prelude + +import qualified Database.Bolty.Connection.Pipe as P +import Database.Bolty.Connection.Type +import Database.Bolty.Logging +import Database.Bolty.Record + +import Control.Exception (SomeException, throwIO, try) +import Data.Text (Text) +import Data.Word (Word64) +import Debug.Trace (traceEventIO) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Stack (HasCallStack) + +import Database.Bolty.Message.Response +import Database.Bolty.Message.Request +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.PackStream.Ps (Ps, fromPs) +import Data.PackStream.Result (Result(..)) + + +-- | Run a query, return only records. +queryIO :: HasCallStack => Connection -> Text -> IO (V.Vector Record) +queryIO conn cypher = records <$> queryPIO' conn cypher H.empty + +-- | Run a parameterized query, return only records. +queryPIO :: HasCallStack => Connection -> Text -> H.HashMap Text Ps -> IO (V.Vector Record) +queryPIO conn cypher params = records <$> queryPIO' conn cypher params + +-- | Run a query, return full response. +queryIO' :: HasCallStack => Connection -> Text -> IO SuccessPull +queryIO' conn cypher = queryPIO' conn cypher H.empty + +-- | Run a parameterized query, return full response. +queryPIO' :: HasCallStack => Connection -> Text -> H.HashMap Text Ps -> IO SuccessPull +queryPIO' conn cypher params = do + (runResp, pullResp, clientNs) <- timedQuery conn cypher params + fireLogger conn cypher params runResp pullResp clientNs + fireNotifications conn pullResp + pure pullResp + +-- | Send RUN and receive the run response. +requestResponseRunIO :: HasCallStack => Connection -> Text -> H.HashMap Text Ps -> IO SuccessRun +requestResponseRunIO conn cypher params = do + st <- P.getState conn + P.requireStateIO conn [Ready, TXready] "RUN" + let request = case st of + TXready -> RRunExplicitTransaction $ RunExplicitTransaction cypher params defaultRunExtra + _ -> RRunAutoCommitTransaction $ mkRunAutoCommit cypher params + P.flushIO conn request + response <- P.fetchIO conn + case response of + RSuccess meta -> do + P.setState conn $ case st of + TXready -> TXstreaming + _ -> Streaming + case makeResponseRunAutoCommitTransaction meta of + Left err -> throwIO $ WrongMessageFormat err + Right v -> pure v + RIgnored -> do + P.reset conn + throwIO ResponseErrorIgnored + RFailure Failure{code, message} -> do + P.setState conn Failed + P.reset conn + throwIO $ ResponseErrorFailure code message + RRecord _ -> do + P.reset conn + throwIO ResponseErrorRecords + +-- | Pull all records from an in-progress query. +requestResponsePullIO :: HasCallStack => Connection -> IO SuccessPull +requestResponsePullIO conn = do + P.requireStateIO conn [Streaming, TXstreaming] "PULL" + P.flushIO conn $ RPull defaultPull + go V.empty + where + go records = do + response <- P.fetchIO conn + case response of + RSuccess meta -> do + let has_more = case H.lookup "has_more" meta of + Just hm -> case fromPs hm of + Success True -> True + _ -> False + Nothing -> False + if has_more then do + P.flushIO conn $ RPull defaultPull + go records + else do + st <- P.getState conn + P.setState conn $ case st of + TXstreaming -> TXready + _ -> Ready + case makeSuccessPull records meta of + Left err -> throwIO $ WrongMessageFormat err + Right v -> pure v + RIgnored -> do + P.reset conn + throwIO ResponseErrorIgnored + RFailure Failure{code, message} -> do + P.setState conn Failed + P.reset conn + throwIO $ ResponseErrorFailure code message + RRecord record -> go $ V.snoc records record + +-- | Run a parameterized query, returning column names alongside records. +queryPWithFieldsIO :: HasCallStack => Connection -> T.Text -> H.HashMap T.Text Ps -> IO (V.Vector T.Text, V.Vector Record) +queryPWithFieldsIO conn cypher params = do + (runResp, pullResp, clientNs) <- timedQuery conn cypher params + fireLogger conn cypher params runResp pullResp clientNs + fireNotifications conn pullResp + pure (successFields runResp, records pullResp) + +-- | Run a query, returning column names alongside records. +queryWithFieldsIO :: HasCallStack => Connection -> T.Text -> IO (V.Vector T.Text, V.Vector Record) +queryWithFieldsIO conn cypher = queryPWithFieldsIO conn cypher H.empty + + +-- | Run a parameterized query, returning field names, records, and metadata. +queryPMetaIO :: HasCallStack => Connection -> T.Text -> H.HashMap T.Text Ps -> IO (V.Vector T.Text, V.Vector Record, QueryMeta) +queryPMetaIO conn cypher params = do + (runResp, pullResp, clientNs) <- timedQuery conn cypher params + fireLogger conn cypher params runResp pullResp clientNs + fireNotifications conn pullResp + pure (successFields runResp, records pullResp, infos pullResp) + + +-- --------------------------------------------------------------------------- +-- Internal: timing + logging +-- --------------------------------------------------------------------------- + +-- | Run a query with monotonic clock timing, returning the responses and elapsed nanoseconds. +-- Uses Bolt pipelining: sends RUN + PULL before reading either response, +-- saving one network round-trip compared to the sequential approach. +timedQuery :: HasCallStack => Connection -> T.Text -> H.HashMap T.Text Ps -> IO (SuccessRun, SuccessPull, Word64) +timedQuery conn cypher params = do + traceEventIO "START boltWireIO" + t0 <- getMonotonicTimeNSec + + -- Build RUN request + st <- P.getState conn + P.requireStateIO conn [Ready, TXready] "RUN" + let runRequest = case st of + TXready -> RRunExplicitTransaction $ RunExplicitTransaction cypher params defaultRunExtra + _ -> RRunAutoCommitTransaction $ mkRunAutoCommit cypher params + + -- Pipeline: send RUN + PULL before receiving either response + P.flushIO conn runRequest + P.flushIO conn (RPull defaultPull) + + -- Receive RUN response + runResult <- try @SomeException $ do + runResponse <- P.fetchIO conn + case runResponse of + RSuccess meta -> do + P.setState conn $ case st of + TXready -> TXstreaming + _ -> Streaming + case makeResponseRunAutoCommitTransaction meta of + Left err -> throwIO $ WrongMessageFormat err + Right v -> pure v + RFailure Failure{code, message} -> do + P.setState conn Failed + throwIO $ ResponseErrorFailure code message + RIgnored -> + throwIO ResponseErrorIgnored + RRecord _ -> + throwIO ResponseErrorRecords + + case runResult of + Left err -> do + -- RUN failed: consume the IGNORED response for the pipelined PULL + _ <- P.fetchIO conn + P.reset conn + throwIO err + Right runResp -> do + -- Receive PULL responses + pullResp <- pullRecords conn V.empty + t1 <- getMonotonicTimeNSec + traceEventIO "STOP boltWireIO" + pure (runResp, pullResp, t1 - t0) + +-- | Pull all records from an in-progress pipelined query. +-- The initial PULL has already been sent; this receives responses and handles has_more pagination. +pullRecords :: HasCallStack => Connection -> V.Vector Record -> IO SuccessPull +pullRecords conn recs = do + response <- P.fetchIO conn + case response of + RSuccess meta -> do + let has_more = case H.lookup "has_more" meta of + Just hm -> case fromPs hm of + Success True -> True + _ -> False + Nothing -> False + if has_more then do + P.flushIO conn $ RPull defaultPull + pullRecords conn recs + else do + st <- P.getState conn + P.setState conn $ case st of + TXstreaming -> TXready + _ -> Ready + case makeSuccessPull recs meta of + Left err -> throwIO $ WrongMessageFormat err + Right v -> pure v + RIgnored -> do + P.reset conn + throwIO ResponseErrorIgnored + RFailure Failure{code, message} -> do + P.setState conn Failed + P.reset conn + throwIO $ ResponseErrorFailure code message + RRecord record -> pullRecords conn $ V.snoc recs record + +-- | Fire the query logger callback if configured. +fireLogger :: Connection -> T.Text -> H.HashMap T.Text Ps -> SuccessRun -> SuccessPull -> Word64 -> IO () +fireLogger Connection{queryLogger} cypher params runResp SuccessPull{records, infos} clientNs = + case queryLogger of + Nothing -> pure () + Just logger -> logger QueryLog + { qlCypher = cypher + , qlParameters = params + , qlRowCount = V.length records + , qlServerFirst = successTFirst runResp + , qlServerLast = t_last infos + , qlClientTime = fromIntegral clientNs / 1_000_000 + } infos + +-- | Fire the notification handler for each parsed notification, if configured. +fireNotifications :: Connection -> SuccessPull -> IO () +fireNotifications Connection{notificationHandler} SuccessPull{infos = QueryMeta{parsedNotifications}} = + case notificationHandler of + Nothing -> pure () + Just handler -> V.mapM_ handler parsedNotifications diff --git a/src/Database/Bolty/Connection/Config.hs b/src/Database/Bolty/Connection/Config.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection/Config.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ApplicativeDo #-} + +-- | Internal module. Not part of the public API. +module Database.Bolty.Connection.Config + ( validateConfig + ) where + +import qualified Data.Text as T +import qualified Validation as V + +import Database.Bolty.Connection.Type +import Database.Bolty.Connection.Version (boltVersionsToSpec) +import Database.Bolty.Util (whenInvalid) + + +-- | Validate a 'Config', returning either validation errors or a 'ValidatedConfig'. +validateConfig :: Config -> V.Validation [T.Text] ValidatedConfig +validateConfig Config{host, port, scheme, use_tls, versions, timeout, user_agent, routing, queryLogger, notificationHandler} = do + h <- whenInvalid host (T.null host) "Host can not be empty" + s <- validateScheme scheme + validated_versions <- boltVersionsToSpec versions + ua <- validateUserAgent user_agent + pure $ ValidatedConfig {host = h, port, scheme = s, use_tls, versions = validated_versions, timeout, user_agent = ua, routing, queryLogger, notificationHandler} + +validateScheme :: Scheme -> V.Validation [T.Text] Scheme +validateScheme s@(Basic principal credentials) = do + _ <- whenInvalid principal (T.null principal) "Scheme basic principal (username) can not be empty" + _ <- whenInvalid credentials (T.null credentials) "Scheme basic credentials (password) can not be empty" + pure s +validateScheme s@(Bearer credentials) = do + _ <- whenInvalid credentials (T.null credentials) "Scheme bearer credentials (password) can not be empty" + pure s +validateScheme s = pure s + +validateUserAgent :: UserAgent -> V.Validation [T.Text] UserAgent +validateUserAgent ua@UserAgent{name, version} = do + _ <- whenInvalid name (T.null name) "User agent name can not be empty" + _ <- whenInvalid version (T.null version) "User agent version can not be empty" + pure ua diff --git a/src/Database/Bolty/Connection/Connection.hs b/src/Database/Bolty/Connection/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection/Connection.hs @@ -0,0 +1,81 @@ +-- | Internal module. Not part of the public API. +module Database.Bolty.Connection.Connection + ( connect + , close + , send + , receiveBytestring + , receiveBinary + ) where + +import Control.Monad.Trans (MonadIO(..)) +import Data.Default (Default(..)) +import Data.Persist (HasEndianness, runGet, getBE) +import Data.Word (Word16) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Network.Connection (Connection, ConnectionParams(..), connectFromSocket, connectionClose, + connectionGetExact, connectionPut, + initConnectionContext) +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Network.Socket as NS +import qualified System.Timeout as ST (timeout) +import TextShow (TextShow, showt) + + +timeoutThrow :: (HasCallStack, TextShow b) => Int -> b -> IO a -> IO a +timeoutThrow milliseconds associated_data action = withFrozenCallStack $ do + res <- ST.timeout (milliseconds * 1_000) action + case res of + Just a -> return a + Nothing -> fail $ "Timeout: " ++ show (showt associated_data) + + +-- | Open a raw TCP connection to the given host and port with optional TLS. +connect :: (MonadIO m, HasCallStack) => Bool -> T.Text -> Word16 -> Int -> m (Connection, Int) +connect use_tls host port timeout = liftIO $ do + ctx <- initConnectionContext + let params = ConnectionParams + { connectionHostname = T.unpack host + , connectionPort = fromIntegral port + , connectionUseSecure = if use_tls then Just def else Nothing + , connectionUseSocks = Nothing + } + let hints = NS.defaultHints { NS.addrSocketType = NS.Stream } + addrs <- NS.getAddrInfo (Just hints) (Just $ T.unpack host) (Just $ show port) + case addrs of + [] -> fail $ "Cannot resolve " ++ T.unpack host + (addr:_) -> do + sock <- NS.openSocket addr + NS.setSocketOption sock NS.NoDelay 1 + timeoutThrow timeout ("connecting to " <> host <> ":" <> showt port) $ do + NS.connect sock (NS.addrAddress addr) + conn <- connectFromSocket ctx sock params + pure (conn, timeout) + + +-- | Close a raw TCP connection. +close :: (MonadIO m, HasCallStack) => Connection -> Int -> m () +close conn timeout = liftIO $ timeoutThrow timeout ("closing connection" :: T.Text) $ connectionClose conn + + +-- | Receive exactly @size@ bytes from the connection with a timeout. +receiveBytestring :: (MonadIO m, HasCallStack) => Connection -> Int -> Int -> m BS.ByteString +receiveBytestring conn timeout size = + liftIO $ timeoutThrow timeout ("receiving " <> showt size <> " bytes") $ connectionGetExact conn size + + +-- | Receive and decode a big-endian binary value from the connection. +receiveBinary :: forall a m. (HasEndianness a, MonadIO m, HasCallStack) => Connection -> Int -> Int -> m a +receiveBinary conn timeout size = + fmap decodeBE $ liftIO $ timeoutThrow timeout ("receiving data" :: T.Text) $ connectionGetExact conn size + where + decodeBE bs = case runGet (getBE @a) bs of + Left e -> error $ "receiveBinary: " ++ e + Right a -> a + + +-- | Send raw bytes over the connection with a timeout. +send :: (MonadIO m, HasCallStack) => Connection -> Int -> BS.ByteString -> m () +send conn timeout bytes = do + let timeout_message = "sending " <> showt (BS.length bytes) <> " bytes" + liftIO $ timeoutThrow timeout timeout_message $ connectionPut conn bytes diff --git a/src/Database/Bolty/Connection/Instances.hs b/src/Database/Bolty/Connection/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection/Instances.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Internal module. Not part of the public API. +module Database.Bolty.Connection.Instances + ( -- instances only + ) where + +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T + +import Data.PackStream.Generic (genericToPs, genericFromPs) +import Data.PackStream.Ps +import Data.PackStream.Result +import Database.Bolty.Connection.Type +import Database.Bolty.Util (putTextUtf8) + + +instance PackStream Scheme where + toPs = genericToPs + fromPs = genericFromPs + + +instance PackStream Routing where + toPs NoRouting = PsDictionary H.empty + toPs Routing = PsDictionary $ H.singleton "routing" $ PsDictionary H.empty + toPs (RoutingSpec address query_params) = PsDictionary $ H.singleton "routing" $ PsDictionary $ H.union (H.singleton "address" (toPs address)) (H.map toPs query_params) + toBinary routing = toBinary $ toPs routing + fromPs ps = withDictionary "Routing" f ps + where f :: H.HashMap T.Text Ps -> Result Routing + f m | m == H.empty = pure NoRouting + | H.size m == 1 = pure Routing + | otherwise = + case H.lookup "address" m of + Nothing -> Error "\"address\" not found in routing part" + Just address -> do + address2 <- fromPs address + remainder <- traverse fromPs $ H.delete "address" m + pure $ RoutingSpec address2 remainder + + +instance PackStream UserAgent where + toPs (UserAgent name version) = toPs $ name <> "/" <> version + toBinary (UserAgent name version) = putTextUtf8 $ name <> "/" <> version + fromPs = withString "UserAgent" f + where f text = case T.splitOn "/" text of + (name : version : _) -> pure $ UserAgent name version + _ -> Error $ "Expected UserAgent in format \"name/version\", got: " <> text diff --git a/src/Database/Bolty/Connection/Pipe.hs b/src/Database/Bolty/Connection/Pipe.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection/Pipe.hs @@ -0,0 +1,441 @@ +-- | Internal module. Not part of the public API. +module Database.Bolty.Connection.Pipe + ( connect + , close + , reset + , ping + , flush + , fetch + , sendRequest + , receiveResponse + , requireState + , setState + , getState + , logon + , logoff + , sendTelemetry + , MonadPipe + -- * Connection accessors + , connectionVersion + , connectionAgent + , connectionId + , connectionTelemetryEnabled + , connectionServerIdleTimeout + , touchConnection + , connectionLastActivity + -- * Transaction primitives (plain IO) + , beginTx + , commitTx + , rollbackTx + , tryRollback + -- * Plain IO wire helpers + , requireStateIO + , flushIO + , fetchIO + ) where + +import Data.Kind (Constraint, Type) +import Control.Exception (Exception, SomeException, catch, throwIO, try) +import Control.Monad (when, unless) +import Control.Monad.Trans (MonadIO(..)) +import Control.Monad.Extra (whenMaybe, whileJustM) +import Control.Monad.Except +import Data.Persist (putBE, runPutLazy) +import qualified Data.Persist as P +import Data.IORef (newIORef, readIORef, writeIORef) +import GHC.Clock (getMonotonicTimeNSec) +import Data.Bits (shiftR, (.&.)) +import Data.Int (Int64) +import Data.Word +import Data.PackStream.Integer (fromPSInteger) +import GHC.Stack (HasCallStack) +import Prelude +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.PackStream as PS +import Data.PackStream.Ps (Ps(..)) +import qualified Data.Vector as V +import qualified Network.Connection as NC + +import Database.Bolty.Connection.Type +import qualified Database.Bolty.Connection.Connection as C +import Database.Bolty.Message.Response +import Database.Bolty.Message.Request +import Database.Bolty.Value.Helpers (isNewVersion, versionMajor, supportsLogonLogoff, supportsTelemetry) +import Database.Bolty.Util + + +-- | Constraint alias for monads that can perform BOLT pipe operations. +type MonadPipe :: (Type -> Type) -> Constraint +type MonadPipe m = (HasCallStack, MonadIO m, MonadError Error m) + + +exceptToThrow :: (Exception e, MonadIO m) => ExceptT e m b -> m b +exceptToThrow f = runExceptT f >>= \case + Right y -> pure y + Left e -> liftIO $ throwIO e + + +-- | Connect to a Neo4j server, perform the BOLT handshake and authentication. +connect :: (MonadIO m, HasCallStack) => ValidatedConfig -> m Connection +connect ValidatedConfig{..} = do + (rawConn, tout) <- C.connect use_tls host port timeout + (server_version, agent, conn_id, telem, idleTimeout) <- exceptToThrow $ handshake rawConn tout ValidatedConfig{..} + stateRef <- liftIO $ newIORef Ready + now <- liftIO getMonotonicTimeNSec + actRef <- liftIO $ newIORef now + pure $ Connection { rawConnection = rawConn, timeout_milliseconds = tout + , version = server_version, server_state = stateRef + , server_agent = agent, connection_id = conn_id, lastActivity = actRef + , telemetry_enabled = telem, serverIdleTimeout = idleTimeout + , queryLogger = queryLogger + , notificationHandler = notificationHandler } + + +-- | Send GOODBYE (if supported) and close the connection. +close :: (MonadIO m, HasCallStack) => Connection -> m () +close Connection{rawConnection, timeout_milliseconds, version, server_state} = exceptToThrow $ do + _ <- whenMaybe (isNewVersion version) $ sendRequest rawConnection timeout_milliseconds RGoodbye + liftIO $ writeIORef server_state Disconnected + C.close rawConnection timeout_milliseconds + + +-- | Send RESET and transition the connection back to the Ready state. +reset :: (MonadIO m, HasCallStack) => Connection -> m () +reset Connection{rawConnection, timeout_milliseconds, server_state} = exceptToThrow $ do + sendRequest rawConnection timeout_milliseconds RReset + response <- receiveResponse rawConnection timeout_milliseconds + case response of + (RSuccess _) -> liftIO $ writeIORef server_state Ready + _ -> throwError ResetFailed + + +-- | Check if a Pipe is alive by sending RESET and expecting SUCCESS. +-- Returns True if healthy, False otherwise. Catches all exceptions. +ping :: MonadIO m => Connection -> m Bool +ping Connection{rawConnection, timeout_milliseconds, server_state} = liftIO $ do + result <- try @SomeException $ runExceptT $ do + sendRequest rawConnection timeout_milliseconds RReset + response <- receiveResponse rawConnection timeout_milliseconds + case response of + (RSuccess _) -> liftIO $ writeIORef server_state Ready + _ -> throwError ResetFailed + pure $ case result of + Right (Right _) -> True + _ -> False + + +-- | Check that the connection is in one of the allowed states, or throw 'InvalidState' +requireState :: MonadPipe m => Connection -> [ServerState] -> T.Text -> m () +requireState Connection{server_state} allowed action = do + st <- liftIO $ readIORef server_state + unless (st `elem` allowed) $ + throwError $ InvalidState st action + + +-- | Update the server state +setState :: MonadIO m => Connection -> ServerState -> m () +setState Connection{server_state} st = liftIO $ writeIORef server_state st + + +-- | Get the current server state +getState :: MonadIO m => Connection -> m ServerState +getState Connection{server_state} = liftIO $ readIORef server_state + + +handshake :: MonadPipe m => NC.Connection -> Int -> ValidatedConfig -> m (Word32, T.Text, T.Text, Bool, Maybe Int) +handshake rawConn tout ValidatedConfig{versions, user_agent, scheme = authScheme, routing} = do + -- https://neo4j.com/docs/bolt/current/bolt/handshake/#_bolt_identification + C.send rawConn tout (encodeStrict (0x6060B017 :: Word32)) + C.send rawConn tout $ P.runPut $ mapM_ putBE versions + server_version :: Word32 <- C.receiveBinary rawConn tout 4 + when (not $ versionAccepted server_version versions) $ throwError $ UnsupportedServerVersion server_version + if supportsLogonLogoff server_version then do + -- Bolt 5.1+: HELLO without credentials (no scheme/principal/credentials fields) + let serverMinor = fromIntegral ((server_version `shiftR` 8) .&. 0xFF) :: Word8 + let helloDict = PsDictionary $ H.fromList $ + [ ("user_agent", PS.toPs user_agent) + ] <> + -- Bolt 5.3+ requires bolt_agent dictionary + ( if serverMinor >= 3 then + [("bolt_agent", PsDictionary $ H.singleton "product" (PS.toPs user_agent))] + else + [] + ) <> + ( case routing of + NoRouting -> [] + Routing -> [("routing", PsDictionary H.empty)] + RoutingSpec address urlQueryParams -> [("routing", PsDictionary $ H.fromList $ + ("address", PS.toPs address) : [(k, PS.toPs v) | (k, v) <- H.toList urlQueryParams])] + ) + sendPs rawConn tout $ PsStructure 0x01 $ V.singleton helloDict + helloResponse <- receiveResponse rawConn tout + case helloResponse of + RSuccess meta -> do + let agent = psToText $ H.lookupDefault (PsString "") "server" meta + let conn_id = psToText $ H.lookupDefault (PsString "") "connection_id" meta + let telem = parseTelemetryHint meta + let idleTO = parseIdleTimeoutHint meta + -- Now send LOGON with credentials + sendRequest rawConn tout $ RLogon $ Logon authScheme + logonResponse <- receiveResponse rawConn tout + case logonResponse of + RSuccess _ -> pure (server_version, agent, conn_id, telem, idleTO) + _ -> throwError AuthentificationFailed + _ -> throwError AuthentificationFailed + else do + -- Bolt 5.0 and below: HELLO with credentials + -- BOLT 4.x: include patch_bolt to get UTC-based DateTime (0x49/0x69) instead of legacy format + let needsPatch = versionMajor server_version == 4 + sendRequest rawConn tout $ RHello $ Hello user_agent authScheme routing needsPatch + response <- receiveResponse rawConn tout + case response of + RSuccess meta -> do + let agent = psToText $ H.lookupDefault (PsString "") "server" meta + let conn_id = psToText $ H.lookupDefault (PsString "") "connection_id" meta + let idleTO = parseIdleTimeoutHint meta + pure (server_version, agent, conn_id, False, idleTO) + _ -> throwError AuthentificationFailed + where + psToText (PsString t) = t + psToText _ = "" + + -- Parse hints.telemetry.enabled from HELLO SUCCESS metadata + parseTelemetryHint :: H.HashMap T.Text Ps -> Bool + parseTelemetryHint meta = + case H.lookup "hints" meta of + Just (PsDictionary hints) -> + case H.lookup "telemetry.enabled" hints of + Just (PsBoolean b) -> b + _ -> False + _ -> False + + -- Parse hints.connection.recv_timeout_seconds from HELLO SUCCESS metadata + parseIdleTimeoutHint :: H.HashMap T.Text Ps -> Maybe Int + parseIdleTimeoutHint meta = + case H.lookup "hints" meta of + Just (PsDictionary hints) -> + case H.lookup "connection.recv_timeout_seconds" hints of + Just (PsInteger n) -> fmap fromIntegral (fromPSInteger n :: Maybe Int64) + _ -> Nothing + _ -> Nothing + + +-- | Check if a server version response matches any of the client's version specs. +-- The client sends compact version specs: word32 = [0, range, minor, major]. +-- The server responds with: word32 = [0, 0, minor, major]. +-- A server version matches a spec if the majors match and the server minor +-- falls in [spec_minor - range, spec_minor]. +versionAccepted :: Word32 -> [Word32] -> Bool +versionAccepted serverVer = any matches + where + serverMajor = fromIntegral (serverVer .&. 0xFF) :: Word8 + serverMinor = fromIntegral ((serverVer `shiftR` 8) .&. 0xFF) :: Word8 + matches spec = + let specMajor = fromIntegral (spec .&. 0xFF) :: Word8 + specMinor = fromIntegral ((spec `shiftR` 8) .&. 0xFF) :: Word8 + specRange = fromIntegral ((spec `shiftR` 16) .&. 0xFF) :: Word8 + in serverMajor == specMajor + && serverMinor <= specMinor + && serverMinor >= specMinor - specRange + + +-- | Receive and decode a chunked BOLT response from the wire. +receiveResponse :: MonadPipe m => NC.Connection -> Int -> m Response +receiveResponse rawConn tout = do + bs :: BS.ByteString <- whileJustM $ do + size :: Word16 <- C.receiveBinary rawConn tout 2 + if size == 0 then + pure Nothing + else + Just <$> C.receiveBytestring rawConn tout (fromIntegral size) + case PS.unpack' bs of + Left e -> throwError $ CannotReadResponse e + Right response -> pure response + + +-- | Serialize and send a BOLT request as chunked data on the wire. +sendRequest :: MonadPipe m => NC.Connection -> Int -> Request -> m () +sendRequest rawConn tout request = sendPs rawConn tout (PS.toPs request) + +sendPs :: MonadPipe m => NC.Connection -> Int -> Ps -> m () +sendPs rawConn tout ps = do + let bs = PS.pack ps + let chunks = chunksOfBSL 65_535 bs + let encoded = BSL.toStrict $ mconcat (map addChunkHeader chunks) <> BSL.pack [0, 0] + C.send rawConn tout encoded + where addChunkHeader :: BSL.ByteString -> BSL.ByteString + addChunkHeader chunk = let size = fromIntegral (BSL.length chunk) :: Word16 + in runPutLazy (putBE size) <> chunk + + +-- | Send a request through a 'Connection'. +flush :: MonadPipe m => Connection -> Request -> m () +flush Connection{rawConnection, timeout_milliseconds} request = + sendRequest rawConnection timeout_milliseconds request + + +-- | Receive the next response from a 'Connection'. +fetch :: MonadPipe m => Connection -> m Response +fetch Connection{rawConnection, timeout_milliseconds} = + receiveResponse rawConnection timeout_milliseconds + + +-- | Send LOGOFF, expect SUCCESS, transition to Authentication state. +-- Only valid on Bolt 5.1+ connections in Ready state. +logoff :: (MonadIO m, HasCallStack) => Connection -> m () +logoff Connection{rawConnection, timeout_milliseconds, server_state} = exceptToThrow $ do + sendRequest rawConnection timeout_milliseconds RLogoff + response <- receiveResponse rawConnection timeout_milliseconds + case response of + RSuccess _ -> liftIO $ writeIORef server_state Authentication + _ -> throwError $ WrongMessageFormat "Expected SUCCESS after LOGOFF" + + +-- | Send LOGON with credentials, expect SUCCESS, transition to Ready state. +-- Only valid on Bolt 5.1+ connections in Authentication state. +logon :: (MonadIO m, HasCallStack) => Connection -> Scheme -> m () +logon Connection{rawConnection, timeout_milliseconds, server_state} authScheme = exceptToThrow $ do + sendRequest rawConnection timeout_milliseconds $ RLogon $ Logon authScheme + response <- receiveResponse rawConnection timeout_milliseconds + case response of + RSuccess _ -> liftIO $ writeIORef server_state Ready + _ -> throwError AuthentificationFailed + + +-- | Send a TELEMETRY message if the server supports it. +-- No-op if telemetry is not enabled or version < 5.4. +sendTelemetry :: (MonadIO m, HasCallStack) => Connection -> TelemetryApi -> m () +sendTelemetry Connection{telemetry_enabled, version, rawConnection, timeout_milliseconds} api + | telemetry_enabled && supportsTelemetry version = exceptToThrow $ do + sendRequest rawConnection timeout_milliseconds $ RTelemetry api + response <- receiveResponse rawConnection timeout_milliseconds + case response of + RSuccess _ -> pure () + _ -> throwError $ WrongMessageFormat "Expected SUCCESS after TELEMETRY" + | otherwise = pure () + + +-- --------------------------------------------------------------------------- +-- Connection accessors +-- --------------------------------------------------------------------------- + +-- | Get the negotiated BOLT protocol version. +connectionVersion :: Connection -> Word32 +connectionVersion Connection{version} = version + +-- | Get the server agent string. +connectionAgent :: Connection -> T.Text +connectionAgent Connection{server_agent} = server_agent + +-- | Get the server-assigned connection ID. +connectionId :: Connection -> T.Text +connectionId Connection{connection_id} = connection_id + +-- | Get the server-advertised idle timeout in seconds, if any. +connectionServerIdleTimeout :: Connection -> Maybe Int +connectionServerIdleTimeout Connection{serverIdleTimeout} = serverIdleTimeout + +-- | Check whether the server supports telemetry. +connectionTelemetryEnabled :: Connection -> Bool +connectionTelemetryEnabled Connection{telemetry_enabled} = telemetry_enabled + +-- | Update the connection's last-activity timestamp to now. +touchConnection :: MonadIO m => Connection -> m () +touchConnection Connection{lastActivity} = liftIO $ do + now <- getMonotonicTimeNSec + writeIORef lastActivity now + +-- | Get the monotonic timestamp (in nanoseconds) of the last connection activity. +connectionLastActivity :: MonadIO m => Connection -> m Word64 +connectionLastActivity Connection{lastActivity} = liftIO $ readIORef lastActivity + + +-- --------------------------------------------------------------------------- +-- Transaction primitives (plain IO) +-- --------------------------------------------------------------------------- + +-- | Begin an explicit transaction with bookmarks and access mode. +beginTx :: HasCallStack => Connection -> Begin -> IO () +beginTx conn@Connection{rawConnection, timeout_milliseconds, server_state} params = exceptToThrow $ do + requireState conn [Ready] "BEGIN" + sendRequest rawConnection timeout_milliseconds $ RBegin params + response <- receiveResponse rawConnection timeout_milliseconds + case response of + RSuccess _ -> liftIO $ writeIORef server_state TXready + RFailure Failure{code, message} -> do + liftIO $ writeIORef server_state Failed + liftIO $ reset conn + throwError $ ResponseErrorFailure code message + _ -> do + liftIO $ reset conn + throwError $ WrongMessageFormat "Unexpected response to BEGIN" + +-- | Commit the current transaction and return the bookmark (if any). +commitTx :: HasCallStack => Connection -> IO (Maybe T.Text) +commitTx conn@Connection{rawConnection, timeout_milliseconds, server_state} = exceptToThrow $ do + requireState conn [TXready] "COMMIT" + sendRequest rawConnection timeout_milliseconds RCommit + response <- receiveResponse rawConnection timeout_milliseconds + case response of + RSuccess meta -> do + liftIO $ writeIORef server_state Ready + pure $ extractBookmark meta + RFailure Failure{code, message} -> do + liftIO $ writeIORef server_state Failed + liftIO $ reset conn + throwError $ ResponseErrorFailure code message + _ -> do + liftIO $ reset conn + throwError $ WrongMessageFormat "Unexpected response to COMMIT" + +-- | Rollback the current transaction. +rollbackTx :: HasCallStack => Connection -> IO () +rollbackTx conn@Connection{rawConnection, timeout_milliseconds, server_state} = exceptToThrow $ do + requireState conn [TXready] "ROLLBACK" + sendRequest rawConnection timeout_milliseconds RRollback + response <- receiveResponse rawConnection timeout_milliseconds + case response of + RSuccess _ -> liftIO $ writeIORef server_state Ready + RFailure Failure{code, message} -> do + liftIO $ writeIORef server_state Failed + liftIO $ reset conn + throwError $ ResponseErrorFailure code message + _ -> do + liftIO $ reset conn + throwError $ WrongMessageFormat "Unexpected response to ROLLBACK" + + +-- | Try to rollback the current transaction, ignoring errors. +-- Used as cleanup in onException handlers. +tryRollback :: Connection -> IO () +tryRollback conn = do + st <- getState conn + when (st == TXready || st == TXstreaming) $ + catch (rollbackTx conn) handler + where + handler :: Error -> IO () + handler _ = pure () + + +-- --------------------------------------------------------------------------- +-- Plain IO wire helpers +-- --------------------------------------------------------------------------- + +-- | Check the connection state, throw InvalidState if wrong. +requireStateIO :: HasCallStack => Connection -> [ServerState] -> T.Text -> IO () +requireStateIO conn allowed action = do + st <- getState conn + unless (st `elem` allowed) $ throwIO $ InvalidState st action + +-- | Send a request, throwing on wire error. +flushIO :: HasCallStack => Connection -> Request -> IO () +flushIO Connection{rawConnection, timeout_milliseconds} req = + exceptToThrow $ sendRequest rawConnection timeout_milliseconds req + +-- | Receive a response, throwing on wire error. +fetchIO :: HasCallStack => Connection -> IO Response +fetchIO Connection{rawConnection, timeout_milliseconds} = + exceptToThrow $ receiveResponse rawConnection timeout_milliseconds diff --git a/src/Database/Bolty/Connection/Server.hs b/src/Database/Bolty/Connection/Server.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection/Server.hs @@ -0,0 +1,9 @@ +-- | Internal module. Not part of the public API. +-- +-- Server state machine for the BOLT protocol. +-- +-- This module is planned to implement type-safe server state transitions. +-- See: https://neo4j.com/docs/bolt/current/bolt/server-state/ +module Database.Bolty.Connection.Server + ( + ) where diff --git a/src/Database/Bolty/Connection/Type.hs b/src/Database/Bolty/Connection/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection/Type.hs @@ -0,0 +1,234 @@ +-- | Internal module. Not part of the public API. +-- +-- Core types for Neo4j BOLT connections: configuration, errors, and connection handles. +module Database.Bolty.Connection.Type + ( Config(..) + , ValidatedConfig(..) + , ServerState(..) + , Connection(..) + , Error(..) + , Scheme(..) + , Principal + , Credentials + , Routing(..) + , UserAgent(..) + , isTransient + , isRoutingError + ) where + +import Data.Kind (Type) +import Control.Exception (Exception, SomeException) +import Data.Default (Default(..)) +import Data.IORef (IORef) +import Data.Text (Text) +import Data.Word (Word16, Word32, Word64) +import GHC.Generics (Generic) +import qualified Network.Connection as NC +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T + +import Database.Bolty.Connection.Version (Version(..)) +import Database.Bolty.Logging (QueryLog(..)) +import Database.Bolty.Message.Response (QueryMeta) +import Database.Bolty.Notification (Notification) + + +-- | Connection configuration. Use 'Data.Default.def' for sensible defaults and +-- override the fields you need. Must be validated with 'validateConfig' before use. +type Config :: Type +data Config = Config + { host :: T.Text + -- ^ Server hostname or IP address. Default: @\"127.0.0.1\"@. + , port :: Word16 + -- ^ Server port. Default: @7687@. + , scheme :: Scheme + -- ^ Authentication scheme. Default: 'None'. + , use_tls :: Bool + -- ^ Whether to use TLS. Default: @True@. + , versions :: [Version] + -- ^ BOLT protocol versions to negotiate, in preference order. + , timeout :: Int + -- ^ Connection timeout in milliseconds. Default: @10000@. + , routing :: Routing + -- ^ Routing configuration. Default: 'NoRouting'. + , user_agent :: UserAgent + -- ^ User-agent string sent in HELLO. + , queryLogger :: Maybe (QueryLog -> QueryMeta -> IO ()) + -- ^ Optional callback fired after each query completes. + , notificationHandler :: Maybe (Notification -> IO ()) + -- ^ Optional callback fired for each server notification (warnings, hints, deprecations). + } + +instance Default Config where + def = Config + { host = "127.0.0.1" + , port = 7687 + , scheme = None + , use_tls = True + , versions = [ Version{major = 5, minor = 4} + , Version{major = 5, minor = 3} + , Version{major = 5, minor = 2} + , Version{major = 5, minor = 1} + , Version{major = 5, minor = 0} + , Version{major = 4, minor = 4} + ] + , timeout = 10_000 + , routing = NoRouting + , user_agent = UserAgent{name = "bolty", version = "2.0"} + , queryLogger = Nothing + , notificationHandler = Nothing + } + +-- | A validated configuration ready for 'Database.Bolty.connect'. Created via 'validateConfig'. +type ValidatedConfig :: Type +data ValidatedConfig = ValidatedConfig + { host :: T.Text + , port :: Word16 + , scheme :: Scheme + , use_tls :: Bool + , versions :: [Word32] + -- ^ Encoded BOLT version words. + , timeout :: Int + , routing :: Routing + , user_agent :: UserAgent + , queryLogger :: Maybe (QueryLog -> QueryMeta -> IO ()) + , notificationHandler :: Maybe (Notification -> IO ()) + } + + +-- | https://neo4j.com/docs/bolt/current/bolt/server-state/#server-states +type ServerState :: Type +data ServerState + = Disconnected + | Connected + | Defunct + | Authentication + | Ready + | Streaming + | TXready + | TXstreaming + | Failed + | Interrupted + deriving stock (Show, Eq) + + +-- | An open connection to a Neo4j server. Obtain via 'Database.Bolty.connect'. +type Connection :: Type +data Connection = Connection + { rawConnection :: !NC.Connection + , timeout_milliseconds :: !Int + , version :: Word32 + -- ^ Negotiated BOLT protocol version. + , server_state :: IORef ServerState + , server_agent :: Text + -- ^ Server agent string from HELLO response. + , connection_id :: Text + -- ^ Server-assigned connection ID. + , lastActivity :: IORef Word64 + -- ^ Monotonic nanosecond timestamp of last successful operation. + -- Used by 'PingIfIdle' validation strategy to skip health checks + -- on recently-used connections. + , telemetry_enabled :: Bool + -- ^ Whether the server supports telemetry (from HELLO SUCCESS hints). + , serverIdleTimeout :: Maybe Int + -- ^ Server-advertised idle timeout in seconds (from @connection.recv_timeout_seconds@ hint). + -- 'Nothing' if the server didn't send this hint (Bolt < 5.x or hint not present). + , queryLogger :: Maybe (QueryLog -> QueryMeta -> IO ()) + -- ^ Optional callback fired after each query completes. + , notificationHandler :: Maybe (Notification -> IO ()) + -- ^ Optional callback fired for each server notification. + } + + +instance Exception Error + +-- | Errors that can occur during BOLT communication. +type Error :: Type +data Error + = TimeOut T.Text + -- ^ A network operation timed out. + | AuthentificationFailed + -- ^ The server rejected the authentication credentials. + | UnsupportedServerVersion Word32 + -- ^ No mutually supported BOLT version could be negotiated. + | ResetFailed + -- ^ A RESET message failed (connection is likely defunct). + | CannotReadResponse T.Text + -- ^ Failed to parse a response from the server. + | NonboltyError SomeException + -- ^ A non-BOLT exception (e.g. network IO error). + | ResponseErrorRecords + -- ^ Received records when a non-record response was expected. + | WrongMessageFormat T.Text + -- ^ The server sent an unexpected message type. + | ResponseErrorIgnored + -- ^ The server sent an IGNORED response. + | ResponseErrorFailure T.Text T.Text + -- ^ A FAILURE response with Neo4j error code and message. + | InvalidState ServerState T.Text + -- ^ Attempted an operation in an invalid server state. + | RoutingTableError T.Text + -- ^ Failed to fetch or parse a routing table. + deriving stock (Show) + + +-- | Username for authentication. +type Principal :: Type +type Principal = T.Text +-- | Password or token for authentication. +type Credentials :: Type +type Credentials = T.Text + +-- | Authentication scheme for the HELLO handshake. +type Scheme :: Type +data Scheme + = None + -- ^ No authentication. + | Basic !Principal !Credentials + -- ^ Basic username\/password authentication. + | Kerberos + -- ^ Kerberos authentication (ticket obtained externally). + | Bearer !Credentials + -- ^ Bearer token authentication (e.g. SSO). + deriving stock (Eq, Generic) + + +-- | Routing mode for cluster-aware connections. +type Routing :: Type +data Routing + = NoRouting + -- ^ Direct connection (no routing). + | Routing + -- ^ Use server-side routing with default settings. + | RoutingSpec !T.Text !(H.HashMap T.Text T.Text) + -- ^ Use server-side routing with explicit address and parameters. + -- Arguments: advertised address (e.g. @\"core1:7687\"@), additional routing context parameters. + deriving stock (Eq) + + +-- | User-agent identifier sent to the server in the HELLO message. +type UserAgent :: Type +data UserAgent = UserAgent + { name :: !T.Text + -- ^ Application name. + , version :: !T.Text + -- ^ Application version. + } + deriving stock (Eq) + + +-- | Check if an error is a transient Neo4j failure that can be retried. +isTransient :: Error -> Bool +isTransient (ResponseErrorFailure code _) = "Neo.TransientError." `T.isPrefixOf` code +isTransient (RoutingTableError _) = True +isTransient _ = False + +-- | Check if an error indicates stale routing information. +-- These errors mean the driver sent a request to the wrong server +-- (e.g. a write to a read replica). The routing table should be +-- invalidated and the operation retried on a fresh leader. +isRoutingError :: Error -> Bool +isRoutingError (ResponseErrorFailure code _) = + "Neo.ClientError.Cluster.NotALeader" `T.isPrefixOf` code + || "Neo.ClientError.General.ForbiddenOnReadOnlyDatabase" `T.isPrefixOf` code +isRoutingError _ = False diff --git a/src/Database/Bolty/Connection/Version.hs b/src/Database/Bolty/Connection/Version.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Connection/Version.hs @@ -0,0 +1,90 @@ +-- | Internal module. Not part of the public API. +module Database.Bolty.Connection.Version + ( boltVersionsToSpec + , Version(..) + ) where + +import Data.Bits (shiftL, (.|.)) +import Data.Kind (Type) +import Data.List (foldl', sort) +import Data.Maybe (catMaybes) +import Data.Word (Word8, Word32) +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Validation as V +import TextShow (showt) + + +-- | A BOLT protocol version (major.minor). +type Version :: Type +data Version = Version + { minor :: Word8 + , major :: Word8 + } + deriving stock (Eq) + +instance Ord Version where + compare Version{minor = minorA, major = majorA} Version{minor = minorB, major = majorB} = + let compare_major = compare majorA majorB + in if compare_major == EQ then + compare minorA minorB + else + compare_major + + +validateVersion :: Version -> Maybe T.Text +validateVersion Version{minor, major} + | major < 4 = Just "Bolt protocol versions below 4.4 are not supported" + | major == 4 && minor < 4 = Just "Bolt protocol version 4.4 is the minimum supported minor; 4.0-4.3 are not supported" + | major == 4 && minor > 4 = Just "Bolt protocol version 4 does not have any minor versions higher than 4 (4.4 is the highest minor)" + | major == 5 && minor > 4 = Just "The driver supports up to Bolt 5.4" + | major > 5 = Just "The latest supported Bolt major version is 5, please open a github issue for support for later protocols" + | otherwise = Nothing + +-- | Validate and compact a list of BOLT versions into a 4-element handshake spec. +boltVersionsToSpec :: [Version] -> V.Validation [T.Text] [Word32] +boltVersionsToSpec [] = V.Failure ["Specify at least one protocol version"] +boltVersionsToSpec versions = + let errors :: [(Version, T.Text)] + errors = catMaybes $ map (\x -> fmap (\e -> (x, e)) $ validateVersion x) versions + version_error_to_string :: (Version, T.Text) -> T.Text + version_error_to_string (Version{minor, major}, err) = showt (BS.singleton major) <> "." <> showt (BS.singleton minor) <> ": " <> err + in if not (null errors) then + V.Failure $ map version_error_to_string errors + else + let ws = compactVersions versions + in if length ws > 4 then + V.Failure ["Could not make a version specification, try specifying less versions"] + else + V.Success $ ws <> replicate (4 - length ws) (0 :: Word32) + + +word8ToWord32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 +word8ToWord32 a b c d + = (fromIntegral a `shiftL` 24) + .|. (fromIntegral b `shiftL` 16) + .|. (fromIntegral c `shiftL` 8) + .|. fromIntegral d + +compactVersions :: [Version] -> [Word32] +compactVersions versions = + let (trailing, acc) = foldl' f (Nothing, []) $ reverse $ sort versions + in acc <> maybe [] (\p -> [versionAndBelowToWord p]) trailing + where versionAndBelowToWord :: (Version, Word8) -> Word32 + versionAndBelowToWord (Version{minor, major}, versions_below) = word8ToWord32 0 versions_below minor major + + f :: (Maybe (Version, Word8), [Word32]) -> Version -> (Maybe (Version, Word8), [Word32]) + f (previous, acc) current@Version{minor = minorCurrent, major = majorCurrent} = + let supportsVersionCompression = (majorCurrent == 4 && minorCurrent >= 3) || majorCurrent > 4 + in if not supportsVersionCompression then + case previous of + Nothing -> (Nothing, acc <> [versionAndBelowToWord (current, 0)]) + Just p -> (Nothing, acc <> [versionAndBelowToWord p, versionAndBelowToWord (current, 0)]) + else + case previous of + Just (p@(Version{minor = minorLast, major = majorLast}), versions_below) -> + if majorLast == majorCurrent && minorCurrent == minorLast - versions_below - 1 then + (Just (p, versions_below + 1), acc) + else + (Just (current, 0), acc <> [versionAndBelowToWord (p, versions_below)]) + Nothing -> (Just (current, 0), acc) diff --git a/src/Database/Bolty/Decode.hs b/src/Database/Bolty/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Decode.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Type-safe decoding of query result records. +-- +-- Instead of manually pattern-matching on 'Bolt' values, build composable +-- 'Decode' and 'RowDecoder' values that validate types at extraction time. +-- +-- @ +-- import Database.Bolty.Decode +-- +-- data Person = Person { pName :: Text, pAge :: Int64 } +-- +-- personDecoder :: 'RowDecoder' Person +-- personDecoder = Person +-- \<$\> 'field' \"name\" 'text' +-- \<*\> 'field' \"age\" 'int64' +-- @ +module Database.Bolty.Decode + ( DecodeError(..) + , Decode(..) + , RowDecoder(..) + , FromBolt(..) + , ToBolt(..) + -- * Primitive decoders + , bool, int, int64, float, text, bytes, nullable, list, dict + -- * UUID decoder + , uuid + -- * Time decoders + , utcTime, day, timeOfDay + -- * Aeson decoder + , aesonValue + -- * Node property decoders + , nodeProperty, nodePropertyOptional, nodeLabels, nodeProperties + -- * PackStream interop + , psDecode + -- * Graph type decoders + , node, relationship, path + -- * Record-level decoders + , column, field + -- * Running decoders + , decodeRow, decodeRows + -- * Internal converters (exported for testing) + , psToBolt, boltToPs + ) where + +import Data.Kind (Constraint, Type) +import Control.Exception (Exception) +import TextShow (TextShow(..), fromText) +import Data.Int (Int64) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as Aeson +import qualified Data.ByteString as BS +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.UUID.Types as UUID +import qualified Data.Vector as V +import Data.Scientific (fromFloatDigits) +import Data.Time.Calendar.OrdinalDate (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.Time.LocalTime (TimeOfDay) +import GHC.Float (int2Double) + +import Data.PackStream.Integer (PSInteger, fromPSInteger) +import Data.PackStream.Ps (Ps(..), PackStream(..)) +import Data.PackStream.Result (Result(..)) +import Database.Bolty.Value.Type +import Database.Bolty.Value.Helpers (sigNode, sigRel, sigURel, sigPath + , sigDate, sigTime, sigLocalTime, sigDateTime + , sigDateTimeZoneId, sigLocalDateTime, sigDuration + , sigPoint2D, sigPoint3D) +import Database.Bolty.Record (Record) + + +-- | Errors that can occur when decoding a 'Bolt' value or record row. +type DecodeError :: Type +data DecodeError + = TypeMismatch T.Text T.Text + -- ^ The value had a different type than expected (expected, got). + | MissingField T.Text + -- ^ A named field was not present in the column list. + | IndexOutOfBounds Int Int + -- ^ Column index was out of range (requested index, actual length). + | EmptyResultSet + -- ^ The result set contained no records. + deriving stock (Show, Eq) + +instance Exception DecodeError + +instance TextShow DecodeError where + showb (TypeMismatch e g) = "TypeMismatch {expected = \"" <> fromText e <> "\", got = \"" <> fromText g <> "\"}" + showb (MissingField f) = "MissingField \"" <> fromText f <> "\"" + showb (IndexOutOfBounds i l) = "IndexOutOfBounds " <> showb i <> " " <> showb l + showb EmptyResultSet = "EmptyResultSet" + + +-- | A decoder for a single 'Bolt' value. +type Decode :: Type -> Type +type role Decode representational +newtype Decode a = Decode { runDecode :: Bolt -> Either DecodeError a } + +instance Functor Decode where + fmap f (Decode g) = Decode (fmap f . g) + +instance Applicative Decode where + pure a = Decode (\_ -> Right a) + Decode f <*> Decode a = Decode $ \b -> f b <*> a b + +instance Monad Decode where + Decode m >>= k = Decode $ \b -> do + a <- m b + runDecode (k a) b + + +-- | Helper to build a decoder from an extractor function. +fromExtractor :: T.Text -> (Bolt -> Maybe a) -> Decode a +fromExtractor name extract = Decode $ \b -> + case extract b of + Just a -> Right a + Nothing -> Left $ TypeMismatch name (boltTypeName b) + +boltTypeName :: Bolt -> T.Text +boltTypeName BoltNull = "Null" +boltTypeName (BoltBoolean _) = "Boolean" +boltTypeName (BoltInteger _) = "Integer" +boltTypeName (BoltFloat _) = "Float" +boltTypeName (BoltBytes _) = "Bytes" +boltTypeName (BoltString _) = "String" +boltTypeName (BoltList _) = "List" +boltTypeName (BoltDictionary _) = "Dictionary" +boltTypeName (BoltNode _) = "Node" +boltTypeName (BoltRelationship _) = "Relationship" +boltTypeName (BoltUnboundRelationship _) = "UnboundRelationship" +boltTypeName (BoltPath _) = "Path" +boltTypeName (BoltDate _) = "Date" +boltTypeName (BoltTime _) = "Time" +boltTypeName (BoltLocalTime _) = "LocalTime" +boltTypeName (BoltDateTime _) = "DateTime" +boltTypeName (BoltDateTimeZoneId _) = "DateTimeZoneId" +boltTypeName (BoltLocalDateTime _) = "LocalDateTime" +boltTypeName (BoltDuration _) = "Duration" +boltTypeName (BoltPoint2D _) = "Point2D" +boltTypeName (BoltPoint3D _) = "Point3D" + + +-- * Primitive decoders + +-- | Decode a 'BoltBoolean'. +bool :: Decode Bool +bool = fromExtractor "Boolean" asBool + +-- | Decode a 'BoltInteger' as a 'PSInteger'. +int :: Decode PSInteger +int = fromExtractor "Integer" asInt + +-- | Decode a 'BoltInteger' narrowed to 'Int64'. Fails if the value is out of range. +int64 :: Decode Int64 +int64 = Decode $ \b -> case asInt b of + Just n -> case fromPSInteger n of + Just i -> Right i + Nothing -> Left $ TypeMismatch "Int64" "Integer (out of range)" + Nothing -> Left $ TypeMismatch "Integer" (boltTypeName b) + +-- | Decode a 'BoltFloat'. +float :: Decode Double +float = fromExtractor "Float" asFloat + +-- | Decode a 'BoltString'. +text :: Decode T.Text +text = fromExtractor "String" asText + +-- | Decode a 'BoltBytes'. +bytes :: Decode BS.ByteString +bytes = fromExtractor "Bytes" asBytes + +-- | Make a decoder nullable: returns 'Nothing' for 'BoltNull', otherwise applies the inner decoder. +nullable :: Decode a -> Decode (Maybe a) +nullable (Decode f) = Decode $ \b -> case b of + BoltNull -> Right Nothing + _ -> Just <$> f b + +-- | Decode a 'BoltList', applying the element decoder to each item. +list :: Decode a -> Decode (V.Vector a) +list (Decode f) = Decode $ \b -> case b of + BoltList v -> traverse f v + _ -> Left $ TypeMismatch "List" (boltTypeName b) + +-- | Decode a 'BoltDictionary'. +dict :: Decode (H.HashMap T.Text Bolt) +dict = fromExtractor "Dictionary" asDict + + +-- * UUID decoder + +-- | Decode a UUID from a 'BoltString'. +uuid :: Decode UUID.UUID +uuid = Decode $ \b -> case b of + BoltString t -> case UUID.fromText t of + Just u -> Right u + Nothing -> Left $ TypeMismatch "UUID" ("String (invalid UUID: " <> t <> ")") + _ -> Left $ TypeMismatch "UUID (String)" (boltTypeName b) + + +-- * Time decoders + +-- | Decode a 'UTCTime' from a 'BoltString' (ISO 8601) or 'BoltDateTime'. +utcTime :: Decode UTCTime +utcTime = Decode $ \b -> case b of + BoltString t -> case iso8601ParseM (T.unpack t) of + Just u -> Right u + Nothing -> Left $ TypeMismatch "UTCTime" ("String (invalid ISO8601: " <> t <> ")") + BoltDateTime dt -> + Right $ posixSecondsToUTCTime $ fromIntegral dt.seconds + BoltDateTimeZoneId dt -> + Right $ posixSecondsToUTCTime $ fromIntegral dt.seconds + BoltLocalDateTime dt -> + Right $ posixSecondsToUTCTime $ fromIntegral dt.seconds + _ -> Left $ TypeMismatch "UTCTime (String/DateTime)" (boltTypeName b) + +-- | Decode a 'Day' from a 'BoltString' (ISO 8601). +day :: Decode Day +day = Decode $ \b -> case b of + BoltString t -> case iso8601ParseM (T.unpack t) of + Just d -> Right d + Nothing -> Left $ TypeMismatch "Day" ("String (invalid ISO8601: " <> t <> ")") + _ -> Left $ TypeMismatch "Day (String)" (boltTypeName b) + +-- | Decode a 'TimeOfDay' from a 'BoltString' (ISO 8601). +timeOfDay :: Decode TimeOfDay +timeOfDay = Decode $ \b -> case b of + BoltString t -> case iso8601ParseM (T.unpack t) of + Just v -> Right v + Nothing -> Left $ TypeMismatch "TimeOfDay" ("String (invalid ISO8601: " <> t <> ")") + _ -> Left $ TypeMismatch "TimeOfDay (String)" (boltTypeName b) + + +-- * Aeson decoder + +-- | Decode any Bolt value to an 'Aeson.Value'. +aesonValue :: Decode Aeson.Value +aesonValue = Decode boltToAeson + where + boltToAeson :: Bolt -> Either DecodeError Aeson.Value + boltToAeson BoltNull = Right Aeson.Null + boltToAeson (BoltBoolean b) = Right $ Aeson.Bool b + boltToAeson (BoltInteger n) = case fromPSInteger n :: Maybe Int of + Just i -> Right $ Aeson.Number $ fromFloatDigits $ int2Double i + Nothing -> Left $ TypeMismatch "Aeson.Value" "Integer (out of range)" + boltToAeson (BoltFloat d) = Right $ Aeson.Number $ fromFloatDigits d + boltToAeson (BoltString t) = Right $ Aeson.String t + boltToAeson (BoltList v) = Aeson.Array <$> traverse boltToAeson v + boltToAeson (BoltDictionary m) = do + pairs <- traverse boltToAeson m + Right $ Aeson.Object $ Aeson.fromList $ map (\(k, v) -> (Key.fromText k, v)) $ H.toList pairs + boltToAeson other = Left $ TypeMismatch "Aeson.Value" (boltTypeName other) + + +-- * Node property decoders + +-- | Extract a property from a 'BoltNode' by key and decode it. +nodeProperty :: T.Text -> Decode a -> Decode a +nodeProperty key (Decode f) = Decode $ \b -> case b of + BoltNode n -> case H.lookup key n.properties of + Just ps -> f (psToBolt ps) + Nothing -> Left $ MissingField key + _ -> Left $ TypeMismatch "Node" (boltTypeName b) + +-- | Extract a property from a 'BoltNode' by key, returning 'Nothing' if the key is missing. +nodePropertyOptional :: T.Text -> Decode a -> Decode (Maybe a) +nodePropertyOptional key (Decode f) = Decode $ \b -> case b of + BoltNode n -> case H.lookup key n.properties of + Just ps -> Just <$> f (psToBolt ps) + Nothing -> Right Nothing + _ -> Left $ TypeMismatch "Node" (boltTypeName b) + +-- | Extract labels from a 'BoltNode'. +nodeLabels :: Decode (V.Vector T.Text) +nodeLabels = Decode $ \b -> case b of + BoltNode n -> Right n.labels + _ -> Left $ TypeMismatch "Node" (boltTypeName b) + +-- | Extract the raw properties HashMap from a 'BoltNode'. +nodeProperties :: Decode (H.HashMap T.Text Ps) +nodeProperties = Decode $ \b -> case b of + BoltNode n -> Right n.properties + _ -> Left $ TypeMismatch "Node" (boltTypeName b) + + +-- * PackStream interop + +-- | Decode via the PackStream 'fromPs' roundtrip through a node property's Ps value. +-- Useful for types that already have PackStream instances. +psDecode :: PackStream a => Decode a +psDecode = Decode $ \b -> case fromPs (boltToPs b) of + Success v -> Right v + Error e -> Left $ TypeMismatch "PackStream" e + + +-- * Graph type decoders + +-- | Decode a 'BoltNode'. +node :: Decode Node +node = fromExtractor "Node" asNode + +-- | Decode a 'BoltRelationship'. +relationship :: Decode Relationship +relationship = fromExtractor "Relationship" asRelationship + +-- | Decode a 'BoltPath'. +path :: Decode Path +path = fromExtractor "Path" asPath + + +-- * Record-level decoders + +-- | A decoder for a full result row. Compose with 'Applicative' to decode multiple columns. +type RowDecoder :: Type -> Type +type role RowDecoder representational +newtype RowDecoder a = RowDecoder + { runRowDecoder :: V.Vector T.Text -> Record -> Either DecodeError a } + +instance Functor RowDecoder where + fmap f (RowDecoder g) = RowDecoder $ \cols rec -> f <$> g cols rec + +instance Applicative RowDecoder where + pure a = RowDecoder $ \_ _ -> Right a + RowDecoder f <*> RowDecoder a = RowDecoder $ \cols rec -> + f cols rec <*> a cols rec + + +-- | Types that can be decoded from a result row without an explicit decoder. +-- +-- Implement this for your application types to use 'Database.Bolty.query' +-- without passing a 'RowDecoder' explicitly: +-- +-- @ +-- data Person = Person { name :: Text, age :: Int64 } +-- +-- instance FromBolt Person where +-- rowDecoder = Person \<$\> field \"name\" text \<*\> field \"age\" int64 +-- @ +type FromBolt :: Type -> Constraint +class FromBolt a where + rowDecoder :: RowDecoder a + + +-- | Types that can be encoded to a 'Ps' value for use as query parameters. +-- All 'PackStream' instances are automatically 'ToBolt' instances. +type ToBolt :: Type -> Constraint +class ToBolt a where + toBolt :: a -> Ps + +instance PackStream a => ToBolt a where + toBolt = toPs + + +-- | Decode a value at a positional column index. +column :: Int -> Decode a -> RowDecoder a +column idx (Decode f) = RowDecoder $ \_ rec -> + let len = V.length rec + in if idx < 0 || idx >= len + then Left $ IndexOutOfBounds idx len + else f (rec V.! idx) + +-- | Decode a value by column name. +field :: T.Text -> Decode a -> RowDecoder a +field name (Decode f) = RowDecoder $ \cols rec -> + case V.elemIndex name cols of + Nothing -> Left $ MissingField name + Just idx -> f (rec V.! idx) + + +-- * Running decoders + +-- | Decode a single record row. +decodeRow :: RowDecoder a -> V.Vector T.Text -> Record -> Either DecodeError a +decodeRow (RowDecoder f) = f + +-- | Decode all records in a result set. Fails on the first 'DecodeError'. +decodeRows :: RowDecoder a -> V.Vector T.Text -> V.Vector Record -> Either DecodeError (V.Vector a) +decodeRows decoder cols = traverse (decodeRow decoder cols) + + +-- * Internal helpers + +-- | Convert a Ps value to a Bolt value. +psToBolt :: Ps -> Bolt +psToBolt PsNull = BoltNull +psToBolt (PsBoolean b) = BoltBoolean b +psToBolt (PsInteger n) = BoltInteger n +psToBolt (PsFloat d) = BoltFloat d +psToBolt (PsString t) = BoltString t +psToBolt (PsBytes b) = BoltBytes b +psToBolt (PsList v) = BoltList $ V.map psToBolt v +psToBolt (PsDictionary m) = BoltDictionary $ H.map psToBolt m +psToBolt ps@(PsStructure t _) + | t == sigNode = tryFromPs BoltNode ps + | t == sigRel = tryFromPs BoltRelationship ps + | t == sigURel = tryFromPs BoltUnboundRelationship ps + | t == sigPath = tryFromPs BoltPath ps + | t == sigDate = tryFromPs BoltDate ps + | t == sigTime = tryFromPs BoltTime ps + | t == sigLocalTime = tryFromPs BoltLocalTime ps + | t == sigDateTime = tryFromPs BoltDateTime ps + | t == sigDateTimeZoneId = tryFromPs BoltDateTimeZoneId ps + | t == sigLocalDateTime = tryFromPs BoltLocalDateTime ps + | t == sigDuration = tryFromPs BoltDuration ps + | t == sigPoint2D = tryFromPs BoltPoint2D ps + | t == sigPoint3D = tryFromPs BoltPoint3D ps + | otherwise = BoltNull + where + tryFromPs :: PackStream a => (a -> Bolt) -> Ps -> Bolt + tryFromPs wrap p = case fromPs p of + Success v -> wrap v + _ -> BoltNull + +-- | Convert a Bolt value to a Ps value. +boltToPs :: Bolt -> Ps +boltToPs BoltNull = PsNull +boltToPs (BoltBoolean b) = PsBoolean b +boltToPs (BoltInteger n) = PsInteger n +boltToPs (BoltFloat d) = PsFloat d +boltToPs (BoltString t) = PsString t +boltToPs (BoltBytes b) = PsBytes b +boltToPs (BoltList v) = PsList $ V.map boltToPs v +boltToPs (BoltDictionary m) = PsDictionary $ H.map boltToPs m +boltToPs (BoltNode n) = toPs n +boltToPs (BoltRelationship r) = toPs r +boltToPs (BoltUnboundRelationship r) = toPs r +boltToPs (BoltPath p) = toPs p +boltToPs (BoltDate d) = toPs d +boltToPs (BoltTime t) = toPs t +boltToPs (BoltLocalTime t) = toPs t +boltToPs (BoltDateTime dt) = toPs dt +boltToPs (BoltDateTimeZoneId dt) = toPs dt +boltToPs (BoltLocalDateTime dt) = toPs dt +boltToPs (BoltDuration d) = toPs d +boltToPs (BoltPoint2D p) = toPs p +boltToPs (BoltPoint3D p) = toPs p diff --git a/src/Database/Bolty/Logging.hs b/src/Database/Bolty/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Logging.hs @@ -0,0 +1,33 @@ +-- | Query logging types for observability. +module Database.Bolty.Logging + ( QueryLog(..) + ) where + +import Data.Int (Int64) +import Data.Kind (Type) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import Data.PackStream.Ps (Ps) + + +-- | Information about a completed query, passed to the 'queryLogger' callback. +type QueryLog :: Type +data QueryLog = QueryLog + { qlCypher :: !T.Text + -- ^ The Cypher query text. + , qlParameters :: !(H.HashMap T.Text Ps) + -- ^ The query parameters (empty map if none). + , qlRowCount :: !Int + -- ^ Number of result records returned. + -- Server-reported timing + , qlServerFirst :: !Int64 + -- ^ @t_first@: milliseconds until the first record was available on the server. + , qlServerLast :: !Int64 + -- ^ @t_last@: milliseconds until the last record was consumed on the server. + -- Client-measured timing + , qlClientTime :: !Double + -- ^ Wall-clock milliseconds for the full round-trip (RUN send to PULL complete), + -- measured with 'GHC.Clock.getMonotonicTimeNSec'. Includes network latency, + -- serialization, and deserialization overhead. + } + deriving stock (Show) diff --git a/src/Database/Bolty/Message/Request.hs b/src/Database/Bolty/Message/Request.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Message/Request.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE ApplicativeDo #-} + +-- | Internal module. Not part of the public API. +module Database.Bolty.Message.Request + ( Request(..) + , Hello(..) + , Logon(..) + , TelemetryApi(..) + , RunExplicitTransaction(..) + , RunAutoCommitTransaction(..), defaultRunAutoCommitTransaction, mkRunAutoCommit + , Discard(..) + , Begin(..) + , Pull(..), defaultPull + , Route(..) + , RouteExtra(..) + , RunExtra(..), defaultRunExtra + ) where + +import Data.HashMap.Lazy (HashMap) +import Data.Int (Int64) +import Data.Kind (Type) +import GHC.Generics (Generic) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V + +import Data.PackStream +import Data.PackStream.Integer (toPSInteger, fromPSInteger) +import Database.Bolty.Connection.Instances () +import Database.Bolty.Connection.Type (UserAgent(..), Scheme(..), Routing(..)) + + +-- | A BOLT client request message. +type Request :: Type +data Request + = RHello Hello + | RGoodbye + | RReset + | RRunExplicitTransaction RunExplicitTransaction + | RRunAutoCommitTransaction RunAutoCommitTransaction + | RDiscard Discard + | RPull Pull + | RBegin Begin + | RCommit + | RRollback + | RRoute Route + | RLogon Logon + | RLogoff + | RTelemetry TelemetryApi + deriving stock (Generic) + + +instance PackStream Request where + toPs (RHello hello) = structureSingleton 0x01 $ toPs hello + toPs (RGoodbye) = PsStructure 0x02 V.empty + toPs (RReset) = PsStructure 0x0F V.empty + toPs (RRunExplicitTransaction x) = runExplicitTransactionToPs x + toPs (RRunAutoCommitTransaction x) = runAutoCommitTransactiontoPs x + toPs (RDiscard discard) = structureSingleton 0x2F $ toPs discard + toPs (RPull pull) = structureSingleton 0x3F $ toPs pull + toPs (RBegin begin) = structureSingleton 0x11 $ toPs begin + toPs (RCommit) = PsStructure 0x12 V.empty + toPs (RRollback) = PsStructure 0x13 V.empty + toPs (RRoute route) = routeToPs route + toPs (RLogon logon) = structureSingleton 0x6A $ logonToPs logon + toPs (RLogoff) = PsStructure 0x6B V.empty + toPs (RTelemetry api) = PsStructure 0x54 $ V.singleton $ PsInteger $ toPSInteger $ telemetryApiToInt api + fromPs (PsStructure 0x01 fields) = fromOneField fields RHello "expected exactly one field for Hello" + fromPs (PsStructure 0x02 fields) = if V.null fields then Success RGoodbye else Error "additional data on RGoodbye request is not allowed" + fromPs (PsStructure 0x0F fields) = if V.null fields then Success RReset else Error "additional data on RReset request is not allowed" + fromPs (PsStructure 0x10 fields) = fromPsToRunRequest fields + fromPs (PsStructure 0x2F fields) = fromOneField fields RDiscard "expected exactly one field for Discard" + fromPs (PsStructure 0x3F fields) = fromOneField fields RPull "expected exactly one field for Pull" + fromPs (PsStructure 0x11 fields) = fromOneField fields RBegin "expected exactly one field for Begin" + fromPs (PsStructure 0x12 fields) = if V.null fields then Success RCommit else Error "additional data on RCommit request is not allowed" + fromPs (PsStructure 0x13 fields) = if V.null fields then Success RRollback else Error "additional data on RRollback request is not allowed" + fromPs (PsStructure 0x66 fields) = fromPsToRoute fields + fromPs (PsStructure 0x6A fields) = fromOneField fields RLogon "expected exactly one field for Logon" + fromPs (PsStructure 0x6B fields) = if V.null fields then Success RLogoff else Error "additional data on RLogoff request is not allowed" + fromPs (PsStructure 0x54 fields) = fromPsToTelemetry fields + fromPs _ = Error "Could not decode Request" + + +fromPsToRunRequest :: V.Vector Ps -> Result Request +fromPsToRunRequest fields = + if V.length fields /= 1 then + Error "expected exactly one field for Run" + else do + arg <- fromPs $ V.unsafeHead fields + f arg + where f :: H.HashMap T.Text Ps -> Result Request + f map = if any (\f -> H.member f map) ["bookmarks", "tx_timeout", "tx_metadata", "mode", "db", "imp_user"] then do + query :: T.Text <- lookupWithError "query" map "\"query\" not found in Run Request" + parameters :: H.HashMap T.Text Ps <- lookupWithError "parameters" map "\"parameters\" not found in Run Request" + extra :: RunExtra <- lookupWithError "extra" map "\"extra\" not found in Run Request" + bookmarks :: V.Vector T.Text <- lookupWithError "bookmarks" map "\"bookmarks\" not found in Run Request" + tx_timeout :: Maybe Int64 <- lookupMaybe "tx_timeout" map + tx_metadata :: H.HashMap T.Text Ps <- lookupWithError "tx_metadata" map "\"tx_metadata\" not found in Run Request" + mode :: Char <- fromPsMode map + db :: Maybe T.Text <- lookupMaybe "db" map + imp_user :: Maybe T.Text <- lookupMaybe "imp_user" map + pure $ RRunAutoCommitTransaction RunAutoCommitTransaction{query, parameters, extra, bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} + else do + query :: T.Text <- lookupWithError "query" map "\"query\" not found in Run Request" + parameters :: H.HashMap T.Text Ps <- lookupWithError "parameters" map "\"parameters\" not found in Run Request" + extra :: RunExtra <- lookupWithError "extra" map "\"extra\" not found in Run Request" + pure $ RRunExplicitTransaction RunExplicitTransaction{query, parameters, extra} + + + +-- | HELLO message payload for initial handshake authentication. +type Hello :: Type +data Hello = Hello + { user_agent :: UserAgent + , scheme :: Scheme + , routing :: Routing + , patchBolt :: Bool + -- ^ When True, include @"patch_bolt": ["utc"]@ in HELLO (BOLT 4.3\/4.4 only). + } + deriving stock (Generic) + +instance PackStream Hello where + toPs = helloToPs + fromPs = helloFromPs + + +-- | RUN message payload within an explicit transaction. +type RunExplicitTransaction :: Type +data RunExplicitTransaction = RunExplicitTransaction + { query :: !T.Text + , parameters :: !(H.HashMap T.Text Ps) + , extra :: RunExtra + } + deriving stock (Generic) + +runExplicitTransactionToPs :: RunExplicitTransaction -> Ps +runExplicitTransactionToPs RunExplicitTransaction{query, parameters, extra} = + PsStructure 0x10 $ V.fromList + [ toPs query + , toPs parameters + , toPs extra + ] + +-- | Default 'RunAutoCommitTransaction' with empty query, parameters, and bookmarks. +defaultRunAutoCommitTransaction :: RunAutoCommitTransaction +defaultRunAutoCommitTransaction = RunAutoCommitTransaction + { query = "" + , parameters = H.empty + , extra = defaultRunExtra + , bookmarks = V.empty + , tx_timeout = Nothing + , tx_metadata = H.empty + , mode = 'w' + , db = Nothing + , imp_user = Nothing + } + +-- | Build a 'RunAutoCommitTransaction' with the given query and parameters. +mkRunAutoCommit :: T.Text -> H.HashMap T.Text Ps -> RunAutoCommitTransaction +mkRunAutoCommit q p = RunAutoCommitTransaction + { query = q + , parameters = p + , extra = defaultRunExtra + , bookmarks = V.empty + , tx_timeout = Nothing + , tx_metadata = H.empty + , mode = 'w' + , db = Nothing + , imp_user = Nothing + } + +-- | RUN message payload for an auto-commit transaction. +type RunAutoCommitTransaction :: Type +data RunAutoCommitTransaction = RunAutoCommitTransaction + { query :: !T.Text + , parameters :: !(H.HashMap T.Text Ps) + , extra :: RunExtra + , bookmarks :: V.Vector T.Text + , tx_timeout :: !(Maybe Int64) + , tx_metadata :: !(H.HashMap T.Text Ps) + , mode :: !Char + , db :: !(Maybe T.Text) + , imp_user :: !(Maybe T.Text) + } + deriving stock (Generic) + +runAutoCommitTransactiontoPs :: RunAutoCommitTransaction -> Ps +runAutoCommitTransactiontoPs RunAutoCommitTransaction{query, parameters, bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} = + PsStructure 0x10 $ V.fromList + [ toPs query + , toPs parameters + , PsDictionary $ H.fromList $ + let tx_timeout_list = case tx_timeout of + Nothing -> [] + Just t -> [("tx_timeout", toPs t)] + imp_user_list = case imp_user of + Nothing -> [] + Just i -> [("imp_user", toPs i)] + in [ ("bookmarks", toPs bookmarks) + , ("tx_metadata", toPs tx_metadata) + , ("mode", toPs $ T.singleton mode) + , ("db", toPs db) + ] <> tx_timeout_list <> imp_user_list + ] + + + +-- | DISCARD message payload with record count and query ID. +type Discard :: Type +data Discard = Discard + { n :: Int64 + , qid :: Int64 + } + deriving stock (Generic) +instance PackStream Discard where + toPs Discard{n, qid} = PsDictionary $ H.fromList + [("n", toPs n), ("qid", toPs qid)] + fromPs = withDictionary "Discard" $ \m -> do + n' <- lookupWithError "n" m "\"n\" not found in Discard" + qid' <- lookupWithError "qid" m "\"qid\" not found in Discard" + pure $ Discard{n = n', qid = qid'} + +-- | BEGIN message payload for starting an explicit transaction. +type Begin :: Type +data Begin = Begin + { bookmarks :: !(V.Vector T.Text) + , tx_timeout :: !(Maybe Int64) + , tx_metadata :: !(H.HashMap T.Text Ps) + , mode :: !Char + , db :: !(Maybe T.Text) + , imp_user :: !(Maybe T.Text) + } + deriving stock (Generic) +instance PackStream Begin where + toPs Begin{bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} = PsDictionary $ H.fromList + [ ("bookmarks", toPs bookmarks) + , ("tx_timeout", toPs tx_timeout) + , ("tx_metadata", toPs tx_metadata) + , ("mode", toPs $ T.singleton mode) + , ("db", toPs db) + , ("imp_user", toPs imp_user) + ] + toBinary run_extra = putPs $ toPs run_extra + fromPs = withDictionary "Begin" f + where f map = do + bookmarks :: V.Vector T.Text <- lookupWithError "bookmarks" map "\"bookmarks\" not found in Begin" + tx_timeout :: Maybe Int64 <- lookupMaybe "tx_timeout" map + tx_metadata :: H.HashMap T.Text Ps <- lookupWithError "tx_metadata" map "\"tx_metadata\" not found in Begin" + mode :: Char <- fromPsMode map + db :: (Maybe T.Text) <- lookupMaybe "db" map + imp_user :: Maybe T.Text <- lookupMaybe "imp_user" map + pure $ Begin{bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} + + + +-- | ROUTE message payload for fetching routing tables. +type Route :: Type +data Route = Route + { routing :: !(H.HashMap T.Text Ps) -- Only "address" specified + , bookmarks :: !(V.Vector T.Text) + , extra :: RouteExtra + } + +routeToPs :: Route -> Ps +routeToPs Route{routing, bookmarks, extra} = + PsStructure 0x66 $ V.fromList + [ toPs routing + , toPs bookmarks + , toPs extra + ] + +fromPsToRoute :: V.Vector Ps -> Result Request +fromPsToRoute fields + | V.length fields /= 3 = Error "expected exactly 3 fields for Route" + | otherwise = do + routing <- fromPs (fields V.! 0) + bookmarks <- fromPs (fields V.! 1) + extra <- fromPs (fields V.! 2) + Success $ RRoute Route{routing, bookmarks, extra} + +-- | Default 'Pull' requesting all records (@n = -1@) with no explicit query ID. +defaultPull :: Pull +defaultPull = Pull{n = -1, qid = Nothing} + +-- | PULL message payload with record count and optional query ID. +type Pull :: Type +data Pull = Pull + { n :: Int64 + , qid :: Maybe Int64 + } + deriving stock (Generic) +instance PackStream Pull where + toPs Pull{n, qid} = PsDictionary $ H.fromList $ + [("n", toPs n)] <> + case qid of + Nothing -> [] + Just q -> [("qid", toPs q)] + fromPs = withDictionary "Pull" $ \m -> do + n' <- lookupWithError "n" m "\"n\" not found in Pull" + qid' <- lookupMaybe "qid" m + pure $ Pull{n = n', qid = qid'} + +-- | Extra parameters for the ROUTE message (database and impersonated user). +type RouteExtra :: Type +data RouteExtra = RouteExtra + { db :: !(Maybe T.Text) + , imp_user :: !(Maybe T.Text) + } +instance PackStream RouteExtra where + toPs RouteExtra{db, imp_user} = PsDictionary $ H.fromList $ + maybe [] (\d -> [("db", toPs d)]) db <> + maybe [] (\i -> [("imp_user", toPs i)]) imp_user + toBinary route_extra = putPs $ toPs route_extra + fromPs = withDictionary "RouteExtra" f + where f map = do + db :: Maybe T.Text <- lookupMaybe "db" map + imp_user :: Maybe T.Text <- lookupMaybe "imp_user" map + pure $ RouteExtra{db, imp_user} + + +-- | Extra parameters for the RUN message (bookmarks, timeout, metadata, mode, db, impersonation). +type RunExtra :: Type +data RunExtra = RunExtra + { bookmarks :: !(V.Vector T.Text) + , tx_timeout :: !(Maybe Int64) + , tx_metadata :: !(H.HashMap T.Text Ps) + , mode :: !Char + , db :: !(Maybe T.Text) + , imp_user :: !(Maybe T.Text) + } + +-- | Default 'RunExtra' with empty bookmarks, no timeout, write mode, and no database. +defaultRunExtra :: RunExtra +defaultRunExtra = RunExtra + { bookmarks = V.empty + , tx_timeout = Nothing + , tx_metadata = H.empty + , mode = 'w' + , db = Nothing + , imp_user = Nothing + } + +instance PackStream RunExtra where + toPs RunExtra{bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} = PsDictionary $ H.fromList + [ ("bookmarks", toPs bookmarks) + , ("tx_timeout", toPs tx_timeout) + , ("tx_metadata", toPs tx_metadata) + , ("mode", toPs $ T.singleton mode) + , ("db", toPs db) + , ("imp_user", toPs imp_user) + ] + toBinary run_extra = putPs $ toPs run_extra + fromPs = withDictionary "RunExtra" f + where f map = do + bookmarks :: V.Vector T.Text <- lookupWithError "bookmarks" map "\"bookmarks\" not found in RunExtra" + tx_timeout :: Maybe Int64 <- lookupMaybe "tx_timeout" map + tx_metadata :: H.HashMap T.Text Ps <- lookupWithError "tx_metadata" map "\"tx_metadata\" not found in RunExtra" + mode :: Char <- fromPsMode map + db :: Maybe T.Text <- lookupMaybe "db" map + imp_user :: Maybe T.Text <- lookupMaybe "imp_user" map + pure $ RunExtra{bookmarks, tx_timeout, tx_metadata, mode, db, imp_user} + + +fromPsMode :: HashMap T.Text Ps -> Result Char +fromPsMode map = do + mode :: T.Text <- lookupWithError "mode" map "\"mode\" not found in RunExtra" + if T.length mode == 1 then + Success $ T.head mode + else + Error "\"mode\" in RunExtra should be a single character of either 'r' or 'w'" + + +helloToPs :: Hello -> Ps +helloToPs Hello{user_agent, scheme, routing, patchBolt} = + PsDictionary $ H.fromList $ + [ ("user_agent", toPs user_agent) + , ("scheme" , toPs scheme') + ] <> + ( case scheme of + None -> [] + Basic principal credentials -> [("principal", toPs principal), ("credentials", toPs credentials)] + Kerberos -> [] + Bearer credentials -> [("credentials", toPs credentials)] + ) <> + ( case routing of + NoRouting -> [] + Routing -> [("routing", PsDictionary H.empty)] + RoutingSpec address urlQueryParams -> [("routing", PsDictionary $ H.fromList $ + ("address", toPs address) : [(k, toPs v) | (k, v) <- H.toList urlQueryParams])] + ) <> + ( if patchBolt then [("patch_bolt", PsList $ V.singleton $ PsString "utc")] else [] ) + where + scheme' :: T.Text + scheme' = case scheme of + None -> "none" + Basic _ _ -> "basic" + Kerberos -> "kerberos" + Bearer _ -> "bearer" + +helloFromPs :: Ps -> Result Hello +helloFromPs = withDictionary "Request:Hello" f + where f :: H.HashMap T.Text Ps -> Result Hello + f map = do + user_agent :: UserAgent <- lookupWithError "user_agent" map "\"user_agent\" not found in hello request" + scheme :: T.Text <- lookupWithError "scheme" map "\"scheme\" not found in hello request" + routing <- case H.lookup "routing" map of + Nothing -> Success NoRouting + Just (PsDictionary m) + | H.null m -> Success Routing + | otherwise -> case H.lookup "address" m of + Just addr -> do + a <- fromPs addr + let params = H.delete "address" m + ps <- traverse fromPs params + Success $ RoutingSpec a ps + Nothing -> Error "\"routing\" dictionary missing \"address\" key" + Just _ -> Error "\"routing\" field should be a dictionary" + let credentials = H.lookup "credentials" map + let principal = H.lookup "principal" map + let pb = case H.lookup "patch_bolt" map of + Just (PsList v) -> V.elem (PsString "utc") v + _ -> False + case scheme of + "none" -> pure $ Hello {user_agent, scheme = None, routing, patchBolt = pb} + "basic" -> case (principal, credentials) of + (Just p, Just c) -> do + p2 <- fromPs p + c2 <- fromPs c + pure $ Hello {user_agent, scheme = Basic p2 c2, routing, patchBolt = pb} + _ -> Error "\"principal\" and \"credentials\" required for scheme \"basic\"" + "kerberos" -> pure $ Hello {user_agent, scheme = Kerberos, routing, patchBolt = pb} + "bearer" -> case credentials of + Just c -> do + c2 <- fromPs c + pure $ Hello {user_agent, scheme = Bearer c2, routing, patchBolt = pb} + Nothing -> Error "\"credentials\" required for scheme \"bearer\"" + _ -> Error $ "unknown scheme: " <> scheme + + +-- | LOGON message carries authentication credentials (Bolt 5.1+). +-- In 5.1+ HELLO no longer carries credentials; auth moves to LOGON. +type Logon :: Type +data Logon = Logon + { scheme :: Scheme + } + deriving stock (Generic) + +instance PackStream Logon where + toPs = logonToPs + fromPs = logonFromPs + +logonToPs :: Logon -> Ps +logonToPs Logon{scheme} = + PsDictionary $ H.fromList $ + [ ("scheme", toPs scheme') + ] <> + ( case scheme of + None -> [] + Basic principal credentials -> [("principal", toPs principal), ("credentials", toPs credentials)] + Kerberos -> [] + Bearer credentials -> [("credentials", toPs credentials)] + ) + where + scheme' :: T.Text + scheme' = case scheme of + None -> "none" + Basic _ _ -> "basic" + Kerberos -> "kerberos" + Bearer _ -> "bearer" + +logonFromPs :: Ps -> Result Logon +logonFromPs = withDictionary "Request:Logon" f + where f :: H.HashMap T.Text Ps -> Result Logon + f map = do + schemeTxt :: T.Text <- lookupWithError "scheme" map "\"scheme\" not found in logon request" + let credentials = H.lookup "credentials" map + let principal = H.lookup "principal" map + case schemeTxt of + "none" -> pure $ Logon{scheme = None} + "basic" -> case (principal, credentials) of + (Just p, Just c) -> do + p2 <- fromPs p + c2 <- fromPs c + pure $ Logon{scheme = Basic p2 c2} + _ -> Error "\"principal\" and \"credentials\" required for scheme \"basic\"" + "kerberos" -> pure $ Logon{scheme = Kerberos} + "bearer" -> case credentials of + Just c -> do + c2 <- fromPs c + pure $ Logon{scheme = Bearer c2} + Nothing -> Error "\"credentials\" required for scheme \"bearer\"" + _ -> Error $ "unknown scheme: " <> schemeTxt + + +-- | Telemetry API type indicators (Bolt 5.4+). +type TelemetryApi :: Type +data TelemetryApi + = ManagedTransactions + | ExplicitTransactions + | ImplicitTransactions + | ExecuteQuery + deriving stock (Show, Eq) + +telemetryApiToInt :: TelemetryApi -> Int64 +telemetryApiToInt ManagedTransactions = 0 +telemetryApiToInt ExplicitTransactions = 1 +telemetryApiToInt ImplicitTransactions = 2 +telemetryApiToInt ExecuteQuery = 3 + +telemetryApiFromInt :: Int64 -> Result TelemetryApi +telemetryApiFromInt 0 = Success ManagedTransactions +telemetryApiFromInt 1 = Success ExplicitTransactions +telemetryApiFromInt 2 = Success ImplicitTransactions +telemetryApiFromInt 3 = Success ExecuteQuery +telemetryApiFromInt n = Error $ "unknown telemetry api value: " <> T.pack (show n) + +fromPsToTelemetry :: V.Vector Ps -> Result Request +fromPsToTelemetry fields + | V.length fields /= 1 = Error "expected exactly one field for Telemetry" + | otherwise = case V.unsafeHead fields of + PsInteger n -> case fromPSInteger n of + Just i -> fmap RTelemetry $ telemetryApiFromInt i + Nothing -> Error "telemetry api integer out of Int64 range" + _ -> Error "expected integer field for Telemetry" diff --git a/src/Database/Bolty/Message/Response.hs b/src/Database/Bolty/Message/Response.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Message/Response.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE ApplicativeDo #-} + +-- | Internal module. Not part of the public API. +module Database.Bolty.Message.Response + ( Response(..) + , Failure(..) + , SuccessHello(..) + , SuccessRun(..), successFields, successTFirst + , SuccessRunAutoCommitTransaction(..) + , SuccessRunExplicitTransaction(..) + , makeResponseRunAutoCommitTransaction + , SuccessDiscard(..), SuccessDiscardLast(..) + , SuccessPull(..), QueryMeta(..) + , makeSuccessPull, mapToSuccessPull + , SuccessCommit(..) + , RoutingTable(..) + , parseRoutingTable + , extractBookmark + ) where + +import Data.Kind (Type) +import Data.Int (Int64) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V + +import qualified Data.PackStream as PS +import Data.PackStream.Ps as PS +import Data.PackStream.Integer (fromPSInteger) +import Database.Bolty.Notification (Notification, parseNotifications) +import Database.Bolty.Plan (PlanNode, ProfileNode, parsePlan, parseProfile) +import Database.Bolty.Stats (QueryStats, parseStats) +import Database.Bolty.Record (Record) + +-- | A BOLT server response message. +-- +-- the server always responds with one summary message if the connection is still open +-- the server always responds with zero or more detail messages before sending a summary message +type Response :: Type +data Response + = RSuccess !(H.HashMap T.Text Ps) + -- ^ https://neo4j.com/docs/bolt/current/bolt/message/#messages-success + | RIgnored + -- ^ https://neo4j.com/docs/bolt/current/bolt/message/#messages-ignored + | RFailure Failure + -- ^ https://neo4j.com/docs/bolt/current/bolt/message/#messages-failure + | RRecord !Record + -- ^ https://neo4j.com/docs/bolt/current/bolt/message/#messages-record +instance PS.PackStream Response where + toPs (RSuccess success) = structureSingleton 0x70 $ toPs success + toPs (RIgnored) = PsStructure 0x7E V.empty + toPs (RFailure failure) = structureSingleton 0x7F $ toPs failure + toPs (RRecord records) = structureSingleton 0x71 $ toPs records + fromPs (PsStructure 0x70 fields) = PS.fromOneField fields RSuccess "expected exactly one field for Success" + fromPs (PsStructure 0x7E fields) = if V.null fields then PS.Success RIgnored else PS.Error "additional data on Ignored request is not allowed" + fromPs (PsStructure 0x7F fields) = PS.fromOneField fields RFailure "expected exactly one field for Failure" + fromPs (PsStructure 0x71 fields) = PS.fromOneField fields RRecord "expected exactly one field for Record" + fromPs _ = PS.Error "Could not decode Response" + + + +-- | Parse a RUN SUCCESS response for an auto-commit transaction. +makeResponseRunAutoCommitTransaction :: H.HashMap T.Text Ps -> Either T.Text SuccessRun +makeResponseRunAutoCommitTransaction map = do + fields <- PS.lookupMaybeError "fields" map + t_first <- PS.lookupMaybeError "t_first" map + pure $ AutoCommitTransaction $ SuccessRunAutoCommitTransaction fields t_first + + + +-- | Build a 'SuccessPull' from collected records and PULL SUCCESS metadata (Either version). +makeSuccessPull :: V.Vector Record -> H.HashMap T.Text Ps -> Either T.Text SuccessPull +makeSuccessPull records map = do + let bookmark = case PS.lookupMaybeError "bookmark" map of + Right b -> Just b + Left _ -> Nothing + t_last <- PS.lookupMaybeError "t_last" map + type_ <- PS.lookupMaybeError "type" map + db <- PS.lookupMaybeError "db" map + let stats = H.lookup "stats" map + let parsedStats = parseStats stats + let plan = H.lookup "plan" map + let profile = H.lookup "profile" map + let notifications = H.lookup "notifications" map + let parsedNotifications = parseNotifications notifications + let parsedPlan = parsePlan plan + let parsedProfile = parseProfile profile + let infos = QueryMeta{bookmark, t_last, type_, stats, parsedStats, plan, profile, notifications, parsedNotifications, parsedPlan, parsedProfile, db} + pure $ SuccessPull{records, infos} + + + + + +-- | A server-reported failure with a Neo4j error code and human-readable message. +type Failure :: Type +data Failure = Failure + { code :: !T.Text + , message :: !T.Text + } +instance PS.PackStream Failure where + toPs (Failure code message) = PsDictionary $ H.fromList [("code", toPs code), ("message", toPs message)] + fromPs (PsDictionary map) = do + code <- PS.lookupWithError "code" map "expected \"code\" in Failure response" + message <- PS.lookupWithError "message" map "expected \"message\" in Failure response" + PS.Success $ Failure code message + fromPs _ = PS.Error "expected dictionary for Failure" + + + + +-- | Parsed HELLO SUCCESS metadata. +type SuccessHello :: Type +data SuccessHello = SuccessHello + { server :: !T.Text + -- ^ server agent string, example "Neo4j/4.1.0" + , connection_id :: !T.Text + -- ^ unique identifier of the bolt connection used on the server side, example: "bolt-61" + , hints :: !(H.HashMap T.Text Ps) + -- ^ set of optional configuration hints to be considered by the driver + } + +-- | Parsed RUN SUCCESS metadata, either auto-commit or explicit transaction. +type SuccessRun :: Type +data SuccessRun + = AutoCommitTransaction SuccessRunAutoCommitTransaction + | ExplicitTransaction SuccessRunExplicitTransaction + +-- | Extract the result field names from a 'SuccessRun'. +successFields :: SuccessRun -> V.Vector T.Text +successFields (AutoCommitTransaction (SuccessRunAutoCommitTransaction fields _)) = fields +successFields (ExplicitTransaction (SuccessRunExplicitTransaction fields _ _)) = fields + +-- | Extract the @t_first@ timing value from a 'SuccessRun'. +successTFirst :: SuccessRun -> Int64 +successTFirst (AutoCommitTransaction (SuccessRunAutoCommitTransaction _ tf)) = tf +successTFirst (ExplicitTransaction (SuccessRunExplicitTransaction _ tf _)) = tf + +-- | RUN SUCCESS metadata for an auto-commit transaction. +type SuccessRunAutoCommitTransaction :: Type +data SuccessRunAutoCommitTransaction = SuccessRunAutoCommitTransaction + { fields :: !(V.Vector T.Text) + -- ^ the fields of the return result. e.g. [“name”, “age”, …] + , t_first :: !Int64 + -- ^ the time, specified in ms, which the first record in the result stream is available after + } + +-- | RUN SUCCESS metadata for an explicit transaction. +type SuccessRunExplicitTransaction :: Type +data SuccessRunExplicitTransaction = SuccessRunExplicitTransaction + { fields :: !(V.Vector T.Text) + -- ^ the fields of the return result. e.g. [“name”, “age”, …] + , t_first :: !Int64 + -- ^ the time, specified in ms, which the first record in the result stream is available after + , qid :: !Int64 + -- ^ specifies the server assigned statement ID to reference the server side result-set with commencing BEGIN+RUN+PULL and BEGIN+RUN+DISCARD messages. + } + +-- | Parsed DISCARD SUCCESS response. +type SuccessDiscard :: Type +data SuccessDiscard + = DiscardMore + | DiscardLast SuccessDiscardLast + +-- | Final DISCARD SUCCESS metadata with bookmark and database. +type SuccessDiscardLast :: Type +data SuccessDiscardLast = SuccessDiscardLast + { bookmark :: !T.Text + -- ^ the bookmark after committing this transaction (Auto-commit Transaction only) + , db :: !T.Text + -- ^ the database name where the query is executed. + } + +-- | Build a 'SuccessPull' from collected records and PULL SUCCESS metadata (Result version). +mapToSuccessPull :: V.Vector Record -> H.HashMap T.Text Ps -> PS.Result SuccessPull +mapToSuccessPull records map = do + bookmark :: Maybe T.Text <- PS.lookupMaybe "bookmark" map + t_last :: Int64 <- PS.lookupWithError "t_last" map "could not find \"t_last\" in Pull response" + type_ :: T.Text <- PS.lookupWithError "type" map "could not find \"type\" in Pull response" + db :: T.Text <- PS.lookupWithError "db" map "could not find \"db\" in Pull response" + let stats = H.lookup "stats" map + let parsedStats = parseStats stats + let plan = H.lookup "plan" map + let profile = H.lookup "profile" map + let notifications = H.lookup "notifications" map + let parsedNotifications = parseNotifications notifications + let parsedPlan = parsePlan plan + let parsedProfile = parseProfile profile + let infos = QueryMeta{bookmark, t_last, type_, stats, parsedStats, plan, profile, notifications, parsedNotifications, parsedPlan, parsedProfile, db} + pure $ SuccessPull{records, infos} + + + + +-- | Full query result: records plus server metadata. +type SuccessPull :: Type +data SuccessPull = SuccessPull + { records :: !(V.Vector Record) + , infos :: !QueryMeta + } + +-- | Server metadata from a PULL SUCCESS response. +type QueryMeta :: Type +data QueryMeta = QueryMeta + { bookmark :: !(Maybe T.Text) + -- ^ the bookmark after committing this transaction (Autocommit Transaction only, absent in explicit transactions). + , t_last :: !Int64 + -- ^ the time, specified in ms, which the last record in the result stream is consumed after. + , type_ :: !T.Text + -- ^ the type of the statement, e.g. "r" for read-only statement, "w" for write-only statement, "rw" for read-and-write, and "s" for schema only. + , stats :: !(Maybe Ps) + -- ^ counter information, such as db-hits etc. May be omitted. + , parsedStats :: !(Maybe QueryStats) + -- ^ parsed stats from the raw field above. + , plan :: !(Maybe Ps) + -- ^ plan result. May be omitted. + , profile :: !(Maybe Ps) + -- ^ profile result. May be omitted. + , notifications :: !(Maybe Ps) + -- ^ a list of all notifications generated during execution of this statement. May be omitted. + , parsedNotifications :: !(V.Vector Notification) + -- ^ parsed notifications from the raw field above. + , parsedPlan :: !(Maybe PlanNode) + -- ^ parsed plan tree from the raw @plan@ field above. + , parsedProfile :: !(Maybe ProfileNode) + -- ^ parsed profile tree from the raw @profile@ field above. + , db :: !T.Text + -- ^ the database name where the query was executed (v4.0+). + } + +-- | Parsed COMMIT SUCCESS metadata. +type SuccessCommit :: Type +data SuccessCommit = SuccessCommit + { bookmark :: !T.Text + -- ^ the bookmark after committing this transaction. + } + + +-- | A parsed routing table returned by the ROUTE message. +type RoutingTable :: Type +data RoutingTable = RoutingTable + { ttl :: !Int64 + -- ^ Seconds to cache this routing table. + , db :: !T.Text + -- ^ Database name this routing table is for. + , routers :: !(V.Vector T.Text) + -- ^ "host:port" addresses for ROUTE role. + , readers :: !(V.Vector T.Text) + -- ^ "host:port" addresses for READ role. + , writers :: !(V.Vector T.Text) + -- ^ "host:port" addresses for WRITE role. + } + deriving stock (Show, Eq) + + +-- | Parse a routing table from the SUCCESS response metadata of a ROUTE message. +-- The expected wire format is: +-- @{"rt": {"ttl": N, "db": "name", "servers": [{"addresses": [...], "role": "WRITE"}, ...]}}@ +parseRoutingTable :: H.HashMap T.Text Ps -> Either T.Text RoutingTable +parseRoutingTable meta = do + rtPs <- case H.lookup "rt" meta of + Just (PsDictionary m) -> Right m + Just _ -> Left "\"rt\" field should be a dictionary" + Nothing -> Left "\"rt\" key not found in ROUTE response" + ttl <- case H.lookup "ttl" rtPs of + Just (PsInteger n) -> case fromPSInteger n of + Just i -> Right i + Nothing -> Left "\"ttl\" integer out of Int64 range" + Just _ -> Left "\"ttl\" should be an integer" + Nothing -> Left "\"ttl\" not found in routing table" + db <- case H.lookup "db" rtPs of + Just (PsString s) -> Right s + Just _ -> Left "\"db\" should be a string" + Nothing -> Left "\"db\" not found in routing table" + serversPs <- case H.lookup "servers" rtPs of + Just (PsList v) -> Right v + Just _ -> Left "\"servers\" should be a list" + Nothing -> Left "\"servers\" not found in routing table" + let (routers, readers, writers) = V.foldl' classifyServer (V.empty, V.empty, V.empty) serversPs + Right RoutingTable{ttl, db, routers, readers, writers} + + +-- | Classify a single server entry from the routing table by its role. +classifyServer :: (V.Vector T.Text, V.Vector T.Text, V.Vector T.Text) + -> Ps + -> (V.Vector T.Text, V.Vector T.Text, V.Vector T.Text) +classifyServer (rout, rd, wr) (PsDictionary m) = + case (H.lookup "role" m, H.lookup "addresses" m) of + (Just (PsString role), Just (PsList addrs)) -> + let addrTexts = V.mapMaybe extractText addrs + in case role of + "ROUTE" -> (rout <> addrTexts, rd, wr) + "READ" -> (rout, rd <> addrTexts, wr) + "WRITE" -> (rout, rd, wr <> addrTexts) + _ -> (rout, rd, wr) + _ -> (rout, rd, wr) +classifyServer acc _ = acc + + +extractText :: Ps -> Maybe T.Text +extractText (PsString t) = Just t +extractText _ = Nothing + + +-- | Extract the bookmark from a SUCCESS response metadata (e.g. from COMMIT). +-- Returns 'Nothing' if the @bookmark@ key is absent or not a text value. +extractBookmark :: H.HashMap T.Text Ps -> Maybe T.Text +extractBookmark meta = case H.lookup "bookmark" meta of + Just (PsString t) -> Just t + _ -> Nothing diff --git a/src/Database/Bolty/Notification.hs b/src/Database/Bolty/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Notification.hs @@ -0,0 +1,113 @@ +-- | Server notification types (warnings, deprecations, performance hints). +module Database.Bolty.Notification + ( Notification(..) + , Severity(..) + , Position(..) + , parseNotifications + ) where + +import Prelude + +import Data.Int (Int64) +import Data.Kind (Type) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V + +import Data.PackStream.Ps (Ps(..)) +import Data.PackStream.Integer (fromPSInteger) + + +-- | A notification emitted by the server during query execution. +-- Notifications include warnings about performance (cartesian products, +-- missing indexes), deprecation notices, and hints. +type Notification :: Type +data Notification = Notification + { nCode :: !T.Text + -- ^ e.g. @"Neo.ClientNotification.Statement.CartesianProduct"@ + , nTitle :: !T.Text + -- ^ Human-readable title. + , nDescription :: !T.Text + -- ^ Detailed description of the issue. + , nSeverity :: !Severity + -- ^ WARNING or INFORMATION. + , nCategory :: !T.Text + -- ^ e.g. @"PERFORMANCE"@, @"DEPRECATION"@, @"HINT"@, @"UNRECOGNIZED"@, @"UNSUPPORTED"@, @"GENERIC"@, @"SECURITY"@, @"TOPOLOGY"@, @"SCHEMA"@. + , nPosition :: !(Maybe Position) + -- ^ Position in the Cypher query, if available. + } + deriving stock (Show, Eq) + + +-- | Severity level of a notification. +type Severity :: Type +data Severity = SevWarning | SevInformation | SevUnknown !T.Text + deriving stock (Show, Eq) + + +-- | Position in a Cypher query string. +type Position :: Type +data Position = Position + { offset :: !Int64 + , line :: !Int64 + , col :: !Int64 + } + deriving stock (Show, Eq) + + +-- | Parse the raw @notifications@ field from PULL SUCCESS metadata. +-- Returns an empty vector if the field is 'Nothing' or not a list. +parseNotifications :: Maybe Ps -> V.Vector Notification +parseNotifications Nothing = V.empty +parseNotifications (Just (PsList items)) = V.mapMaybe parseOne items +parseNotifications (Just _) = V.empty + + +-- | Parse a single notification dictionary. +parseOne :: Ps -> Maybe Notification +parseOne (PsDictionary m) = do + code <- lookupText "code" m + title <- lookupText "title" m + desc <- lookupText "description" m + let severity = parseSeverity $ H.lookup "severity" m + let category = case lookupText "category" m of + Just c -> c + Nothing -> "" + let position = parsePosition $ H.lookup "position" m + Just Notification + { nCode = code + , nTitle = title + , nDescription = desc + , nSeverity = severity + , nCategory = category + , nPosition = position + } +parseOne _ = Nothing + + +lookupText :: T.Text -> H.HashMap T.Text Ps -> Maybe T.Text +lookupText key m = case H.lookup key m of + Just (PsString t) -> Just t + _ -> Nothing + + +parseSeverity :: Maybe Ps -> Severity +parseSeverity (Just (PsString "WARNING")) = SevWarning +parseSeverity (Just (PsString "INFORMATION")) = SevInformation +parseSeverity (Just (PsString other)) = SevUnknown other +parseSeverity _ = SevUnknown "" + + +parsePosition :: Maybe Ps -> Maybe Position +parsePosition (Just (PsDictionary m)) = do + off <- lookupInt64 "offset" m + ln <- lookupInt64 "line" m + c <- lookupInt64 "column" m + Just Position{offset = off, line = ln, col = c} +parsePosition _ = Nothing + + +lookupInt64 :: T.Text -> H.HashMap T.Text Ps -> Maybe Int64 +lookupInt64 key m = case H.lookup key m of + Just (PsInteger n) -> fromPSInteger n + _ -> Nothing diff --git a/src/Database/Bolty/Plan.hs b/src/Database/Bolty/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Plan.hs @@ -0,0 +1,154 @@ +-- | Typed plan and profile trees from EXPLAIN\/PROFILE queries. +module Database.Bolty.Plan + ( PlanNode(..) + , ProfileNode(..) + , parsePlan + , parseProfile + ) where + +import Prelude + +import Data.Int (Int64) +import Data.Kind (Type) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V + +import Data.PackStream.Ps (Ps(..)) +import Data.PackStream.Integer (fromPSInteger) + + +-- | A node in the query execution plan tree (from EXPLAIN). +type PlanNode :: Type +data PlanNode = PlanNode + { pnOperatorType :: !T.Text + , pnArguments :: !(H.HashMap T.Text Ps) + , pnIdentifiers :: !(V.Vector T.Text) + , pnEstimatedRows :: !Double + , pnChildren :: !(V.Vector PlanNode) + } deriving stock (Show, Eq) + + +-- | A node in the query profile tree (from PROFILE). +-- Extends 'PlanNode' with actual execution statistics. +type ProfileNode :: Type +data ProfileNode = ProfileNode + { prOperatorType :: !T.Text + , prArguments :: !(H.HashMap T.Text Ps) + , prIdentifiers :: !(V.Vector T.Text) + , prEstimatedRows :: !Double + , prDbHits :: !Int64 + , prRows :: !Int64 + , prPageCacheHits :: !Int64 + , prPageCacheMisses :: !Int64 + , prTime :: !Int64 -- ^ microseconds + , prChildren :: !(V.Vector ProfileNode) + } deriving stock (Show, Eq) + + +-- | Parse the raw @plan@ field from PULL SUCCESS metadata into a typed 'PlanNode' tree. +parsePlan :: Maybe Ps -> Maybe PlanNode +parsePlan Nothing = Nothing +parsePlan (Just (PsDictionary m)) = parsePlanDict m +parsePlan (Just _) = Nothing + + +-- | Parse the raw @profile@ field from PULL SUCCESS metadata into a typed 'ProfileNode' tree. +parseProfile :: Maybe Ps -> Maybe ProfileNode +parseProfile Nothing = Nothing +parseProfile (Just (PsDictionary m)) = parseProfileDict m +parseProfile (Just _) = Nothing + + +parsePlanDict :: H.HashMap T.Text Ps -> Maybe PlanNode +parsePlanDict m = do + opType <- lookupText "operatorType" m + let args = case H.lookup "args" m of + Just (PsDictionary a) -> a + _ -> H.empty + let idents = case H.lookup "identifiers" m of + Just (PsList v) -> V.mapMaybe extractText v + _ -> V.empty + let estRows = lookupDouble "estimatedRows" m + let children = case H.lookup "children" m of + Just (PsList v) -> V.mapMaybe parsePlanPs v + _ -> V.empty + Just PlanNode + { pnOperatorType = opType + , pnArguments = args + , pnIdentifiers = idents + , pnEstimatedRows = estRows + , pnChildren = children + } + + +parsePlanPs :: Ps -> Maybe PlanNode +parsePlanPs (PsDictionary m) = parsePlanDict m +parsePlanPs _ = Nothing + + +parseProfileDict :: H.HashMap T.Text Ps -> Maybe ProfileNode +parseProfileDict m = do + opType <- lookupText "operatorType" m + let args = case H.lookup "args" m of + Just (PsDictionary a) -> a + _ -> H.empty + let idents = case H.lookup "identifiers" m of + Just (PsList v) -> V.mapMaybe extractText v + _ -> V.empty + let estRows = lookupDouble "estimatedRows" m + let dbHits = lookupInt64OrZero "dbHits" m + let rows = lookupInt64OrZero "rows" m + let pcHits = lookupInt64OrZero "pageCacheHits" m + let pcMisses = lookupInt64OrZero "pageCacheMisses" m + let time = lookupInt64OrZero "time" m + let children = case H.lookup "children" m of + Just (PsList v) -> V.mapMaybe parseProfilePs v + _ -> V.empty + Just ProfileNode + { prOperatorType = opType + , prArguments = args + , prIdentifiers = idents + , prEstimatedRows = estRows + , prDbHits = dbHits + , prRows = rows + , prPageCacheHits = pcHits + , prPageCacheMisses = pcMisses + , prTime = time + , prChildren = children + } + + +parseProfilePs :: Ps -> Maybe ProfileNode +parseProfilePs (PsDictionary m) = parseProfileDict m +parseProfilePs _ = Nothing + + +-- Helpers + +lookupText :: T.Text -> H.HashMap T.Text Ps -> Maybe T.Text +lookupText key m = case H.lookup key m of + Just (PsString t) -> Just t + _ -> Nothing + + +extractText :: Ps -> Maybe T.Text +extractText (PsString t) = Just t +extractText _ = Nothing + + +lookupDouble :: T.Text -> H.HashMap T.Text Ps -> Double +lookupDouble key m = case H.lookup key m of + Just (PsFloat d) -> d + Just (PsInteger n) -> case fromPSInteger n of + Just (i :: Int64) -> fromIntegral i + Nothing -> 0.0 + _ -> 0.0 + + +lookupInt64OrZero :: T.Text -> H.HashMap T.Text Ps -> Int64 +lookupInt64OrZero key m = case H.lookup key m of + Just (PsInteger n) -> case fromPSInteger n of + Just i -> i + Nothing -> 0 + _ -> 0 diff --git a/src/Database/Bolty/Pool.hs b/src/Database/Bolty/Pool.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Pool.hs @@ -0,0 +1,219 @@ +-- | Connection pooling with health-check validation and retry configuration. +module Database.Bolty.Pool + ( BoltPool(..) + , PoolConfig(..) + , defaultPoolConfig + , ValidationStrategy(..) + , RetryConfig(..) + , defaultRetryConfig + , PoolCounters(..) + , createPool + , destroyPool + , withConnection + , poolCounters + ) where + +import Control.Exception (SomeException, mask, try, fromException, throwIO) +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef') +import Data.Pool (Pool) +import qualified Data.Pool as Pool +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Stack (HasCallStack) + +import Data.Kind (Type) +import Database.Bolty.Connection.Type (Connection, ValidatedConfig, Error(..)) +import qualified Database.Bolty.Connection.Pipe as P +import Database.Bolty.Connection.Pipe (touchConnection, connectionLastActivity, + connectionServerIdleTimeout) + + +-- | Configuration for retry logic on transient failures. +type RetryConfig :: Type +data RetryConfig = RetryConfig + { maxRetries :: !Int + -- ^ Maximum number of retry attempts. Default: 5. + , initialDelay :: !Int + -- ^ Initial delay in microseconds before first retry. Default: 200000 (200ms). + , maxDelay :: !Int + -- ^ Maximum delay in microseconds between retries. Default: 5000000 (5s). + } + deriving stock (Show, Eq) + +-- | Default retry configuration: 5 retries, 200ms initial delay, 5s max delay. +defaultRetryConfig :: RetryConfig +defaultRetryConfig = RetryConfig + { maxRetries = 5 + , initialDelay = 200_000 + , maxDelay = 5_000_000 + } + + +-- | Strategy for validating connections when they are checked out of the pool. +type ValidationStrategy :: Type +data ValidationStrategy + = AlwaysPing + -- ^ Always send RESET before use (current default, safest). + | PingIfIdle !Int + -- ^ Only ping if the connection has been idle for more than N seconds. + -- Connections used within the last N seconds are assumed healthy. + | NeverPing + -- ^ Skip health check entirely (fastest, use only in trusted environments). + deriving stock (Show, Eq) + +-- | Configuration for the connection pool. +type PoolConfig :: Type +data PoolConfig = PoolConfig + { maxConnections :: Int + -- ^ Maximum number of open connections. Default: 10. + , idleTimeout :: Double + -- ^ Seconds before an idle connection is closed. Default: 60. + , maxPingRetries :: Int + -- ^ Number of additional attempts after a ping failure. Default: 1. + -- Total attempts = 1 + maxPingRetries. + , retryConfig :: RetryConfig + -- ^ Retry configuration for transient failures. Default: 'defaultRetryConfig'. + , validationStrategy :: ValidationStrategy + -- ^ How to validate connections on checkout. Default: 'AlwaysPing'. + } + +-- | Default pool configuration: 10 max connections, 60 second idle timeout, 1 ping retry. +defaultPoolConfig :: PoolConfig +defaultPoolConfig = PoolConfig + { maxConnections = 10 + , idleTimeout = 60 + , maxPingRetries = 1 + , retryConfig = defaultRetryConfig + , validationStrategy = PingIfIdle 30 + } + + +-- | A pool of Neo4j connections with health-check and retry configuration. +type BoltPool :: Type +data BoltPool = BoltPool + { bpPool :: !(Pool Connection) + , bpMaxRetries :: !Int + , bpRetryConfig :: !RetryConfig + , bpValidation :: !ValidationStrategy + , bpActiveConns :: !(IORef Int) + , bpTotalAcqs :: !(IORef Int) + , bpTotalWaitNs :: !(IORef Word64) + } + + +-- | Snapshot of pool-level counters. +type PoolCounters :: Type +data PoolCounters = PoolCounters + { pcActive :: !Int + -- ^ Number of connections currently checked out. + , pcTotalAcqs :: !Int + -- ^ Lifetime count of connection acquisitions. + , pcTotalWaitNs :: !Word64 + -- ^ Cumulative nanoseconds spent waiting for connections. + } deriving stock (Show, Eq) + + +-- | Create a new connection pool. +-- If the server advertises @connection.recv_timeout_seconds@, the pool's +-- idle timeout is capped to @min(configured, hint - 5)@ so connections +-- are recycled before the server closes them. +createPool :: HasCallStack => ValidatedConfig -> PoolConfig -> IO BoltPool +createPool cfg PoolConfig{..} = do + -- Probe a connection to discover the server's idle timeout hint. + probe <- P.connect cfg + let effectiveIdle = case connectionServerIdleTimeout probe of + Just serverSecs | serverSecs > 5 -> + min idleTimeout (fromIntegral (serverSecs - 5)) + _ -> idleTimeout + P.close probe + let poolCfg = Pool.defaultPoolConfig + (P.connect cfg) -- create + P.close -- destroy + effectiveIdle -- idle timeout (seconds) + maxConnections -- max resources + pool <- Pool.newPool poolCfg + activeRef <- newIORef 0 + acqRef <- newIORef 0 + waitRef <- newIORef 0 + pure BoltPool { bpPool = pool, bpMaxRetries = maxPingRetries + , bpRetryConfig = retryConfig, bpValidation = validationStrategy + , bpActiveConns = activeRef, bpTotalAcqs = acqRef, bpTotalWaitNs = waitRef } + + +-- | Destroy the pool, closing all connections. +destroyPool :: BoltPool -> IO () +destroyPool BoltPool{bpPool} = Pool.destroyAllResources bpPool + + +-- | Acquire a healthy connection from the pool, run an action, then release it. +-- Validates the connection using the configured 'ValidationStrategy'. +-- On connection failure during the action, discards the dead connection and +-- retries once with a fresh one. +withConnection :: HasCallStack => BoltPool -> (Connection -> IO a) -> IO a +withConnection BoltPool{bpPool, bpMaxRetries, bpValidation, bpActiveConns, bpTotalAcqs, bpTotalWaitNs} action = + go (bpMaxRetries + 1) True + where + go 0 _ = fail "withConnection: no healthy connection available" + go n canRetryDead = mask $ \restore -> do + t0 <- getMonotonicTimeNSec + (conn, localPool) <- Pool.takeResource bpPool + t1 <- getMonotonicTimeNSec + atomicModifyIORef' bpActiveConns $ \x -> (x + 1, ()) + atomicModifyIORef' bpTotalAcqs $ \x -> (x + 1, ()) + atomicModifyIORef' bpTotalWaitNs $ \x -> (x + (t1 - t0), ()) + let decActive = atomicModifyIORef' bpActiveConns $ \x -> (x - 1, ()) + shouldPing <- needsPing bpValidation conn + healthy <- if shouldPing then P.ping conn else pure True + if healthy + then do + result <- try $ restore (action conn) + case result of + Right x -> do + touchConnection conn + Pool.putResource localPool conn + decActive + pure x + Left (e :: SomeException) + | canRetryDead, isConnectionError e -> do + Pool.destroyResource bpPool localPool conn + decActive + restore $ go n False -- retry with fresh connection, no more retries + | otherwise -> do + Pool.destroyResource bpPool localPool conn + decActive + restore $ throwIOSome e + else do + Pool.destroyResource bpPool localPool conn + decActive + restore $ go (n - 1) canRetryDead + + -- | Check if a connection needs a ping based on the validation strategy. + needsPing :: ValidationStrategy -> Connection -> IO Bool + needsPing AlwaysPing _ = pure True + needsPing NeverPing _ = pure False + needsPing (PingIfIdle secs) conn = do + now <- getMonotonicTimeNSec + lastAct <- connectionLastActivity conn + let idleNs = now - lastAct + let thresholdNs = fromIntegral secs * 1_000_000_000 + pure (idleNs >= thresholdNs) + + throwIOSome :: SomeException -> IO a + throwIOSome = throwIO' where + throwIO' :: SomeException -> IO a + throwIO' = Control.Exception.throwIO + + -- | Check if an exception is a connection-level error (not a query error). + isConnectionError :: SomeException -> Bool + isConnectionError e = case fromException e :: Maybe Error of + Just (NonboltyError _) -> True + _ -> False + + +-- | Read a snapshot of the pool's lifetime counters. +poolCounters :: BoltPool -> IO PoolCounters +poolCounters BoltPool{bpActiveConns, bpTotalAcqs, bpTotalWaitNs} = do + active <- readIORef bpActiveConns + acqs <- readIORef bpTotalAcqs + waitNs <- readIORef bpTotalWaitNs + pure PoolCounters{pcActive = active, pcTotalAcqs = acqs, pcTotalWaitNs = waitNs} diff --git a/src/Database/Bolty/Record.hs b/src/Database/Bolty/Record.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Record.hs @@ -0,0 +1,23 @@ +-- | Query result records. +module Database.Bolty.Record + ( Record + , lookupField + ) where + +import Data.Kind (Type) +import qualified Data.Text as T +import qualified Data.Vector as V + +import Database.Bolty.Value.Type (Bolt) + + +-- | A single result row: a vector of 'Bolt' values, one per column. +type Record :: Type +type Record = V.Vector Bolt + + +-- | Look up a field value by column name, given the column name vector +-- from the query's SuccessRun response. +lookupField :: V.Vector T.Text -> T.Text -> Record -> Maybe Bolt +lookupField columns name record = + V.elemIndex name columns >>= (record V.!?) diff --git a/src/Database/Bolty/ResultSet.hs b/src/Database/Bolty/ResultSet.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/ResultSet.hs @@ -0,0 +1,95 @@ +-- | Multi-pass decoding of denormalized query results. +-- +-- When a Cypher query uses @OPTIONAL MATCH@, the result set is denormalized: +-- parent fields are repeated for each matched child row. 'ResultSet' bundles +-- field names with records so you can decode the same rows with different +-- decoders in multiple passes. +-- +-- __Preferred alternative:__ Use Cypher @COLLECT()@ or pattern comprehensions +-- to aggregate children server-side, avoiding denormalization entirely: +-- +-- @ +-- MATCH (p:Parent) +-- OPTIONAL MATCH (p)-[:HAS]->(c:Child) +-- RETURN p, COLLECT(c) AS children +-- @ +-- +-- When that isn't practical (e.g. multiple independent optional paths), +-- use 'groupByField' as an escape hatch: +-- +-- @ +-- rs <- queryResult conn "MATCH (p:Parent) OPTIONAL MATCH (p)-[:HAS]->(c:Child) RETURN p.id AS pid, c" +-- groups <- either throwIO pure $ groupByField (field \"pid\" (nullable int64)) rs +-- -- groups :: Vector (Int64, ResultSet) +-- -- Each sub-ResultSet contains the rows for that parent. +-- @ +module Database.Bolty.ResultSet + ( ResultSet(..) + , decodeResultSet + , decodeHead + , groupByField + ) where + +import Data.Kind (Type) +import qualified Data.Text as T +import qualified Data.Vector as V + +import Database.Bolty.Decode (DecodeError(..), RowDecoder, decodeRow, decodeRows) +import Database.Bolty.Record (Record) + + +-- | A query result: field (column) names paired with the result records. +-- Supports multi-pass decoding — decode the same rows with different +-- 'RowDecoder's without re-running the query. +type ResultSet :: Type +data ResultSet = ResultSet + { fields :: !(V.Vector T.Text) + , records :: !(V.Vector Record) + } deriving stock (Show, Eq) + + +-- | Decode every record in a 'ResultSet' using a 'RowDecoder'. +-- Fails on the first 'DecodeError'. +decodeResultSet :: RowDecoder a -> ResultSet -> Either DecodeError (V.Vector a) +decodeResultSet decoder (ResultSet fs rs) = decodeRows decoder fs rs + + +-- | Decode the first record of a 'ResultSet', or fail with 'EmptyResultSet'. +decodeHead :: RowDecoder a -> ResultSet -> Either DecodeError a +decodeHead decoder (ResultSet fs rs) = case V.uncons rs of + Nothing -> Left EmptyResultSet + Just (rec, _) -> decodeRow decoder fs rec + + +-- | Group consecutive records by a decoded key field. +-- +-- Records whose key decodes to 'Nothing' (e.g. NULL from an @OPTIONAL MATCH@ +-- with no match) are skipped. Grouping is consecutive, not global: if the same +-- key appears in non-adjacent runs, they become separate groups. +-- +-- Each sub-'ResultSet' shares the parent's field names. +-- +-- __Prefer Cypher @COLLECT()@__ when possible — this function is an escape +-- hatch for queries where server-side aggregation is impractical. +groupByField + :: Eq k + => RowDecoder (Maybe k) + -> ResultSet + -> Either DecodeError (V.Vector (k, ResultSet)) +groupByField keyDecoder (ResultSet fs rs) = + buildGroups =<< V.foldM' accumulate [] rs + where + accumulate acc rec = do + mk <- decodeRow keyDecoder fs rec + pure $ case mk of + Nothing -> acc -- skip NULL keys + Just k -> case acc of + (curK, curRecs) : rest + | curK == k -> (curK, rec : curRecs) : rest + _ -> (k, [rec]) : acc + + buildGroups groups = + Right $ V.fromList + [ (k, ResultSet fs (V.fromList (reverse recs))) + | (k, recs) <- reverse groups + ] diff --git a/src/Database/Bolty/Routing.hs b/src/Database/Bolty/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Routing.hs @@ -0,0 +1,354 @@ +-- | Cluster-aware routing: automatic server discovery and failover for Neo4j causal clusters. +module Database.Bolty.Routing + ( -- * Routing table + getRoutingTable + , RoutingTable(..) + -- * Access mode + , AccessMode(..) + -- * Routing pool + , RoutingPool(..) + , RoutingPoolConfig(..) + , defaultRoutingPoolConfig + , createRoutingPool + , destroyRoutingPool + , withRoutingConnection + , withRoutingTransaction + , invalidateRoutingTable + -- * Internals (exported for testing) + , parseAddress + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Exception (SomeException, throwIO, try, fromException, + onException) +import Control.Monad (when) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as H +import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef') +import Data.Kind (Type) +import Data.Text (Text) +import Data.List (isInfixOf) +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Word (Word16, Word64) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Stack (HasCallStack) + +import Database.Bolty.Connection.Type +import qualified Database.Bolty.Connection.Pipe as P +import Database.Bolty.Message.Request (Request(..), Route(..), RouteExtra(..), Begin(..)) +import Database.Bolty.Message.Response (Response(..), Failure(..), RoutingTable(..), parseRoutingTable) +import Database.Bolty.Pool + + +-- | Access mode for routing: determines whether to use reader or writer servers. +type AccessMode :: Type +data AccessMode = ReadAccess | WriteAccess + deriving stock (Show, Eq) + + +-- | Fetch a routing table from the server. The connection must be in Ready state. +getRoutingTable :: HasCallStack => Connection -> Maybe Text -> IO RoutingTable +getRoutingTable conn dbName = do + P.requireStateIO conn [Ready] "ROUTE" + P.flushIO conn $ RRoute Route + { routing = H.empty + , bookmarks = V.empty + , extra = RouteExtra{db = dbName, imp_user = Nothing} + } + response <- P.fetchIO conn + case response of + RSuccess meta -> + case parseRoutingTable meta of + Right rt -> pure rt + Left err -> throwIO $ RoutingTableError err + RFailure Failure{code, message} -> do + P.setState conn Failed + P.reset conn + throwIO $ ResponseErrorFailure code message + _ -> do + P.reset conn + throwIO $ WrongMessageFormat "Unexpected response to ROUTE" + + +-- | Configuration for a routing-aware connection pool. +type RoutingPoolConfig :: Type +data RoutingPoolConfig = RoutingPoolConfig + { poolConfig :: PoolConfig + -- ^ Per-address pool configuration. + , routingDb :: Maybe Text + -- ^ Database to route for (Nothing = default database). + , refreshBuffer :: Int + -- ^ Seconds before TTL expiry to proactively refresh the routing table. + } + +-- | Default routing pool configuration. +defaultRoutingPoolConfig :: RoutingPoolConfig +defaultRoutingPoolConfig = RoutingPoolConfig + { poolConfig = defaultPoolConfig + , routingDb = Nothing + , refreshBuffer = 10 + } + + +-- | Cached routing table with monotonic expiry time. +type CachedRoutingTable :: Type +data CachedRoutingTable = CachedRoutingTable + { cachedTable :: !RoutingTable + , expiresAtNs :: !Word64 + } + +-- | A routing-aware connection pool that directs connections based on access mode. +type RoutingPool :: Type +data RoutingPool = RoutingPool + { rpConfig :: !ValidatedConfig + , rpPoolConfig :: !PoolConfig + , rpRoutingDb :: !(Maybe Text) + , rpRefreshBuf :: !Int + , rpCacheRef :: !(IORef (Maybe CachedRoutingTable)) + , rpPoolsRef :: !(IORef (HashMap Text BoltPool)) + , rpRefreshLock :: !(MVar ()) + , rpCounter :: !(IORef Int) + } + + +-- | Create a routing-aware connection pool. Connects to the seed address, +-- fetches the initial routing table, and sets up per-address pools. +createRoutingPool :: ValidatedConfig -> RoutingPoolConfig -> IO RoutingPool +createRoutingPool cfg RoutingPoolConfig{..} = do + let routingCfg = setRouting cfg Routing + cacheRef <- newIORef Nothing + poolsRef <- newIORef H.empty + lock <- newMVar () + counter <- newIORef 0 + let rp = RoutingPool + { rpConfig = routingCfg + , rpPoolConfig = poolConfig + , rpRoutingDb = routingDb + , rpRefreshBuf = refreshBuffer + , rpCacheRef = cacheRef + , rpPoolsRef = poolsRef + , rpRefreshLock = lock + , rpCounter = counter + } + -- Bootstrap: fetch routing table from seed + _ <- refreshRoutingTable rp + pure rp + + +-- | Destroy all per-address pools in the routing pool. +destroyRoutingPool :: RoutingPool -> IO () +destroyRoutingPool RoutingPool{rpPoolsRef} = do + pools <- readIORef rpPoolsRef + mapM_ destroyPool pools + writeIORef rpPoolsRef H.empty + + +-- | Invalidate the cached routing table, forcing a refresh on the next operation. +-- Use this when a routing error (e.g. NotALeader) indicates the table is stale. +invalidateRoutingTable :: RoutingPool -> IO () +invalidateRoutingTable RoutingPool{rpCacheRef} = writeIORef rpCacheRef Nothing + + +-- | Pick the next address from a vector using round-robin. +roundRobin :: RoutingPool -> V.Vector Text -> IO Text +roundRobin RoutingPool{rpCounter} addrs = do + idx <- atomicModifyIORef' rpCounter $ \n -> (n + 1, n) + pure $ addrs V.! (idx `mod` V.length addrs) + + +-- | Acquire a connection routed by access mode, run an action, then release. +-- On connection failure, tries the next address in round-robin order +-- until all addresses are exhausted. +withRoutingConnection :: HasCallStack => RoutingPool -> AccessMode -> (Connection -> IO a) -> IO a +withRoutingConnection rp mode action = do + rt <- getOrRefreshTable rp + let addrs = case mode of + ReadAccess -> readers rt + WriteAccess -> writers rt + when (V.null addrs) $ + throwIO $ RoutingTableError $ "No servers available for " <> T.pack (show mode) + tryAddresses rp addrs (V.length addrs) Nothing action + + +-- | Try addresses in round-robin order, failing over on connection errors. +tryAddresses :: HasCallStack + => RoutingPool -> V.Vector Text -> Int -> Maybe SomeException -> (Connection -> IO a) -> IO a +tryAddresses _rp _addrs 0 (Just lastErr) _action = throwIO lastErr +tryAddresses _rp _addrs 0 Nothing _action = + throwIO $ RoutingTableError "All servers unavailable" +tryAddresses rp addrs remaining _lastErr action = do + addr <- roundRobin rp addrs + pool <- getOrCreatePool rp addr + result <- try $ withConnection pool action + case result of + Right x -> pure x + Left (e :: SomeException) + | remaining > 1, isServerUnavailable e -> + tryAddresses rp addrs (remaining - 1) (Just e) action + | otherwise -> throwIO e + + +-- | Check if an exception indicates the server is unavailable (connection refused, +-- broken pipe, no healthy connection in pool, etc.) as opposed to a query-level error. +isServerUnavailable :: SomeException -> Bool +isServerUnavailable e = case fromException e :: Maybe Error of + Just (NonboltyError _) -> True -- IO exceptions (connection refused, broken pipe, etc.) + _ -> "no healthy connection" `isInfixOf` show e + + +-- | Run a retrying transaction routed by access mode. +-- Re-acquires routing table and connection on each retry attempt, so that +-- routing errors (NotALeader) and transient errors trigger fresh routing. +withRoutingTransaction :: HasCallStack => RoutingPool -> AccessMode -> (Connection -> IO a) -> IO a +withRoutingTransaction rp mode action = + let rc = retryConfig (rpPoolConfig rp) + maxR = maxRetries rc + initD = initialDelay rc + maxD = maxDelay rc + in go maxR initD maxD + where + go 0 _ _ = attempt + go n delay maxD = do + result <- try attempt + case result of + Right x -> pure x + Left (e :: SomeException) -> case fromException e :: Maybe Error of + Just err + | isTransient err -> do + threadDelay delay + go (n - 1) (min maxD (delay * 2)) maxD + | isRoutingError err -> do + invalidateRoutingTable rp + threadDelay delay + go (n - 1) (min maxD (delay * 2)) maxD + _ -> throwIO e + + modeChar = case mode of + ReadAccess -> 'r' + WriteAccess -> 'w' + + attempt = do + rt <- getOrRefreshTable rp + let addrs = case mode of + ReadAccess -> readers rt + WriteAccess -> writers rt + when (V.null addrs) $ + throwIO $ RoutingTableError $ "No servers available for " <> T.pack (show mode) + addr <- roundRobin rp addrs + pool <- getOrCreatePool rp addr + withConnection pool $ \conn -> do + P.beginTx conn $ Begin V.empty Nothing H.empty modeChar Nothing Nothing + result <- action conn `onException` P.tryRollback conn + _ <- P.commitTx conn + pure result + + +-- | Get the cached routing table, refreshing if expired. +getOrRefreshTable :: RoutingPool -> IO RoutingTable +getOrRefreshTable rp@RoutingPool{rpCacheRef, rpRefreshBuf} = do + cached <- readIORef rpCacheRef + now <- getMonotonicTimeNSec + let bufferNs = fromIntegral rpRefreshBuf * 1_000_000_000 + case cached of + Just CachedRoutingTable{cachedTable, expiresAtNs} + | now + bufferNs < expiresAtNs -> pure cachedTable + _ -> refreshRoutingTable rp + + +-- | Refresh the routing table. Tries known router addresses from the cached +-- table first, then falls back to the seed address from the initial config. +refreshRoutingTable :: RoutingPool -> IO RoutingTable +refreshRoutingTable rp@RoutingPool{rpConfig, rpCacheRef, rpRefreshLock} = + withMVar rpRefreshLock $ \_ -> do + -- Double-check after acquiring lock (another thread may have refreshed) + cached <- readIORef rpCacheRef + now <- getMonotonicTimeNSec + let bufferNs = fromIntegral (rpRefreshBuf rp) * 1_000_000_000 + case cached of + Just CachedRoutingTable{cachedTable, expiresAtNs} + | now + bufferNs < expiresAtNs -> pure cachedTable + _ -> do + -- Build list of addresses to try: known routers first, seed last + let knownRouters = case cached of + Just CachedRoutingTable{cachedTable} -> V.toList (routers cachedTable) + Nothing -> [] + let seedAddr = seedAddress rpConfig + let allAddrs = dedupAddrs (knownRouters <> [seedAddr]) + tryRefreshFrom rp allAddrs now + + +-- | Try to refresh the routing table from a list of router addresses. +-- Tries each in order, falling through on failure. +tryRefreshFrom :: RoutingPool -> [Text] -> Word64 -> IO RoutingTable +tryRefreshFrom _rp [] _now = + throwIO $ RoutingTableError "Could not reach any router to refresh routing table" +tryRefreshFrom rp@RoutingPool{rpConfig, rpRoutingDb, rpCacheRef} (addr:rest) now = do + let (h, p) = parseAddress addr + let cfg = setHostPort rpConfig h p + result <- try $ do + conn <- P.connect cfg + rt <- getRoutingTable conn rpRoutingDb + P.close conn + pure rt + case result of + Right rt -> do + let expiresAt = now + fromIntegral (ttl rt) * 1_000_000_000 + writeIORef rpCacheRef $ Just CachedRoutingTable{cachedTable = rt, expiresAtNs = expiresAt} + pure rt + Left (_ :: SomeException) + | not (null rest) -> tryRefreshFrom rp rest now + | otherwise -> throwIO $ RoutingTableError "Could not reach any router to refresh routing table" + + +-- | Remove duplicate addresses while preserving order. +dedupAddrs :: [Text] -> [Text] +dedupAddrs = go [] + where + go :: [Text] -> [Text] -> [Text] + go _seen [] = [] + go seen (x:xs) + | x `elem` seen = go seen xs + | otherwise = x : go (x:seen) xs + + +-- | Get or create a pool for a given address. +getOrCreatePool :: RoutingPool -> Text -> IO BoltPool +getOrCreatePool RoutingPool{rpConfig, rpPoolConfig, rpPoolsRef} addr = do + pools <- readIORef rpPoolsRef + case H.lookup addr pools of + Just pool -> pure pool + Nothing -> do + let (h, p) = parseAddress addr + let cfg = setHostPort rpConfig h p + pool <- createPool cfg rpPoolConfig + atomicModifyIORef' rpPoolsRef $ \ps -> (H.insert addr pool ps, ()) + pure pool + + +-- | Parse "host:port" into (host, port). Falls back to default port 7687. +parseAddress :: Text -> (Text, Word16) +parseAddress addr = + case T.splitOn ":" addr of + [h, p] -> case reads (T.unpack p) of + [(port, "")] -> (h, port) + _ -> (h, 7687) + _ -> (addr, 7687) + + +-- | Set the routing field on a ValidatedConfig (avoids ambiguous record update). +setRouting :: ValidatedConfig -> Routing -> ValidatedConfig +setRouting ValidatedConfig{host, port, scheme, use_tls, versions, timeout, user_agent, queryLogger, notificationHandler} r = + ValidatedConfig{host, port, scheme, use_tls, versions, timeout, routing = r, user_agent, queryLogger, notificationHandler} + + +-- | Set host and port on a ValidatedConfig (avoids ambiguous record update). +setHostPort :: ValidatedConfig -> Text -> Word16 -> ValidatedConfig +setHostPort ValidatedConfig{scheme, use_tls, versions, timeout, routing, user_agent, queryLogger, notificationHandler} h p = + ValidatedConfig{host = h, port = p, scheme, use_tls, versions, timeout, routing, user_agent, queryLogger, notificationHandler} + + +-- | Extract "host:port" from a ValidatedConfig (avoids ambiguous record field access). +seedAddress :: ValidatedConfig -> Text +seedAddress ValidatedConfig{host = h, port = p} = h <> ":" <> T.pack (show p) diff --git a/src/Database/Bolty/Session.hs b/src/Database/Bolty/Session.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Session.hs @@ -0,0 +1,217 @@ +-- | Sessions: managed transactions with automatic bookmark tracking for causal consistency. +module Database.Bolty.Session + ( -- * Bookmark management + BookmarkManager + , newBookmarkManager + , getBookmarks + , updateBookmark + -- * Session + , Session + , SessionConfig(..) + , defaultSessionConfig + , createSession + , createRoutingSession + -- * Managed transactions + , readTransaction + , writeTransaction + -- * Querying + , getLastBookmarks + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, fromException, onException, + throwIO, try) +import Control.Monad (when) +import qualified Data.HashMap.Lazy as H +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Vector as V +import GHC.Stack (HasCallStack) + +import Database.Bolty.Connection.Type +import qualified Database.Bolty.Connection.Pipe as P +import Database.Bolty.Message.Request (Begin(Begin), TelemetryApi(..)) +import Database.Bolty.Pool +import Database.Bolty.Routing (AccessMode(..), RoutingPool(..), withRoutingConnection, + invalidateRoutingTable) + + +-- --------------------------------------------------------------------------- +-- Bookmark management +-- --------------------------------------------------------------------------- + +-- | Mutable bookmark holder for causal consistency across transactions. +-- Within a session, each committed transaction produces a bookmark that +-- supersedes all previous bookmarks. The manager tracks the latest +-- bookmark(s) so they can be passed to the next transaction's BEGIN. +type BookmarkManager :: Type +newtype BookmarkManager = BookmarkManager (IORef [Text]) + +-- | Create a bookmark manager with optional initial bookmarks. +newBookmarkManager :: [Text] -> IO BookmarkManager +newBookmarkManager initial = BookmarkManager <$> newIORef initial + +-- | Get the current bookmarks. +getBookmarks :: BookmarkManager -> IO [Text] +getBookmarks (BookmarkManager ref) = readIORef ref + +-- | Replace the current bookmarks with the new one from a COMMIT response. +updateBookmark :: BookmarkManager -> Text -> IO () +updateBookmark (BookmarkManager ref) bm = writeIORef ref [bm] + + +-- --------------------------------------------------------------------------- +-- Session +-- --------------------------------------------------------------------------- + +-- | Session configuration. +type SessionConfig :: Type +data SessionConfig = SessionConfig + { database :: !(Maybe Text) + -- ^ Database to use (Nothing = default database). + , accessMode :: !AccessMode + -- ^ Default access mode for auto-commit queries. + , sessionBookmarks :: ![Text] + -- ^ Initial bookmarks for causal consistency (e.g. from a previous session). + } + +-- | Default session configuration: default database, write access, no initial bookmarks. +defaultSessionConfig :: SessionConfig +defaultSessionConfig = SessionConfig + { database = Nothing + , accessMode = WriteAccess + , sessionBookmarks = [] + } + + +-- | Which pool type the session uses (internal). +type SessionPool :: Type +data SessionPool + = DirectPool !BoltPool + | RoutedPool !RoutingPool + +-- | A session bundles a connection pool with bookmark management and configuration. +-- Sessions track bookmarks automatically across managed transactions +-- ('readTransaction', 'writeTransaction') to ensure causal consistency. +type Session :: Type +data Session = Session + { sPool :: !SessionPool + , sBookmarks :: !BookmarkManager + , sConfig :: !SessionConfig + , sRetry :: !RetryConfig + , sTelemetrySent :: !(IORef Bool) + } + + +-- | Create a session using a direct (non-routing) connection pool. +createSession :: BoltPool -> SessionConfig -> IO Session +createSession pool cfg = do + bm <- newBookmarkManager (sessionBookmarks cfg) + ts <- newIORef False + pure Session + { sPool = DirectPool pool + , sBookmarks = bm + , sConfig = cfg + , sRetry = bpRetryConfig pool + , sTelemetrySent = ts + } + + +-- | Create a session using a routing-aware connection pool. +createRoutingSession :: RoutingPool -> SessionConfig -> IO Session +createRoutingSession rp cfg = do + bm <- newBookmarkManager (sessionBookmarks cfg) + ts <- newIORef False + pure Session + { sPool = RoutedPool rp + , sBookmarks = bm + , sConfig = cfg + , sRetry = retryConfig (rpPoolConfig rp) + , sTelemetrySent = ts + } + + +-- | Get the last bookmarks from the session. Pass these to a new session's +-- 'SessionConfig' to ensure the new session sees all committed writes. +getLastBookmarks :: Session -> IO [Text] +getLastBookmarks Session{sBookmarks} = getBookmarks sBookmarks + + +-- --------------------------------------------------------------------------- +-- Managed transactions +-- --------------------------------------------------------------------------- + +-- | Run a read transaction. Uses 'ReadAccess' for routing (directs to +-- read replicas in a cluster). Automatically handles BEGIN, COMMIT, +-- ROLLBACK, bookmark propagation, and retries on transient failures. +readTransaction :: HasCallStack => Session -> (Connection -> IO a) -> IO a +readTransaction session action = managedTransaction session ReadAccess action + + +-- | Run a write transaction. Uses 'WriteAccess' for routing (directs to +-- the leader in a cluster). Automatically handles BEGIN, COMMIT, +-- ROLLBACK, bookmark propagation, and retries on transient failures. +writeTransaction :: HasCallStack => Session -> (Connection -> IO a) -> IO a +writeTransaction session action = managedTransaction session WriteAccess action + + +-- | Internal: run a managed transaction with the given access mode. +-- Re-acquires a connection on each retry so that routing errors (NotALeader) +-- result in fresh routing table lookups. +managedTransaction :: HasCallStack => Session -> AccessMode -> (Connection -> IO a) -> IO a +managedTransaction Session{sPool, sBookmarks, sConfig, sRetry, sTelemetrySent} mode action = + let maxR = maxRetries sRetry + initD = initialDelay sRetry + maxD = maxDelay sRetry + in go maxR initD maxD + where + go 0 _ _ = attempt + go n delay maxD = do + result <- try attempt + case result of + Right x -> pure x + Left (e :: SomeException) -> case fromException e :: Maybe Error of + Just err + | isTransient err -> do + threadDelay delay + go (n - 1) (min maxD (delay * 2)) maxD + | isRoutingError err -> do + invalidatePool sPool + threadDelay delay + go (n - 1) (min maxD (delay * 2)) maxD + _ -> throwIO e + + modeChar = case mode of + ReadAccess -> 'r' + WriteAccess -> 'w' + + attempt = + withSessionConnection sPool mode $ \conn -> do + -- Get current bookmarks and begin the transaction + bms <- getBookmarks sBookmarks + P.beginTx conn $ Begin (V.fromList bms) Nothing H.empty modeChar (database sConfig) Nothing + -- Run the user's action, rollback on error + result <- action conn `onException` P.tryRollback conn + -- Commit and extract bookmark + mbBookmark <- P.commitTx conn + case mbBookmark of + Just bm -> updateBookmark sBookmarks bm + Nothing -> pure () + -- Send telemetry after first successful managed transaction + sent <- readIORef sTelemetrySent + when (not sent) $ do + writeIORef sTelemetrySent True + P.sendTelemetry conn ManagedTransactions + pure result + + invalidatePool (RoutedPool rp) = invalidateRoutingTable rp + invalidatePool (DirectPool _) = pure () + + +-- | Acquire a connection based on pool type and access mode. +withSessionConnection :: SessionPool -> AccessMode -> (Connection -> IO a) -> IO a +withSessionConnection (DirectPool pool) _mode action = + withConnection pool action +withSessionConnection (RoutedPool rp) mode action = + withRoutingConnection rp mode action diff --git a/src/Database/Bolty/Stats.hs b/src/Database/Bolty/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Stats.hs @@ -0,0 +1,75 @@ +-- | Query statistics (nodes created, relationships deleted, etc.). +module Database.Bolty.Stats + ( QueryStats(..) + , parseStats + ) where + +import Prelude + +import Data.Int (Int64) +import Data.Kind (Type) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T + +import Data.PackStream.Ps (Ps(..)) +import Data.PackStream.Integer (fromPSInteger) + + +-- | Typed query statistics from the PULL SUCCESS metadata. +-- All integer fields default to 0 and booleans to False when absent. +type QueryStats :: Type +data QueryStats = QueryStats + { nodesCreated :: !Int64 + , nodesDeleted :: !Int64 + , relationshipsCreated :: !Int64 + , relationshipsDeleted :: !Int64 + , propertiesSet :: !Int64 + , labelsAdded :: !Int64 + , labelsRemoved :: !Int64 + , indexesAdded :: !Int64 + , indexesRemoved :: !Int64 + , constraintsAdded :: !Int64 + , constraintsRemoved :: !Int64 + , containsUpdates :: !Bool + , containsSystemUpdates :: !Bool + , systemUpdates :: !Int64 + } + deriving stock (Show, Eq) + + +-- | Parse the raw @stats@ field from PULL SUCCESS metadata. +-- Returns 'Nothing' if the field is absent (read-only queries). +-- The server uses hyphenated keys (e.g. @"nodes-created"@). +parseStats :: Maybe Ps -> Maybe QueryStats +parseStats Nothing = Nothing +parseStats (Just (PsDictionary m)) = Just QueryStats + { nodesCreated = intField "nodes-created" m + , nodesDeleted = intField "nodes-deleted" m + , relationshipsCreated = intField "relationships-created" m + , relationshipsDeleted = intField "relationships-deleted" m + , propertiesSet = intField "properties-set" m + , labelsAdded = intField "labels-added" m + , labelsRemoved = intField "labels-removed" m + , indexesAdded = intField "indexes-added" m + , indexesRemoved = intField "indexes-removed" m + , constraintsAdded = intField "constraints-added" m + , constraintsRemoved = intField "constraints-removed" m + , containsUpdates = boolField "contains-updates" m + , containsSystemUpdates = boolField "contains-system-updates" m + , systemUpdates = intField "system-updates" m + } +parseStats (Just _) = Nothing + + +intField :: T.Text -> H.HashMap T.Text Ps -> Int64 +intField key m = case H.lookup key m of + Just (PsInteger n) -> case fromPSInteger n of + Just i -> i + Nothing -> 0 + _ -> 0 + + +boolField :: T.Text -> H.HashMap T.Text Ps -> Bool +boolField key m = case H.lookup key m of + Just (PsBoolean b) -> b + _ -> False diff --git a/src/Database/Bolty/Util.hs b/src/Database/Bolty/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Util.hs @@ -0,0 +1,74 @@ +-- | Internal module. Not part of the public API. +module Database.Bolty.Util + ( chunksOfBSL + , chunksOfBS + , putTextUtf8 + , decodeStrict + , encodeStrict + , lazyByteStringToHex + , whenInvalid + ) where + +import Control.Exception.Extra (Partial) +import Data.ByteString.Builder (toLazyByteString, lazyByteStringHex) +import Data.Int (Int64) +import Data.List.Split (chunksOf) +import Data.Persist (Put, HasEndianness, putByteString, runPut, runGet, putBE, getBE) +import Data.Word8 (toUpper) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Validation as V + + +-- | Split a lazy 'BSL.ByteString' into chunks of at most @n@ bytes. +chunksOfBSL :: Partial => Int64 -> BSL.ByteString -> [BSL.ByteString] +chunksOfBSL i _ | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i +chunksOfBSL i xs = repeatedlyBSL (BSL.splitAt i) xs + +-- | Split a strict 'BS.ByteString' into chunks of at most @n@ bytes. +chunksOfBS :: Partial => Int -> BS.ByteString -> [BS.ByteString] +chunksOfBS i _ | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i +chunksOfBS i xs = repeatedlyBS (BS.splitAt i) xs + +repeatedlyBSL :: (BSL.ByteString -> (b, BSL.ByteString)) -> BSL.ByteString -> [b] +repeatedlyBSL f bs + | BSL.null bs = [] + | otherwise = b : repeatedlyBSL f bs' + where (b, bs') = f bs + +repeatedlyBS :: (BS.ByteString -> (b, BS.ByteString)) -> BS.ByteString -> [b] +repeatedlyBS f bs + | BS.null bs = [] + | otherwise = b : repeatedlyBS f bs' + where (b, bs') = f bs + + +-- | Encode 'T.Text' as raw UTF-8 bytes into the 'Put' monad. +putTextUtf8 :: T.Text -> Put () +putTextUtf8 = putByteString . T.encodeUtf8 + +-- | Decode a big-endian value from a strict 'BS.ByteString', throwing on failure. +decodeStrict :: forall a. HasEndianness a => BS.ByteString -> a +decodeStrict bs = case runGet (getBE @a) bs of + Left e -> error $ "decodeStrict: " ++ e + Right v -> v + +-- | Encode a value as a big-endian strict 'BS.ByteString'. +encodeStrict :: HasEndianness a => a -> BS.ByteString +encodeStrict = runPut . putBE + + +-- | Convert a lazy 'BSL.ByteString' to an uppercase hex-encoded strict 'BS.ByteString'. +lazyByteStringToHex :: BSL.ByteString -> BS.ByteString +lazyByteStringToHex bs = BS.intercalate " " $ map BS.pack $ Data.List.Split.chunksOf 2 $ map toUpper $ BS.unpack $ BSL.toStrict $ toLazyByteString $ lazyByteStringHex bs + + +-- | Return 'V.Failure' with the given error when the condition is 'True', otherwise 'V.Success'. +whenInvalid :: a -> Bool -> T.Text -> V.Validation [T.Text] a +whenInvalid x invalid err = + if invalid then + V.Failure [err] + else + V.Success x diff --git a/src/Database/Bolty/Value/Helpers.hs b/src/Database/Bolty/Value/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Value/Helpers.hs @@ -0,0 +1,217 @@ +-- | Internal module. Not part of the public API. +module Database.Bolty.Value.Helpers + ( -- * Checkers + isTinyInt, isTinyWord, isTinyText, isTinyList, isTinyDict, isTinyStruct + , isNull, isBool, isInt, isDouble, isDict, isText, isList, isStruct + , isNewVersion + -- * Version helpers + , versionMajor, versionMinor + , supportsLogonLogoff, supportsTelemetry + -- * Constants + , nullCode, falseCode, trueCode + , int8Code, int16Code, int32Code, int64Code, doubleCode + , textConst, text8Code, text16Code, text32Code + , listConst, list8Code, list16Code, list32Code + , dictConst, dict8Code, dict16Code, dict32Code + , structConst, struct8Code, struct16Code + , sigNode, sigRel, sigURel, sigPath + , sigDate, sigTime, sigLocalTime, sigDateTime, sigDateTimeZoneId, sigLocalDateTime, sigDuration + , sigPoint2D, sigPoint3D + , sigInit, sigHello, sigRun, sigAFail, sigReset, sigDAll, sigPAll, sigGBye + , sigSucc, sigFail, sigRecs, sigIgn + -- * Helpers + , toInt, getSize, inRange, isIntX + ) where + +import Control.Applicative (liftA3) +import Data.Bits ((.&.), shiftR) +import Data.Word (Word8, Word32) + +-- = Checkers + +-- | Check whether a value fits in the PackStream tiny integer range @[-16, 127]@. +isTinyInt :: Integral a => a -> Bool +isTinyInt = inRange (-16, 128 - 1) + +-- | Check whether a tag byte represents a tiny word (inline integer). +isTinyWord :: Word8 -> Bool +isTinyWord = liftA2 (||) (< textConst) (>= 240) + +-- | Check whether a tag byte represents a tiny text (length embedded in tag). +isTinyText :: Word8 -> Bool +isTinyText = liftA2 (&&) (>= textConst) (< listConst) + +-- | Check whether a tag byte represents a tiny list (length embedded in tag). +isTinyList :: Word8 -> Bool +isTinyList = liftA2 (&&) (>= listConst) (< dictConst) + +-- | Check whether a tag byte represents a tiny dictionary (length embedded in tag). +isTinyDict :: Word8 -> Bool +isTinyDict = liftA2 (&&) (>= dictConst) (< structConst) + +-- | Check whether a tag byte represents a tiny structure (length embedded in tag). +isTinyStruct :: Word8 -> Bool +isTinyStruct = liftA2 (&&) (>= structConst) (< nullCode) + +-- | Check whether a tag byte is the null marker. +isNull :: Word8 -> Bool +isNull = (== nullCode) + +-- | Check whether a tag byte is a boolean marker (true or false). +isBool :: Word8 -> Bool +isBool = liftA2 (||) (== trueCode) (== falseCode) + +-- | Check whether a tag byte represents any integer encoding. +isInt :: Word8 -> Bool +isInt = do x <- liftA2 (||) (== int8Code) (== int16Code) + y <- liftA2 (||) (== int32Code) (== int64Code) + z <- isTinyWord + pure $ x || y || z + +-- | Check whether a tag byte is the double (float64) marker. +isDouble :: Word8 -> Bool +isDouble = (== doubleCode) + +-- | Check whether a tag byte represents any dictionary encoding. +isDict :: Word8 -> Bool +isDict = do x <- liftA2 (||) (== dict8Code) (== dict16Code) + y <- liftA2 (||) (== dict32Code) isTinyDict + pure $ x || y + +-- | Check whether a tag byte represents any text encoding. +isText :: Word8 -> Bool +isText = do x <- liftA2 (||) (== text8Code) (== text16Code) + y <- liftA2 (||) (== text32Code) isTinyText + pure $ x || y + +-- | Check whether a tag byte represents any list encoding. +isList :: Word8 -> Bool +isList = do x <- liftA2 (||) (== list8Code) (== list16Code) + y <- liftA2 (||) (== list32Code) isTinyList + pure $ x || y + +-- | Check whether a tag byte represents any structure encoding. +isStruct :: Word8 -> Bool +isStruct = liftA3 (\x y z -> x || y || z) (== struct8Code) (== struct16Code) isTinyStruct + +-- | Check whether a negotiated version uses the new (v3+) handshake format. +isNewVersion :: Word32 -> Bool +isNewVersion v = (v .&. 255) >= 3 + +-- | Extract the major version from a negotiated version Word32. +-- The server responds with [0, 0, minor, major]. +versionMajor :: Word32 -> Word8 +versionMajor v = fromIntegral (v .&. 0xFF) + +-- | Extract the minor version from a negotiated version Word32. +versionMinor :: Word32 -> Word8 +versionMinor v = fromIntegral ((v `shiftR` 8) .&. 0xFF) + +-- | Bolt 5.1+ uses LOGON/LOGOFF instead of credentials in HELLO. +supportsLogonLogoff :: Word32 -> Bool +supportsLogonLogoff v = versionMajor v == 5 && versionMinor v >= 1 + +-- | Bolt 5.4+ supports the TELEMETRY message. +supportsTelemetry :: Word32 -> Bool +supportsTelemetry v = versionMajor v == 5 && versionMinor v >= 4 + +-- = Constants + +-- | Tag bytes for null, false, and true. +nullCode, falseCode, trueCode :: Word8 +nullCode = 192 +falseCode = 194 +trueCode = 195 + +-- | Tag bytes for integer and double encodings. +int8Code, int16Code, int32Code, int64Code, doubleCode :: Word8 +int8Code = 200 +int16Code = 201 +int32Code = 202 +int64Code = 203 +doubleCode = 193 + +-- | Tag bytes for text encodings (tiny base and sized variants). +textConst, text8Code, text16Code, text32Code :: Word8 +textConst = 128 +text8Code = 208 +text16Code = 209 +text32Code = 210 + +-- | Tag bytes for list encodings (tiny base and sized variants). +listConst, list8Code, list16Code, list32Code :: Word8 +listConst = 144 +list8Code = 212 +list16Code = 213 +list32Code = 214 + +-- | Tag bytes for dictionary encodings (tiny base and sized variants). +dictConst, dict8Code, dict16Code, dict32Code :: Word8 +dictConst = 160 +dict8Code = 216 +dict16Code = 217 +dict32Code = 218 + +-- | Tag bytes for structure encodings (tiny base and sized variants). +structConst, struct8Code, struct16Code :: Word8 +structConst = 176 +struct8Code = 220 +struct16Code = 221 + +-- | Structure signature bytes for graph types (Node, Relationship, UnboundRelationship, Path). +sigNode, sigRel, sigURel, sigPath :: Word8 +sigNode = 78 +sigRel = 82 +sigURel = 114 +sigPath = 80 + +-- | Structure signature bytes for temporal types. +sigDate, sigTime, sigLocalTime, sigDateTime, sigDateTimeZoneId, sigLocalDateTime, sigDuration :: Word8 +sigDate = 0x44 -- 68 +sigTime = 0x54 -- 84 +sigLocalTime = 0x74 -- 116 +sigDateTime = 0x49 -- 73 (BOLT v5+) +sigDateTimeZoneId = 0x69 -- 105 (BOLT v5+) +sigLocalDateTime = 0x64 -- 100 (BOLT v5+) +sigDuration = 0x45 -- 69 + +-- | Structure signature bytes for spatial point types. +sigPoint2D, sigPoint3D :: Word8 +sigPoint2D = 0x58 -- 88 +sigPoint3D = 0x59 -- 89 + +-- | Structure signature bytes for client request messages. +sigInit, sigHello, sigRun, sigAFail, sigReset, sigDAll, sigPAll, sigGBye :: Word8 +sigInit = 1 +sigHello = 1 +sigRun = 16 +sigAFail = 14 +sigReset = 15 +sigDAll = 47 +sigPAll = 63 +sigGBye = 2 + +-- | Structure signature bytes for server response messages. +sigSucc, sigFail, sigRecs, sigIgn :: Word8 +sigSucc = 112 +sigFail = 127 +sigRecs = 113 +sigIgn = 126 + +-- = Other helpers + +-- | Convert any 'Integral' value to 'Int'. +toInt :: Integral a => a -> Int +toInt = fromIntegral + +-- | Extract the size from the low nibble of a tag byte. +getSize :: Word8 -> Int +getSize x = fromIntegral $ x .&. 15 + +-- | Check whether a value lies in the half-open interval @[low, up)@. +inRange :: Ord a => (a, a) -> a -> Bool +inRange (low, up) x = low <= x && x < up + +-- | Check whether a value fits in a signed integer with @p@ bits. +isIntX :: Integral x => x -> x -> Bool +isIntX p = inRange (-(2 ^ (p-1)), 2 ^ (p-1) - 1) diff --git a/src/Database/Bolty/Value/Type.hs b/src/Database/Bolty/Value/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolty/Value/Type.hs @@ -0,0 +1,431 @@ +-- | Internal module. Not part of the public API. +-- +-- Bolt value types: the Haskell representation of Neo4j values returned by queries. +module Database.Bolty.Value.Type + ( Bolt(..) + -- * Bolt value extractors + , asNull, asBool, asInt, asFloat, asBytes, asText + , asList, asDict, asNode, asRelationship, asPath + -- * Graph types + , Node(..) + , Relationship(..) + , UnboundRelationship(..) + , Path(..) + -- * Temporal types + , Date(..) + , Time(..) + , LocalTime(..) + , DateTime(..) + , DateTimeZoneId(..) + , LocalDateTime(..) + , Duration(..) + -- * Spatial types + , Point2D(..) + , Point3D(..) + ) where + +import Data.Int (Int64) +import Data.Kind (Type) +import GHC.Generics (Generic) +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.Ps +import Data.PackStream.Result (Result(..)) +import Data.PackStream.Integer (PSInteger) +import Database.Bolty.Value.Helpers (sigNode, sigRel, sigURel, sigPath + , sigDate, sigTime, sigLocalTime, sigDateTime + , sigDateTimeZoneId, sigLocalDateTime, sigDuration + , sigPoint2D, sigPoint3D) +import Numeric (showHex) + + +-- | A typed Neo4j value. Every field in a query result record is a 'Bolt'. +type Bolt :: Type +data Bolt + = BoltNull + | BoltBoolean !Bool + | BoltInteger !PSInteger + | BoltFloat !Double + | BoltBytes !BS.ByteString + | BoltString !T.Text + | BoltList !(V.Vector Bolt) + | BoltDictionary !(H.HashMap T.Text Bolt) + | BoltNode Node + | BoltRelationship Relationship + | BoltUnboundRelationship UnboundRelationship + | BoltPath Path + | BoltDate Date + | BoltTime Time + | BoltLocalTime LocalTime + | BoltDateTime DateTime + | BoltDateTimeZoneId DateTimeZoneId + | BoltLocalDateTime LocalDateTime + | BoltDuration Duration + | BoltPoint2D Point2D + | BoltPoint3D Point3D + deriving stock (Show, Eq, Generic) + +instance PackStream Bolt where + toPs BoltNull = PsNull + toPs (BoltBoolean b) = PsBoolean b + toPs (BoltInteger n) = PsInteger n + toPs (BoltFloat d) = PsFloat d + toPs (BoltBytes b) = PsBytes b + toPs (BoltString t) = PsString t + toPs (BoltList v) = PsList (V.map toPs v) + toPs (BoltDictionary m) = PsDictionary (H.map toPs m) + toPs (BoltNode n) = toPs n + toPs (BoltRelationship r) = toPs r + toPs (BoltUnboundRelationship r) = toPs r + toPs (BoltPath p) = toPs p + toPs (BoltDate d) = toPs d + toPs (BoltTime t) = toPs t + toPs (BoltLocalTime t) = toPs t + toPs (BoltDateTime dt) = toPs dt + toPs (BoltDateTimeZoneId dt) = toPs dt + toPs (BoltLocalDateTime dt) = toPs dt + toPs (BoltDuration d) = toPs d + toPs (BoltPoint2D p) = toPs p + toPs (BoltPoint3D p) = toPs p + + fromPs PsNull = Success BoltNull + fromPs (PsBoolean b) = Success (BoltBoolean b) + fromPs (PsInteger n) = Success (BoltInteger n) + fromPs (PsFloat d) = Success (BoltFloat d) + fromPs (PsBytes b) = Success (BoltBytes b) + fromPs (PsString t) = Success (BoltString t) + fromPs (PsList v) = BoltList <$> traverse fromPs v + fromPs (PsDictionary m) = BoltDictionary <$> traverse fromPs m + fromPs ps@(PsStructure t _) = case t of + _ | t == sigNode -> BoltNode <$> fromPs ps + | t == sigRel -> BoltRelationship <$> fromPs ps + | t == sigURel -> BoltUnboundRelationship <$> fromPs ps + | t == sigPath -> BoltPath <$> fromPs ps + | t == sigDate -> BoltDate <$> fromPs ps + | t == sigTime -> BoltTime <$> fromPs ps + | t == sigLocalTime -> BoltLocalTime <$> fromPs ps + | t == sigDateTime -> BoltDateTime <$> fromPs ps + | t == sigDateTimeZoneId -> BoltDateTimeZoneId <$> fromPs ps + | t == sigLocalDateTime -> BoltLocalDateTime <$> fromPs ps + | t == sigDuration -> BoltDuration <$> fromPs ps + | t == sigPoint2D -> BoltPoint2D <$> fromPs ps + | t == sigPoint3D -> BoltPoint3D <$> fromPs ps + | otherwise -> Error $ "unknown structure tag: 0x" <> T.pack (showHex t "") + + +-- | A graph node. +type Node :: Type +data Node = Node + { id :: !Int64 + -- ^ Legacy numeric ID (use 'element_id' for BOLT 5+). + , labels :: !(V.Vector T.Text) + -- ^ Node labels. + , properties :: !(H.HashMap T.Text Ps) + -- ^ Node properties. + , element_id :: !T.Text + -- ^ Element ID string (empty on BOLT 4.x). + } + deriving stock (Show, Eq, Generic) +instance PackStream Node where + toPs Node{id, labels, properties, element_id} = + PsStructure sigNode $ V.fromList [toPs id, toPs labels, toPs properties, toPs element_id] + -- BOLT 5+: 4 fields (id, labels, properties, element_id) + fromPs (PsStructure t fs) | t == sigNode, V.length fs == 4 = + Node <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3) + -- BOLT 4.x: 3 fields (id, labels, properties) — no element_id + fromPs (PsStructure t fs) | t == sigNode, V.length fs == 3 = + Node <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> pure "" + fromPs other = typeMismatch "Node" other + +-- | A graph relationship (edge). +type Relationship :: Type +data Relationship = Relationship + { id :: !Int64 + -- ^ Legacy numeric ID. + , startNodeId :: !Int64 + -- ^ Legacy numeric ID of the start node. + , endNodeId :: !Int64 + -- ^ Legacy numeric ID of the end node. + , type_ :: !T.Text + -- ^ Relationship type name. + , properties :: !(H.HashMap T.Text Ps) + -- ^ Relationship properties. + , element_id :: !T.Text + -- ^ Element ID string (empty on BOLT 4.x). + , start_node_element_id :: !T.Text + -- ^ Start node element ID (empty on BOLT 4.x). + , end_node_element_id :: !T.Text + -- ^ End node element ID (empty on BOLT 4.x). + } + deriving stock (Show, Eq, Generic) +instance PackStream Relationship where + toPs Relationship{id, startNodeId, endNodeId, type_, properties, element_id, start_node_element_id, end_node_element_id} = + PsStructure sigRel $ V.fromList + [toPs id, toPs startNodeId, toPs endNodeId, toPs type_, toPs properties + , toPs element_id, toPs start_node_element_id, toPs end_node_element_id] + -- BOLT 5+: 8 fields (id, startNodeId, endNodeId, type_, properties, element_id, start_node_element_id, end_node_element_id) + fromPs (PsStructure t fs) | t == sigRel, V.length fs == 8 = + Relationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) + <*> fromPs (fs V.! 3) <*> fromPs (fs V.! 4) <*> fromPs (fs V.! 5) + <*> fromPs (fs V.! 6) <*> fromPs (fs V.! 7) + -- BOLT 4.x: 5 fields (id, startNodeId, endNodeId, type_, properties) — no element_id fields + fromPs (PsStructure t fs) | t == sigRel, V.length fs == 5 = + Relationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) + <*> fromPs (fs V.! 3) <*> fromPs (fs V.! 4) <*> pure "" <*> pure "" <*> pure "" + fromPs other = typeMismatch "Relationship" other + + +-- | A relationship without start\/end node information (used in paths). +type UnboundRelationship :: Type +data UnboundRelationship = UnboundRelationship + { id :: !Int64 + , type_ :: !T.Text + -- ^ Relationship type name. + , properties :: !(H.HashMap T.Text Ps) + , element_id :: !T.Text + -- ^ Element ID string (empty on BOLT 4.x). + } + deriving stock (Show, Eq, Generic) +instance PackStream UnboundRelationship where + toPs UnboundRelationship{id, type_, properties, element_id} = + PsStructure sigURel $ V.fromList [toPs id, toPs type_, toPs properties, toPs element_id] + -- BOLT 5+: 4 fields (id, type_, properties, element_id) + fromPs (PsStructure t fs) | t == sigURel, V.length fs == 4 = + UnboundRelationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3) + -- BOLT 4.x: 3 fields (id, type_, properties) — no element_id + fromPs (PsStructure t fs) | t == sigURel, V.length fs == 3 = + UnboundRelationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> pure "" + fromPs other = typeMismatch "UnboundRelationship" other + + +-- | A graph path: an alternating sequence of nodes and relationships. +type Path :: Type +data Path = Path + { nodes :: !(V.Vector Node) + -- ^ Unique nodes in the path. + , rels :: !(V.Vector UnboundRelationship) + -- ^ Unique relationships in the path. + , indices :: !(V.Vector Int64) + -- ^ Indices into 'nodes' and 'rels' describing the traversal order. + } + deriving stock (Show, Eq, Generic) +instance PackStream Path where + toPs Path{nodes, rels, indices} = + PsStructure sigPath $ V.fromList [toPs nodes, toPs rels, toPs indices] + fromPs (PsStructure t fs) | t == sigPath, V.length fs == 3 = + Path <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) + fromPs other = typeMismatch "Path" other + + +-- | A date (days since Unix epoch). +type Date :: Type +data Date = Date + { days :: !Int64 + } + deriving stock (Show, Eq, Generic) +instance PackStream Date where + toPs Date{days} = + PsStructure sigDate $ V.singleton (toPs days) + fromPs (PsStructure t fs) | t == sigDate, V.length fs == 1 = + Date <$> fromPs (fs V.! 0) + fromPs other = typeMismatch "Date" other + + +-- | A time with timezone offset. +type Time :: Type +data Time = Time + { nanoseconds :: !Int64 + -- ^ Nanoseconds since midnight. + , tz_offset_seconds :: !Int64 + -- ^ Timezone offset in seconds from UTC. + } + deriving stock (Show, Eq, Generic) +instance PackStream Time where + toPs Time{nanoseconds, tz_offset_seconds} = + PsStructure sigTime $ V.fromList [toPs nanoseconds, toPs tz_offset_seconds] + fromPs (PsStructure t fs) | t == sigTime, V.length fs == 2 = + Time <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) + fromPs other = typeMismatch "Time" other + + +-- | A local time (no timezone). +type LocalTime :: Type +data LocalTime = LocalTime + { nanoseconds :: !Int64 + -- ^ Nanoseconds since midnight. + } + deriving stock (Show, Eq, Generic) +instance PackStream LocalTime where + toPs LocalTime{nanoseconds} = + PsStructure sigLocalTime $ V.singleton (toPs nanoseconds) + fromPs (PsStructure t fs) | t == sigLocalTime, V.length fs == 1 = + LocalTime <$> fromPs (fs V.! 0) + fromPs other = typeMismatch "LocalTime" other + + +-- | A date-time with timezone offset. +type DateTime :: Type +data DateTime = DateTime + { seconds :: !Int64 + -- ^ Seconds since Unix epoch. + , nanoseconds :: !Int64 + -- ^ Nanosecond adjustment. + , tz_offset_seconds :: !Int64 + -- ^ Timezone offset in seconds from UTC. + } + deriving stock (Show, Eq, Generic) +instance PackStream DateTime where + toPs DateTime{seconds, nanoseconds, tz_offset_seconds} = + PsStructure sigDateTime $ V.fromList [toPs seconds, toPs nanoseconds, toPs tz_offset_seconds] + fromPs (PsStructure t fs) | t == sigDateTime, V.length fs == 3 = + DateTime <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) + fromPs other = typeMismatch "DateTime" other + + +-- | A date-time with named timezone (e.g. @\"Europe\/Paris\"@). +type DateTimeZoneId :: Type +data DateTimeZoneId = DateTimeZoneId + { seconds :: !Int64 + -- ^ Seconds since Unix epoch. + , nanoseconds :: !Int64 + -- ^ Nanosecond adjustment. + , tz_id :: !T.Text + -- ^ IANA timezone identifier. + } + deriving stock (Show, Eq, Generic) +instance PackStream DateTimeZoneId where + toPs DateTimeZoneId{seconds, nanoseconds, tz_id} = + PsStructure sigDateTimeZoneId $ V.fromList [toPs seconds, toPs nanoseconds, toPs tz_id] + fromPs (PsStructure t fs) | t == sigDateTimeZoneId, V.length fs == 3 = + DateTimeZoneId <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) + fromPs other = typeMismatch "DateTimeZoneId" other + + +-- | A local date-time (no timezone). +type LocalDateTime :: Type +data LocalDateTime = LocalDateTime + { seconds :: !Int64 + -- ^ Seconds since Unix epoch. + , nanoseconds :: !Int64 + -- ^ Nanosecond adjustment. + } + deriving stock (Show, Eq, Generic) +instance PackStream LocalDateTime where + toPs LocalDateTime{seconds, nanoseconds} = + PsStructure sigLocalDateTime $ V.fromList [toPs seconds, toPs nanoseconds] + fromPs (PsStructure t fs) | t == sigLocalDateTime, V.length fs == 2 = + LocalDateTime <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) + fromPs other = typeMismatch "LocalDateTime" other + + +-- | A temporal duration (months, days, seconds, nanoseconds). +type Duration :: Type +data Duration = Duration + { months :: !Int64 + , days :: !Int64 + , seconds :: !Int64 + , nanoseconds :: !Int64 + } + deriving stock (Show, Eq, Generic) +instance PackStream Duration where + toPs Duration{months, days, seconds, nanoseconds} = + PsStructure sigDuration $ V.fromList [toPs months, toPs days, toPs seconds, toPs nanoseconds] + fromPs (PsStructure t fs) | t == sigDuration, V.length fs == 4 = + Duration <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3) + fromPs other = typeMismatch "Duration" other + + +-- | A 2D spatial point. +type Point2D :: Type +data Point2D = Point2D + { srid :: !Int64 + -- ^ Spatial Reference Identifier (e.g. 4326 for WGS-84). + , x :: !Double + , y :: !Double + } + deriving stock (Show, Eq, Generic) +instance PackStream Point2D where + toPs Point2D{srid, x, y} = + PsStructure sigPoint2D $ V.fromList [toPs srid, toPs x, toPs y] + fromPs (PsStructure t fs) | t == sigPoint2D, V.length fs == 3 = + Point2D <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) + fromPs other = typeMismatch "Point2D" other + + +-- | A 3D spatial point. +type Point3D :: Type +data Point3D = Point3D + { srid :: !Int64 + -- ^ Spatial Reference Identifier (e.g. 4979 for WGS-84-3D). + , x :: !Double + , y :: !Double + , z :: !Double + } + deriving stock (Show, Eq, Generic) +instance PackStream Point3D where + toPs Point3D{srid, x, y, z} = + PsStructure sigPoint3D $ V.fromList [toPs srid, toPs x, toPs y, toPs z] + fromPs (PsStructure t fs) | t == sigPoint3D, V.length fs == 4 = + Point3D <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3) + fromPs other = typeMismatch "Point3D" other + + +-- = Bolt value extractors + +-- | Extract a null value. +asNull :: Bolt -> Maybe () +asNull BoltNull = Just () +asNull _ = Nothing + +-- | Extract a boolean value. +asBool :: Bolt -> Maybe Bool +asBool (BoltBoolean b) = Just b +asBool _ = Nothing + +-- | Extract an integer value. +asInt :: Bolt -> Maybe PSInteger +asInt (BoltInteger i) = Just i +asInt _ = Nothing + +-- | Extract a floating-point value. +asFloat :: Bolt -> Maybe Double +asFloat (BoltFloat d) = Just d +asFloat _ = Nothing + +-- | Extract a byte string value. +asBytes :: Bolt -> Maybe BS.ByteString +asBytes (BoltBytes b) = Just b +asBytes _ = Nothing + +-- | Extract a text value. +asText :: Bolt -> Maybe T.Text +asText (BoltString t) = Just t +asText _ = Nothing + +-- | Extract a list value. +asList :: Bolt -> Maybe (V.Vector Bolt) +asList (BoltList v) = Just v +asList _ = Nothing + +-- | Extract a dictionary value. +asDict :: Bolt -> Maybe (H.HashMap T.Text Bolt) +asDict (BoltDictionary m) = Just m +asDict _ = Nothing + +-- | Extract a node value. +asNode :: Bolt -> Maybe Node +asNode (BoltNode n) = Just n +asNode _ = Nothing + +-- | Extract a relationship value. +asRelationship :: Bolt -> Maybe Relationship +asRelationship (BoltRelationship r) = Just r +asRelationship _ = Nothing + +-- | Extract a path value. +asPath :: Bolt -> Maybe Path +asPath (BoltPath p) = Just p +asPath _ = Nothing diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1656 @@ +module Main where + +import Test.Sandwich + +import Control.Monad.IO.Class (liftIO) +import Data.Bits (shiftL, (.|.)) +import Data.Default (def) +import Data.Int (Int64) +import Data.Word (Word32) +import qualified Data.HashMap.Lazy as H +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Validation as Val + +import Data.PackStream.Ps (Ps(..), PackStream(..)) +import Data.PackStream (pack, unpack) +import Data.PackStream.Integer (toPSInteger) +import qualified Data.PackStream.Result as R +import Database.Bolty hiding (Error) +import Database.Bolty.Decode (DecodeError(..), decodeRow, decodeRows) +import Database.Bolty.Record (lookupField) +import qualified Database.Bolty.ResultSet as RS +import Database.Bolty.Logging (QueryLog(..)) +import Database.Bolty.Notification (Notification(..), Severity(..), Position(..), parseNotifications) +import Database.Bolty.Plan (PlanNode(..), ProfileNode(..), parsePlan, parseProfile) +import Database.Bolty.Stats (QueryStats(..), parseStats) +import Database.Bolty.Value.Type (Node(..), Relationship(..), UnboundRelationship(..) + , Path(..), Date(..), Time(..), LocalTime(..) + , DateTime(..), DateTimeZoneId(..), LocalDateTime(..) + , Duration(..), Point2D(..), Point3D(..)) +import Database.Bolty.Message.Request (Request(..), Hello(..), Route(..), RouteExtra(..) + , Logon(..), TelemetryApi(..)) +import Database.Bolty.Message.Response (Response(..), RoutingTable(..), parseRoutingTable, extractBookmark) +import Database.Bolty.Routing (parseAddress) +import Database.Bolty.Session (newBookmarkManager, getBookmarks, updateBookmark) +import Database.Bolty.Decode (psToBolt, boltToPs) +import Database.Bolty.Value.Helpers (sigLocalDateTime, supportsLogonLogoff, supportsTelemetry) + + +-- = Helpers + +setUserAgent :: UserAgent -> Config -> Config +setUserAgent ua Config{..} = Config { user_agent = ua, .. } + +-- = Config validation tests + +configTests :: TopSpec +configTests = describe "Config validation" $ do + it "validates default config" $ do + case validateConfig (def :: Config) of + Val.Failure errs -> expectationFailure $ "Default config should validate: " <> show errs + Val.Success _ -> pure () + + it "rejects empty host" $ do + let cfg = (def :: Config) { host = "" } + case validateConfig cfg of + Val.Failure _ -> pure () + Val.Success _ -> expectationFailure "Empty host should be rejected" + + it "rejects empty user agent name" $ do + let cfg = setUserAgent (UserAgent "" "1.0") (def :: Config) + case validateConfig cfg of + Val.Failure _ -> pure () + Val.Success _ -> expectationFailure "Empty user agent name should be rejected" + + it "rejects empty user agent version" $ do + let cfg = setUserAgent (UserAgent "bolty" "") (def :: Config) + case validateConfig cfg of + Val.Failure _ -> pure () + Val.Success _ -> expectationFailure "Empty user agent version should be rejected" + + it "rejects empty version list" $ do + let cfg = (def :: Config) { versions = [] } + case validateConfig cfg of + Val.Failure _ -> pure () + Val.Success _ -> expectationFailure "Empty version list should be rejected" + + +-- = Version validation tests + +versionTests :: TopSpec +versionTests = describe "Version validation" $ do + it "rejects major version < 4" $ do + let cfg = (def :: Config) { versions = [Version 0 3] } + case validateConfig cfg of + Val.Failure _ -> pure () + Val.Success _ -> expectationFailure "Major version < 4 should be rejected" + + it "rejects version 4.1 (below 4.4 floor)" $ do + let cfg = (def :: Config) { versions = [Version 1 4] } + case validateConfig cfg of + Val.Failure _ -> pure () + Val.Success _ -> expectationFailure "Version 4.1 should be rejected (below 4.4 floor)" + + it "accepts version 5.0" $ do + let cfg = (def :: Config) { versions = [Version 0 5] } + case validateConfig cfg of + Val.Failure errs -> expectationFailure $ "Version 5.0 should validate: " <> show errs + Val.Success _ -> pure () + + +-- = Bolt value extractor tests + +extractorTests :: TopSpec +extractorTests = describe "Bolt value extractors" $ do + it "asText extracts text" $ do + asText (BoltString "hello") `shouldBe` Just "hello" + + it "asText returns Nothing for non-text" $ do + asText (BoltInteger 42) `shouldBe` Nothing + + it "asInt extracts integer" $ do + asInt (BoltInteger 42) `shouldBe` Just 42 + + it "asInt returns Nothing for non-integer" $ do + asInt (BoltString "hello") `shouldBe` Nothing + + it "asBool extracts boolean" $ do + asBool (BoltBoolean True) `shouldBe` Just True + asBool (BoltBoolean False) `shouldBe` Just False + + it "asBool returns Nothing for non-boolean" $ do + asBool BoltNull `shouldBe` Nothing + + it "asFloat extracts float" $ do + asFloat (BoltFloat 3.14) `shouldBe` Just 3.14 + + it "asNull extracts null" $ do + asNull BoltNull `shouldBe` Just () + + it "asNull returns Nothing for non-null" $ do + asNull (BoltInteger 0) `shouldBe` Nothing + + it "asList extracts list" $ do + let v = V.fromList [BoltInteger 1, BoltInteger 2] + asList (BoltList v) `shouldBe` Just v + + it "asDict extracts dictionary" $ do + let m = H.fromList [("key", BoltString "value")] + asDict (BoltDictionary m) `shouldBe` Just m + + +-- = Record accessor tests + +recordTests :: TopSpec +recordTests = describe "Record accessors" $ do + let columns = V.fromList ["name", "age", "city"] + let record = V.fromList [BoltString "Alice", BoltInteger 30, BoltString "Paris"] + + it "lookupField finds existing field" $ do + lookupField columns "name" record `shouldBe` Just (BoltString "Alice") + lookupField columns "age" record `shouldBe` Just (BoltInteger 30) + lookupField columns "city" record `shouldBe` Just (BoltString "Paris") + + it "lookupField returns Nothing for missing field" $ do + lookupField columns "email" record `shouldBe` Nothing + + it "lookupField returns Nothing for empty record" $ do + lookupField columns "name" V.empty `shouldBe` Nothing + + +-- = PackStream round-trip tests + +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 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 (like HELLO)" $ 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 -- Node structure tag + [ PsInteger 1 -- id + , PsList (V.fromList [PsString "Person"]) -- labels + , PsDictionary (H.fromList [("name", PsString "Alice")]) -- properties + , PsString "4:abc:1" -- element_id + ] + 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 + let result = either R.Error R.Success $ unpack (pack txt) + (fromPs =<< result) `shouldBe` R.Success txt + + it "round-trips Bool via PackStream class" $ do + let result = either R.Error R.Success $ unpack (pack True) + (fromPs =<< result) `shouldBe` R.Success True + + +-- = Message serialization tests + +messageTests :: TopSpec +messageTests = describe "Message serialization" $ do + it "HELLO with None scheme produces correct structure" $ do + let hello = Hello (UserAgent "bolty" "2.0") None NoRouting False + let ps = toPs (RHello hello) + case ps of + PsStructure 0x01 fields -> do + V.length fields `shouldBe` 1 + case V.head fields of + PsDictionary m -> do + case H.lookup "user_agent" m of + Just (PsString ua) -> ua `shouldBe` "bolty/2.0" + _ -> expectationFailure "expected user_agent string" + case H.lookup "scheme" m of + Just (PsString s) -> s `shouldBe` "none" + _ -> expectationFailure "expected scheme string" + H.member "routing" m `shouldBe` False + _ -> expectationFailure "expected dictionary as HELLO field" + _ -> expectationFailure "expected structure with tag 0x01" + + it "HELLO with Basic scheme includes principal and credentials" $ do + let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "password") NoRouting False + let ps = toPs (RHello hello) + case ps of + PsStructure 0x01 fields -> case V.head fields of + PsDictionary m -> do + H.lookup "scheme" m `shouldBe` Just (PsString "basic") + H.lookup "principal" m `shouldBe` Just (PsString "neo4j") + H.lookup "credentials" m `shouldBe` Just (PsString "password") + _ -> expectationFailure "expected dictionary" + _ -> expectationFailure "expected structure" + + it "HELLO with Routing includes routing dict" $ do + let hello = Hello (UserAgent "bolty" "2.0") None Routing False + let ps = toPs (RHello hello) + case ps of + PsStructure 0x01 fields -> case V.head fields of + PsDictionary m -> case H.lookup "routing" m of + Just (PsDictionary r) -> H.null r `shouldBe` True + _ -> expectationFailure "expected routing dictionary" + _ -> expectationFailure "expected dictionary" + _ -> expectationFailure "expected structure" + + it "GOODBYE produces empty structure with tag 0x02" $ do + let ps = toPs RGoodbye + case ps of + PsStructure 0x02 fields -> V.null fields `shouldBe` True + _ -> expectationFailure "expected structure with tag 0x02" + + it "RESET produces empty structure with tag 0x0F" $ do + let ps = toPs RReset + case ps of + PsStructure 0x0F fields -> V.null fields `shouldBe` True + _ -> expectationFailure "expected structure with tag 0x0F" + + it "HELLO round-trips through PackStream" $ do + let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "pass") NoRouting False + let request = RHello hello + let ps = toPs request + let encoded = pack ps + case unpack encoded of + Left e -> expectationFailure $ "decode failed: " <> T.unpack e + Right ps' -> do + -- Verify the decoded Ps matches + ps' `shouldBe` ps + + it "SUCCESS response round-trips through PackStream" $ do + let meta = H.fromList [("server", PsString "Neo4j/5.0.0"), ("connection_id", PsString "bolt-1")] + let response = RSuccess meta + let ps = toPs response + let encoded = pack ps + case unpack encoded of + Left e -> expectationFailure $ "decode failed: " <> T.unpack e + Right ps' -> ps' `shouldBe` ps + + +-- = Structure round-trip tests + +structureRoundTripTests :: TopSpec +structureRoundTripTests = describe "Structure round-trips" $ do + + it "round-trips Node" $ do + let node = Node 42 (V.fromList ["Person", "Employee"]) + (H.fromList [("name", PsString "Alice"), ("age", PsInteger 30)]) + "4:abc:42" + (fromPs (toPs node) :: R.Result Node) `shouldBe` R.Success node + + it "round-trips Relationship" $ do + let rel = Relationship 1 10 20 "KNOWS" + (H.fromList [("since", PsInteger 2020)]) + "4:abc:1" "4:abc:10" "4:abc:20" + (fromPs (toPs rel) :: R.Result Relationship) `shouldBe` R.Success rel + + it "round-trips UnboundRelationship" $ do + let urel = UnboundRelationship 5 "LIKES" H.empty "4:abc:5" + (fromPs (toPs urel) :: R.Result UnboundRelationship) `shouldBe` R.Success urel + + it "round-trips Path" $ do + let n1 = Node 1 (V.singleton "A") H.empty "4:abc:1" + let n2 = Node 2 (V.singleton "B") H.empty "4:abc:2" + let r1 = UnboundRelationship 10 "TO" H.empty "4:abc:10" + let path = Path (V.fromList [n1, n2]) (V.singleton r1) (V.fromList [1, 1]) + (fromPs (toPs path) :: R.Result Path) `shouldBe` R.Success path + + it "round-trips Date" $ do + let d = Date 19738 + (fromPs (toPs d) :: R.Result Date) `shouldBe` R.Success d + + it "round-trips Time" $ do + let t = Time 43200000000000 3600 + (fromPs (toPs t) :: R.Result Time) `shouldBe` R.Success t + + it "round-trips LocalTime" $ do + let lt = LocalTime 43200000000000 + (fromPs (toPs lt) :: R.Result LocalTime) `shouldBe` R.Success lt + + it "round-trips DateTime" $ do + let dt = DateTime 1705312800 0 3600 + (fromPs (toPs dt) :: R.Result DateTime) `shouldBe` R.Success dt + + it "round-trips DateTimeZoneId" $ do + let dtz = DateTimeZoneId 1705312800 0 "Europe/Paris" + (fromPs (toPs dtz) :: R.Result DateTimeZoneId) `shouldBe` R.Success dtz + + it "round-trips LocalDateTime" $ do + let ldt = LocalDateTime 1705312800 500000000 + (fromPs (toPs ldt) :: R.Result LocalDateTime) `shouldBe` R.Success ldt + + it "round-trips Duration" $ do + let dur = Duration 14 10 3600 0 + (fromPs (toPs dur) :: R.Result Duration) `shouldBe` R.Success dur + + it "round-trips Point2D" $ do + let p = Point2D 7203 1.5 2.5 + (fromPs (toPs p) :: R.Result Point2D) `shouldBe` R.Success p + + it "round-trips Point3D" $ do + let p = Point3D 9157 1.0 2.0 3.0 + (fromPs (toPs p) :: R.Result Point3D) `shouldBe` R.Success p + + it "Node structure dispatches correctly through Bolt" $ do + let node = Node 42 (V.fromList ["Person"]) + (H.fromList [("name", PsString "Alice")]) + "4:abc:42" + let ps = toPs node + case (fromPs ps :: R.Result Bolt) of + R.Success (BoltNode n) -> n `shouldBe` node + other -> expectationFailure $ "Expected BoltNode, got: " <> show other + + it "Date structure dispatches correctly through Bolt" $ do + let d = Date 19738 + let ps = toPs d + case (fromPs ps :: R.Result Bolt) of + R.Success (BoltDate d') -> d' `shouldBe` d + other -> expectationFailure $ "Expected BoltDate, got: " <> show other + + it "Point2D structure dispatches correctly through Bolt" $ do + let p = Point2D 7203 1.5 2.5 + let ps = toPs p + case (fromPs ps :: R.Result Bolt) of + R.Success (BoltPoint2D p') -> p' `shouldBe` p + other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other + + +-- = Pool config tests + +poolConfigTests :: TopSpec +poolConfigTests = describe "Pool config" $ do + it "defaultPoolConfig has maxPingRetries == 1" $ do + maxPingRetries defaultPoolConfig `shouldBe` 1 + + it "defaultPoolConfig has maxConnections == 10" $ do + maxConnections defaultPoolConfig `shouldBe` 10 + + it "defaultPoolConfig has idleTimeout == 60" $ do + idleTimeout defaultPoolConfig `shouldBe` 60 + + +-- = Retry config and isTransient tests + +retryTests :: TopSpec +retryTests = describe "Retry logic" $ do + it "isTransient returns True for transient error" $ do + isTransient (ResponseErrorFailure "Neo.TransientError.Transaction.DeadlockDetected" "deadlock") `shouldBe` True + + it "isTransient returns True for other transient error codes" $ do + isTransient (ResponseErrorFailure "Neo.TransientError.General.MemoryPoolOutOfMemoryError" "oom") `shouldBe` True + + it "isTransient returns False for client error" $ do + isTransient (ResponseErrorFailure "Neo.ClientError.Statement.SyntaxError" "bad syntax") `shouldBe` False + + it "isTransient returns False for database error" $ do + isTransient (ResponseErrorFailure "Neo.DatabaseError.General.UnknownError" "unknown") `shouldBe` False + + it "isTransient returns False for ResetFailed" $ do + isTransient ResetFailed `shouldBe` False + + it "isTransient returns False for AuthentificationFailed" $ do + isTransient AuthentificationFailed `shouldBe` False + + it "defaultRetryConfig has expected values" $ do + maxRetries defaultRetryConfig `shouldBe` 5 + initialDelay defaultRetryConfig `shouldBe` 200_000 + maxDelay defaultRetryConfig `shouldBe` 5_000_000 + + +-- = Route serialization tests + +routeTests :: TopSpec +routeTests = describe "Route serialization" $ do + + it "Route serializes to 3-field structure with tag 0x66" $ do + let route = Route H.empty V.empty (RouteExtra Nothing Nothing) + let ps = toPs (RRoute route) + case ps of + PsStructure 0x66 fields -> V.length fields `shouldBe` 3 + _ -> expectationFailure $ "expected structure with tag 0x66, got: " <> show ps + + it "Route with address and bookmarks round-trips through PackStream" $ do + let route = Route (H.singleton "address" (PsString "localhost:7687")) + (V.fromList ["bk1", "bk2"]) + (RouteExtra (Just "neo4j") Nothing) + let ps = toPs (RRoute route) + let encoded = pack ps + case unpack encoded of + Left e -> expectationFailure $ "decode failed: " <> T.unpack e + Right ps' -> ps' `shouldBe` ps + + it "Route round-trips through Request fromPs/toPs" $ do + let route = Route H.empty V.empty (RouteExtra Nothing Nothing) + let request = RRoute route + let ps = toPs request + case (fromPs ps :: R.Result Request) of + R.Success (RRoute Route{routing, bookmarks, extra = _}) -> do + H.null routing `shouldBe` True + V.null bookmarks `shouldBe` True + R.Success _other -> expectationFailure $ "expected RRoute, got other Request" + R.Error e -> expectationFailure $ "fromPs failed: " <> T.unpack e + + +-- = Routing table parsing tests + +routingTableTests :: TopSpec +routingTableTests = describe "parseRoutingTable" $ do + + it "parses valid response with multiple roles" $ do + let meta = H.singleton "rt" $ PsDictionary $ H.fromList + [ ("ttl", PsInteger (toPSInteger (300 :: Int64))) + , ("db", PsString "neo4j") + , ("servers", PsList $ V.fromList + [ PsDictionary $ H.fromList + [ ("role", PsString "ROUTE") + , ("addresses", PsList $ V.fromList [PsString "r1:7687", PsString "r2:7687"]) + ] + , PsDictionary $ H.fromList + [ ("role", PsString "READ") + , ("addresses", PsList $ V.fromList [PsString "rd1:7687"]) + ] + , PsDictionary $ H.fromList + [ ("role", PsString "WRITE") + , ("addresses", PsList $ V.fromList [PsString "wr1:7687"]) + ] + ]) + ] + case parseRoutingTable meta of + Right RoutingTable{ttl, db, routers, readers, writers} -> do + ttl `shouldBe` 300 + db `shouldBe` "neo4j" + V.length routers `shouldBe` 2 + V.length readers `shouldBe` 1 + V.length writers `shouldBe` 1 + V.head routers `shouldBe` "r1:7687" + V.head readers `shouldBe` "rd1:7687" + V.head writers `shouldBe` "wr1:7687" + Left e -> expectationFailure $ "parse failed: " <> T.unpack e + + it "fails on missing rt key" $ do + let meta = H.singleton "other" (PsString "value") + case parseRoutingTable meta of + Left _ -> pure () + Right _ -> expectationFailure "expected failure for missing rt key" + + it "fails on missing servers key" $ do + let meta = H.singleton "rt" $ PsDictionary $ H.fromList + [ ("ttl", PsInteger (toPSInteger (300 :: Int64))) + , ("db", PsString "neo4j") + ] + case parseRoutingTable meta of + Left _ -> pure () + Right _ -> expectationFailure "expected failure for missing servers key" + + it "handles CE single-server-all-roles response" $ do + let addr = PsString "localhost:7687" + let meta = H.singleton "rt" $ PsDictionary $ H.fromList + [ ("ttl", PsInteger (toPSInteger (300 :: Int64))) + , ("db", PsString "neo4j") + , ("servers", PsList $ V.fromList + [ PsDictionary $ H.fromList + [ ("role", PsString "ROUTE"), ("addresses", PsList $ V.singleton addr) ] + , PsDictionary $ H.fromList + [ ("role", PsString "READ"), ("addresses", PsList $ V.singleton addr) ] + , PsDictionary $ H.fromList + [ ("role", PsString "WRITE"), ("addresses", PsList $ V.singleton addr) ] + ]) + ] + case parseRoutingTable meta of + Right RoutingTable{routers, readers, writers} -> do + V.length routers `shouldBe` 1 + V.length readers `shouldBe` 1 + V.length writers `shouldBe` 1 + V.head routers `shouldBe` "localhost:7687" + V.head readers `shouldBe` "localhost:7687" + V.head writers `shouldBe` "localhost:7687" + Left e -> expectationFailure $ "parse failed: " <> T.unpack e + + it "isTransient returns True for RoutingTableError" $ do + isTransient (RoutingTableError "test") `shouldBe` True + + +-- = parseAddress tests + +parseAddressTests :: TopSpec +parseAddressTests = describe "parseAddress" $ do + + it "parses host:port" $ do + parseAddress "localhost:7687" `shouldBe` ("localhost", 7687) + + it "parses host with non-default port" $ do + parseAddress "db.example.com:9999" `shouldBe` ("db.example.com", 9999) + + it "falls back to 7687 for missing port" $ do + parseAddress "localhost" `shouldBe` ("localhost", 7687) + + it "falls back to 7687 for non-numeric port" $ do + parseAddress "localhost:abc" `shouldBe` ("localhost", 7687) + + it "parses port 0" $ do + parseAddress "host:0" `shouldBe` ("host", 0) + + +-- = RoutingPoolConfig tests + +routingPoolConfigTests :: TopSpec +routingPoolConfigTests = describe "RoutingPool config" $ do + + it "defaultRoutingPoolConfig has refreshBuffer == 10" $ do + refreshBuffer defaultRoutingPoolConfig `shouldBe` 10 + + it "defaultRoutingPoolConfig has routingDb == Nothing" $ do + routingDb defaultRoutingPoolConfig `shouldBe` Nothing + + it "defaultRoutingPoolConfig uses defaultPoolConfig" $ do + maxConnections (poolConfig defaultRoutingPoolConfig) `shouldBe` 10 + + +-- = Routing error detection tests + +routingErrorTests :: TopSpec +routingErrorTests = describe "Routing error detection" $ do + + it "isRoutingError returns True for NotALeader" $ do + isRoutingError (ResponseErrorFailure "Neo.ClientError.Cluster.NotALeader" "not a leader") `shouldBe` True + + it "isRoutingError returns True for ForbiddenOnReadOnlyDatabase" $ do + isRoutingError (ResponseErrorFailure "Neo.ClientError.General.ForbiddenOnReadOnlyDatabase" "read only") `shouldBe` True + + it "isRoutingError returns False for transient error" $ do + isRoutingError (ResponseErrorFailure "Neo.TransientError.Transaction.DeadlockDetected" "deadlock") `shouldBe` False + + it "isRoutingError returns False for syntax error" $ do + isRoutingError (ResponseErrorFailure "Neo.ClientError.Statement.SyntaxError" "bad syntax") `shouldBe` False + + it "isRoutingError returns False for non-response errors" $ do + isRoutingError ResetFailed `shouldBe` False + isRoutingError (RoutingTableError "test") `shouldBe` False + + +-- = Bookmark management tests + +bookmarkTests :: TopSpec +bookmarkTests = describe "Bookmark management" $ do + + it "new BookmarkManager starts empty" $ do + bm <- liftIO $ newBookmarkManager [] + bms <- liftIO $ getBookmarks bm + bms `shouldBe` [] + + it "new BookmarkManager with initial bookmarks" $ do + bm <- liftIO $ newBookmarkManager ["bm1", "bm2"] + bms <- liftIO $ getBookmarks bm + bms `shouldBe` ["bm1", "bm2"] + + it "updateBookmark replaces bookmarks with single new one" $ do + bm <- liftIO $ newBookmarkManager ["old1", "old2"] + liftIO $ updateBookmark bm "new1" + bms <- liftIO $ getBookmarks bm + bms `shouldBe` ["new1"] + + it "updateBookmark on empty manager adds bookmark" $ do + bm <- liftIO $ newBookmarkManager [] + liftIO $ updateBookmark bm "bm1" + bms <- liftIO $ getBookmarks bm + bms `shouldBe` ["bm1"] + + it "successive updateBookmark calls keep only the latest" $ do + bm <- liftIO $ newBookmarkManager [] + liftIO $ updateBookmark bm "bm1" + liftIO $ updateBookmark bm "bm2" + bms <- liftIO $ getBookmarks bm + bms `shouldBe` ["bm2"] + + it "extractBookmark extracts bookmark from metadata" $ do + let meta = H.fromList [("bookmark", PsString "FB:kcwQ123")] + extractBookmark meta `shouldBe` Just "FB:kcwQ123" + + it "extractBookmark returns Nothing when no bookmark" $ do + let meta = H.fromList [("server", PsString "Neo4j/5.0")] + extractBookmark meta `shouldBe` Nothing + + it "extractBookmark returns Nothing for non-string bookmark" $ do + let meta = H.fromList [("bookmark", PsInteger 42)] + extractBookmark meta `shouldBe` Nothing + + +-- = Session config tests + +sessionConfigTests :: TopSpec +sessionConfigTests = describe "Session config" $ do + + it "defaultSessionConfig has default database" $ do + database defaultSessionConfig `shouldBe` Nothing + + it "defaultSessionConfig has WriteAccess mode" $ do + accessMode defaultSessionConfig `shouldBe` WriteAccess + + it "defaultSessionConfig has no initial bookmarks" $ do + sessionBookmarks defaultSessionConfig `shouldBe` [] + + +-- = Validation strategy tests + +validationStrategyTests :: TopSpec +validationStrategyTests = describe "Validation strategy" $ do + + it "defaultPoolConfig uses PingIfIdle 30" $ do + validationStrategy defaultPoolConfig `shouldBe` PingIfIdle 30 + + it "AlwaysPing /= NeverPing" $ do + (AlwaysPing == NeverPing) `shouldBe` False + + it "PingIfIdle 30 == PingIfIdle 30" $ do + (PingIfIdle 30 == PingIfIdle 30) `shouldBe` True + + it "PingIfIdle 10 /= PingIfIdle 60" $ do + (PingIfIdle 10 == PingIfIdle 60) `shouldBe` False + + it "show AlwaysPing" $ do + show AlwaysPing `shouldBe` "AlwaysPing" + + it "show NeverPing" $ do + show NeverPing `shouldBe` "NeverPing" + + it "show PingIfIdle 30" $ do + show (PingIfIdle 30) `shouldBe` "PingIfIdle 30" + + +-- = Version 5.x validation tests + +version5xTests :: TopSpec +version5xTests = describe "Version 5.x validation" $ do + + it "accepts version 5.1" $ do + let cfg = (def :: Config) { versions = [Version 1 5] } + case validateConfig cfg of + Val.Failure errs -> expectationFailure $ "Version 5.1 should validate: " <> show errs + Val.Success _ -> pure () + + it "accepts version 5.2" $ do + let cfg = (def :: Config) { versions = [Version 2 5] } + case validateConfig cfg of + Val.Failure errs -> expectationFailure $ "Version 5.2 should validate: " <> show errs + Val.Success _ -> pure () + + it "accepts version 5.3" $ do + let cfg = (def :: Config) { versions = [Version 3 5] } + case validateConfig cfg of + Val.Failure errs -> expectationFailure $ "Version 5.3 should validate: " <> show errs + Val.Success _ -> pure () + + it "accepts version 5.4" $ do + let cfg = (def :: Config) { versions = [Version 4 5] } + case validateConfig cfg of + Val.Failure errs -> expectationFailure $ "Version 5.4 should validate: " <> show errs + Val.Success _ -> pure () + + it "rejects version 5.5" $ do + let cfg = (def :: Config) { versions = [Version 5 5] } + case validateConfig cfg of + Val.Failure _ -> pure () + Val.Success _ -> expectationFailure "Version 5.5 should be rejected" + + it "default config offers 5.4 and 4.4" $ do + let cfg = def :: Config + case validateConfig cfg of + Val.Failure errs -> expectationFailure $ "Default config should validate: " <> show errs + Val.Success _ -> do + let vs = versions cfg + -- Should contain 5.4 as highest and 4.4 as fallback + any (\(Version m mj) -> mj == 5 && m == 4) vs `shouldBe` True + any (\(Version m mj) -> mj == 4 && m == 4) vs `shouldBe` True + + +-- = LOGON/LOGOFF/TELEMETRY message tests + +logonLogoffTests :: TopSpec +logonLogoffTests = describe "LOGON/LOGOFF/TELEMETRY message serialization" $ do + + it "LOGON serializes to structure with tag 0x6A and auth dictionary" $ do + let logonReq = RLogon (Logon (Basic "neo4j" "password")) + let ps = toPs logonReq + case ps of + PsStructure 0x6A fields -> do + V.length fields `shouldBe` 1 + case V.head fields of + PsDictionary m -> do + H.lookup "scheme" m `shouldBe` Just (PsString "basic") + H.lookup "principal" m `shouldBe` Just (PsString "neo4j") + H.lookup "credentials" m `shouldBe` Just (PsString "password") + _ -> expectationFailure "expected dictionary as LOGON field" + _ -> expectationFailure $ "expected structure with tag 0x6A, got: " <> show ps + + it "LOGON round-trips through PackStream" $ do + let logonReq = RLogon (Logon (Basic "neo4j" "pass")) + let ps = toPs logonReq + let encoded = pack ps + case unpack encoded of + Left e -> expectationFailure $ "decode failed: " <> T.unpack e + Right ps' -> ps' `shouldBe` ps + + it "LOGOFF serializes to empty structure with tag 0x6B" $ do + let ps = toPs RLogoff + case ps of + PsStructure 0x6B fields -> V.null fields `shouldBe` True + _ -> expectationFailure $ "expected structure with tag 0x6B, got: " <> show ps + + it "TELEMETRY serializes to structure with tag 0x54 and integer field" $ do + let ps = toPs (RTelemetry ManagedTransactions) + case ps of + PsStructure 0x54 fields -> do + V.length fields `shouldBe` 1 + case V.head fields of + PsInteger _ -> pure () + _ -> expectationFailure "expected integer field for TELEMETRY" + _ -> expectationFailure $ "expected structure with tag 0x54, got: " <> show ps + + it "TELEMETRY round-trips through PackStream" $ do + let telReq = RTelemetry ExplicitTransactions + let ps = toPs telReq + let encoded = pack ps + case unpack encoded of + Left e -> expectationFailure $ "decode failed: " <> T.unpack e + Right ps' -> ps' `shouldBe` ps + + it "TelemetryApi values encode to correct integers" $ do + let check api expected = case toPs (RTelemetry api) of + PsStructure 0x54 fields -> case V.head fields of + PsInteger n -> case fromPs (PsInteger n) :: R.Result Int64 of + R.Success v -> v `shouldBe` expected + R.Error e -> expectationFailure $ "fromPs failed: " <> T.unpack e + _ -> expectationFailure "expected integer" + _ -> expectationFailure "expected structure" + check ManagedTransactions 0 + check ExplicitTransactions 1 + check ImplicitTransactions 2 + check ExecuteQuery 3 + + +-- = Version helper tests + +versionHelperTests :: TopSpec +versionHelperTests = describe "Version helpers" $ do + let mkVersion :: Word32 -> Word32 -> Word32 + mkVersion major minor = major .|. (minor `shiftL` 8) + + it "supportsLogonLogoff returns True for 5.1" $ do + supportsLogonLogoff (mkVersion 5 1) `shouldBe` True + + it "supportsLogonLogoff returns True for 5.4" $ do + supportsLogonLogoff (mkVersion 5 4) `shouldBe` True + + it "supportsLogonLogoff returns False for 5.0" $ do + supportsLogonLogoff (mkVersion 5 0) `shouldBe` False + + it "supportsLogonLogoff returns False for 4.4" $ do + supportsLogonLogoff (mkVersion 4 4) `shouldBe` False + + it "supportsTelemetry returns True for 5.4" $ do + supportsTelemetry (mkVersion 5 4) `shouldBe` True + + it "supportsTelemetry returns False for 5.3" $ do + supportsTelemetry (mkVersion 5 3) `shouldBe` False + + it "supportsTelemetry returns False for 5.0" $ do + supportsTelemetry (mkVersion 5 0) `shouldBe` False + + it "supportsTelemetry returns False for 4.4" $ do + supportsTelemetry (mkVersion 4 4) `shouldBe` False + + +-- = Query logging config tests + +loggingConfigTests :: TopSpec +loggingConfigTests = describe "Query logging config" $ do + it "default config has queryLogger = Nothing" $ do + case queryLogger (def :: Config) of + Nothing -> pure () + Just _ -> expectationFailure "Expected queryLogger to be Nothing" + + it "config with logger validates" $ do + let cfg = (def :: Config) { queryLogger = Just (\_ _ -> pure ()) } + case validateConfig cfg of + Val.Failure errs -> expectationFailure $ "Config with logger should validate: " <> show errs + Val.Success _ -> pure () + + it "QueryLog can be constructed" $ do + let ql = QueryLog + { qlCypher = "RETURN 1" + , qlParameters = H.empty + , qlRowCount = 1 + , qlServerFirst = 5 + , qlServerLast = 10 + , qlClientTime = 15.0 + } + qlCypher ql `shouldBe` "RETURN 1" + qlRowCount ql `shouldBe` 1 + qlServerFirst ql `shouldBe` 5 + qlServerLast ql `shouldBe` 10 + qlClientTime ql `shouldBe` 15.0 + + +-- = Notification parsing tests + +notificationTests :: TopSpec +notificationTests = describe "Notification parsing" $ do + + it "parses Nothing to empty vector" $ do + V.length (parseNotifications Nothing) `shouldBe` 0 + + it "parses empty list to empty vector" $ do + V.length (parseNotifications (Just (PsList V.empty))) `shouldBe` 0 + + it "parses non-list to empty vector" $ do + V.length (parseNotifications (Just (PsString "bad"))) `shouldBe` 0 + + it "parses a valid notification" $ do + let notif = PsDictionary $ H.fromList + [ ("code", PsString "Neo.ClientNotification.Statement.CartesianProduct") + , ("title", PsString "Cartesian product warning") + , ("description", PsString "This query builds a cartesian product") + , ("severity", PsString "WARNING") + , ("category", PsString "PERFORMANCE") + , ("position", PsDictionary $ H.fromList + [ ("offset", PsInteger 0) + , ("line", PsInteger 1) + , ("column", PsInteger 1) + ]) + ] + let result = parseNotifications (Just (PsList (V.singleton notif))) + V.length result `shouldBe` 1 + let n = V.head result + nCode n `shouldBe` "Neo.ClientNotification.Statement.CartesianProduct" + nTitle n `shouldBe` "Cartesian product warning" + nDescription n `shouldBe` "This query builds a cartesian product" + nSeverity n `shouldBe` SevWarning + nCategory n `shouldBe` "PERFORMANCE" + nPosition n `shouldBe` Just (Position 0 1 1) + + it "parses INFORMATION severity" $ do + let notif = PsDictionary $ H.fromList + [ ("code", PsString "Neo.ClientNotification.Statement.FeatureDeprecationWarning") + , ("title", PsString "Deprecated") + , ("description", PsString "Use newer syntax") + , ("severity", PsString "INFORMATION") + , ("category", PsString "DEPRECATION") + ] + let result = parseNotifications (Just (PsList (V.singleton notif))) + V.length result `shouldBe` 1 + nSeverity (V.head result) `shouldBe` SevInformation + nPosition (V.head result) `shouldBe` Nothing + + it "handles missing optional fields" $ do + let notif = PsDictionary $ H.fromList + [ ("code", PsString "Neo.Test.Code") + , ("title", PsString "Test") + , ("description", PsString "Test desc") + ] + let result = parseNotifications (Just (PsList (V.singleton notif))) + V.length result `shouldBe` 1 + nCategory (V.head result) `shouldBe` "" + nPosition (V.head result) `shouldBe` Nothing + + it "skips malformed entries in list" $ do + let good = PsDictionary $ H.fromList + [ ("code", PsString "Neo.Test.Code") + , ("title", PsString "Test") + , ("description", PsString "Test desc") + ] + let bad = PsString "not a notification" + let result = parseNotifications (Just (PsList (V.fromList [good, bad, good]))) + V.length result `shouldBe` 2 + + it "default config has notificationHandler = Nothing" $ do + case notificationHandler (def :: Config) of + Nothing -> pure () + Just _ -> expectationFailure "Expected notificationHandler to be Nothing" + + +-- = Query stats parsing tests + +statsTests :: TopSpec +statsTests = describe "Query stats parsing" $ do + + it "parses Nothing to Nothing" $ do + parseStats Nothing `shouldBe` Nothing + + it "parses non-dictionary to Nothing" $ do + parseStats (Just (PsString "bad")) `shouldBe` Nothing + + it "parses full stats dictionary" $ do + let statsPs = PsDictionary $ H.fromList + [ ("nodes-created", PsInteger 2) + , ("nodes-deleted", PsInteger 1) + , ("relationships-created", PsInteger 3) + , ("relationships-deleted", PsInteger 0) + , ("properties-set", PsInteger 5) + , ("labels-added", PsInteger 2) + , ("labels-removed", PsInteger 0) + , ("indexes-added", PsInteger 0) + , ("indexes-removed", PsInteger 0) + , ("constraints-added", PsInteger 0) + , ("constraints-removed", PsInteger 0) + , ("contains-updates", PsBoolean True) + , ("contains-system-updates", PsBoolean False) + , ("system-updates", PsInteger 0) + ] + case parseStats (Just statsPs) of + Nothing -> expectationFailure "Expected Just QueryStats" + Just qs -> do + nodesCreated qs `shouldBe` 2 + nodesDeleted qs `shouldBe` 1 + relationshipsCreated qs `shouldBe` 3 + propertiesSet qs `shouldBe` 5 + labelsAdded qs `shouldBe` 2 + containsUpdates qs `shouldBe` True + containsSystemUpdates qs `shouldBe` False + + it "missing keys default to 0/False" $ do + let statsPs = PsDictionary $ H.fromList + [ ("nodes-created", PsInteger 1) + , ("contains-updates", PsBoolean True) + ] + case parseStats (Just statsPs) of + Nothing -> expectationFailure "Expected Just QueryStats" + Just qs -> do + nodesCreated qs `shouldBe` 1 + nodesDeleted qs `shouldBe` 0 + relationshipsCreated qs `shouldBe` 0 + labelsAdded qs `shouldBe` 0 + containsUpdates qs `shouldBe` True + containsSystemUpdates qs `shouldBe` False + systemUpdates qs `shouldBe` 0 + + it "parses empty dictionary" $ do + case parseStats (Just (PsDictionary H.empty)) of + Nothing -> expectationFailure "Expected Just QueryStats" + Just qs -> do + nodesCreated qs `shouldBe` 0 + containsUpdates qs `shouldBe` False + + +-- = Plan/Profile parsing tests + +planTests :: TopSpec +planTests = describe "Plan parsing" $ do + + it "parsePlan Nothing returns Nothing" $ do + parsePlan Nothing `shouldBe` Nothing + + it "parsePlan non-dictionary returns Nothing" $ do + parsePlan (Just (PsString "bad")) `shouldBe` Nothing + + it "parsePlan parses a simple plan node" $ do + let planPs = PsDictionary $ H.fromList + [ ("operatorType", PsString "ProduceResults@neo4j") + , ("args", PsDictionary $ H.fromList + [ ("planner-impl", PsString "IDP") + , ("runtime", PsString "SLOTTED") + ]) + , ("identifiers", PsList $ V.fromList [PsString "n"]) + , ("estimatedRows", PsFloat 10.0) + , ("children", PsList V.empty) + ] + case parsePlan (Just planPs) of + Nothing -> expectationFailure "Expected Just PlanNode" + Just pn -> do + pnOperatorType pn `shouldBe` "ProduceResults@neo4j" + H.size (pnArguments pn) `shouldBe` 2 + pnIdentifiers pn `shouldBe` V.fromList ["n"] + pnEstimatedRows pn `shouldBe` 10.0 + V.length (pnChildren pn) `shouldBe` 0 + + it "parsePlan parses nested children" $ do + let child = PsDictionary $ H.fromList + [ ("operatorType", PsString "AllNodesScan@neo4j") + , ("identifiers", PsList $ V.fromList [PsString "n"]) + , ("estimatedRows", PsFloat 100.0) + , ("children", PsList V.empty) + ] + let root = PsDictionary $ H.fromList + [ ("operatorType", PsString "ProduceResults@neo4j") + , ("identifiers", PsList $ V.fromList [PsString "n"]) + , ("estimatedRows", PsFloat 100.0) + , ("children", PsList $ V.fromList [child]) + ] + case parsePlan (Just root) of + Nothing -> expectationFailure "Expected Just PlanNode" + Just pn -> do + V.length (pnChildren pn) `shouldBe` 1 + pnOperatorType (V.head (pnChildren pn)) `shouldBe` "AllNodesScan@neo4j" + + it "parsePlan requires operatorType" $ do + let planPs = PsDictionary $ H.fromList + [ ("identifiers", PsList V.empty) + , ("estimatedRows", PsFloat 1.0) + ] + parsePlan (Just planPs) `shouldBe` Nothing + + it "parsePlan defaults missing optional fields" $ do + let planPs = PsDictionary $ H.fromList + [ ("operatorType", PsString "NodeByLabelScan") + ] + case parsePlan (Just planPs) of + Nothing -> expectationFailure "Expected Just PlanNode" + Just pn -> do + pnArguments pn `shouldBe` H.empty + pnIdentifiers pn `shouldBe` V.empty + pnEstimatedRows pn `shouldBe` 0.0 + V.length (pnChildren pn) `shouldBe` 0 + + it "parsePlan skips malformed children" $ do + let good = PsDictionary $ H.fromList + [ ("operatorType", PsString "Scan") ] + let bad = PsString "not a plan node" + let root = PsDictionary $ H.fromList + [ ("operatorType", PsString "Root") + , ("children", PsList $ V.fromList [good, bad, good]) + ] + case parsePlan (Just root) of + Nothing -> expectationFailure "Expected Just PlanNode" + Just pn -> V.length (pnChildren pn) `shouldBe` 2 + + +profileTests :: TopSpec +profileTests = describe "Profile parsing" $ do + + it "parseProfile Nothing returns Nothing" $ do + parseProfile Nothing `shouldBe` Nothing + + it "parseProfile non-dictionary returns Nothing" $ do + parseProfile (Just (PsString "bad")) `shouldBe` Nothing + + it "parseProfile parses a full profile node" $ do + let profPs = PsDictionary $ H.fromList + [ ("operatorType", PsString "ProduceResults@neo4j") + , ("args", PsDictionary $ H.fromList + [ ("runtime", PsString "SLOTTED") ]) + , ("identifiers", PsList $ V.fromList [PsString "n"]) + , ("estimatedRows", PsFloat 10.0) + , ("dbHits", PsInteger 42) + , ("rows", PsInteger 10) + , ("pageCacheHits", PsInteger 5) + , ("pageCacheMisses", PsInteger 2) + , ("time", PsInteger 1234) + , ("children", PsList V.empty) + ] + case parseProfile (Just profPs) of + Nothing -> expectationFailure "Expected Just ProfileNode" + Just pr -> do + prOperatorType pr `shouldBe` "ProduceResults@neo4j" + prDbHits pr `shouldBe` 42 + prRows pr `shouldBe` 10 + prPageCacheHits pr `shouldBe` 5 + prPageCacheMisses pr `shouldBe` 2 + prTime pr `shouldBe` 1234 + prEstimatedRows pr `shouldBe` 10.0 + V.length (prChildren pr) `shouldBe` 0 + + it "parseProfile parses nested children" $ do + let child = PsDictionary $ H.fromList + [ ("operatorType", PsString "AllNodesScan@neo4j") + , ("identifiers", PsList $ V.fromList [PsString "n"]) + , ("estimatedRows", PsFloat 100.0) + , ("dbHits", PsInteger 101) + , ("rows", PsInteger 100) + , ("children", PsList V.empty) + ] + let root = PsDictionary $ H.fromList + [ ("operatorType", PsString "ProduceResults@neo4j") + , ("identifiers", PsList $ V.fromList [PsString "n"]) + , ("estimatedRows", PsFloat 100.0) + , ("dbHits", PsInteger 0) + , ("rows", PsInteger 100) + , ("children", PsList $ V.fromList [child]) + ] + case parseProfile (Just root) of + Nothing -> expectationFailure "Expected Just ProfileNode" + Just pr -> do + V.length (prChildren pr) `shouldBe` 1 + prDbHits (V.head (prChildren pr)) `shouldBe` 101 + + it "parseProfile requires operatorType" $ do + let profPs = PsDictionary $ H.fromList + [ ("dbHits", PsInteger 5) + , ("rows", PsInteger 1) + ] + parseProfile (Just profPs) `shouldBe` Nothing + + it "parseProfile defaults missing numeric fields to 0" $ do + let profPs = PsDictionary $ H.fromList + [ ("operatorType", PsString "NodeByLabelScan") + ] + case parseProfile (Just profPs) of + Nothing -> expectationFailure "Expected Just ProfileNode" + Just pr -> do + prDbHits pr `shouldBe` 0 + prRows pr `shouldBe` 0 + prPageCacheHits pr `shouldBe` 0 + prPageCacheMisses pr `shouldBe` 0 + prTime pr `shouldBe` 0 + prEstimatedRows pr `shouldBe` 0.0 + + it "parseProfile handles estimatedRows as integer" $ do + let profPs = PsDictionary $ H.fromList + [ ("operatorType", PsString "Scan") + , ("estimatedRows", PsInteger 42) + ] + case parseProfile (Just profPs) of + Nothing -> expectationFailure "Expected Just ProfileNode" + Just pr -> prEstimatedRows pr `shouldBe` 42.0 + + +-- = Server hint tests + +serverHintTests :: TopSpec +serverHintTests = describe "Server hint config" $ do + + it "defaultPoolConfig idleTimeout is 60" $ do + idleTimeout defaultPoolConfig `shouldBe` 60 + + +-- = Decode tests + +decodeTests :: TopSpec +decodeTests = describe "Record decoding" $ do + let columns = V.fromList ["name", "age", "active"] + let record = V.fromList [BoltString "Alice", BoltInteger 30, BoltBoolean True] + + it "bool decodes BoltBoolean True" $ do + runDecode Database.Bolty.bool (BoltBoolean True) `shouldBe` Right True + + it "bool rejects BoltString" $ do + case runDecode Database.Bolty.bool (BoltString "x") of + Left (TypeMismatch _ _) -> pure () + other -> expectationFailure $ "Expected TypeMismatch, got: " <> show other + + it "int decodes BoltInteger" $ do + case runDecode Database.Bolty.int (BoltInteger 42) of + Right n -> n `shouldBe` 42 + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "int64 decodes BoltInteger to Int64" $ do + runDecode int64 (BoltInteger 42) `shouldBe` Right (42 :: Int64) + + it "text decodes BoltString" $ do + runDecode Database.Bolty.text (BoltString "hello") `shouldBe` Right "hello" + + it "float decodes BoltFloat" $ do + runDecode Database.Bolty.float (BoltFloat 3.14) `shouldBe` Right 3.14 + + it "nullable text decodes BoltNull to Nothing" $ do + runDecode (nullable Database.Bolty.text) BoltNull `shouldBe` Right Nothing + + it "nullable text decodes BoltString to Just" $ do + runDecode (nullable Database.Bolty.text) (BoltString "x") `shouldBe` Right (Just "x") + + it "list int decodes BoltList" $ do + let v = BoltList $ V.fromList [BoltInteger 1, BoltInteger 2, BoltInteger 3] + case runDecode (Database.Bolty.list Database.Bolty.int) v of + Right xs -> V.length xs `shouldBe` 3 + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "column 0 text decodes first field" $ do + decodeRow (column 0 Database.Bolty.text) columns record `shouldBe` Right "Alice" + + it "column 5 on 3-element record gives IndexOutOfBounds" $ do + decodeRow (column 5 Database.Bolty.text) columns record `shouldBe` Left (IndexOutOfBounds 5 3) + + it "field 'name' text finds column by name" $ do + decodeRow (field "name" Database.Bolty.text) columns record `shouldBe` Right "Alice" + + it "field 'missing' gives MissingField" $ do + decodeRow (field "missing" Database.Bolty.text) columns record `shouldBe` Left (MissingField "missing") + + it "decodeRows maps decoder over multiple records" $ do + let recs = V.fromList [record, record] + case decodeRows (field "name" Database.Bolty.text) columns recs of + Right vs -> vs `shouldBe` V.fromList ["Alice", "Alice"] + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "RowDecoder Applicative composes" $ do + let decoder = (,) <$> field "name" Database.Bolty.text <*> field "age" int64 + decodeRow decoder columns record `shouldBe` Right ("Alice", 30) + + +-- = sigLocalDateTime regression test + +sigLocalDateTimeTest :: TopSpec +sigLocalDateTimeTest = describe "sigLocalDateTime tag" $ do + it "sigLocalDateTime is 0x64 (not 0x66)" $ do + sigLocalDateTime `shouldBe` 0x64 + + +-- = psToBolt / boltToPs tests + +psToBoltTests :: TopSpec +psToBoltTests = describe "psToBolt" $ do + + it "converts Node PsStructure to BoltNode" $ do + let n = Node 1 (V.singleton "Person") (H.singleton "name" (PsString "Alice")) "4:abc:1" + case psToBolt (toPs n) of + BoltNode n' -> n' `shouldBe` n + other -> expectationFailure $ "Expected BoltNode, got: " <> show other + + it "converts Relationship PsStructure to BoltRelationship" $ do + let r = Relationship 1 10 20 "KNOWS" H.empty "4:abc:1" "4:abc:10" "4:abc:20" + case psToBolt (toPs r) of + BoltRelationship r' -> r' `shouldBe` r + other -> expectationFailure $ "Expected BoltRelationship, got: " <> show other + + it "converts UnboundRelationship PsStructure to BoltUnboundRelationship" $ do + let ur = UnboundRelationship 5 "LIKES" H.empty "4:abc:5" + case psToBolt (toPs ur) of + BoltUnboundRelationship ur' -> ur' `shouldBe` ur + other -> expectationFailure $ "Expected BoltUnboundRelationship, got: " <> show other + + it "converts Path PsStructure to BoltPath" $ do + let n1 = Node 1 (V.singleton "A") H.empty "4:abc:1" + let n2 = Node 2 (V.singleton "B") H.empty "4:abc:2" + let r1 = UnboundRelationship 10 "TO" H.empty "4:abc:10" + let p = Path (V.fromList [n1, n2]) (V.singleton r1) (V.fromList [1, 1]) + case psToBolt (toPs p) of + BoltPath p' -> p' `shouldBe` p + other -> expectationFailure $ "Expected BoltPath, got: " <> show other + + it "converts Date PsStructure to BoltDate" $ do + let d = Date 19738 + case psToBolt (toPs d) of + BoltDate d' -> d' `shouldBe` d + other -> expectationFailure $ "Expected BoltDate, got: " <> show other + + it "converts Time PsStructure to BoltTime" $ do + let t = Time 43200000000000 3600 + case psToBolt (toPs t) of + BoltTime t' -> t' `shouldBe` t + other -> expectationFailure $ "Expected BoltTime, got: " <> show other + + it "converts LocalTime PsStructure to BoltLocalTime" $ do + let lt = LocalTime 43200000000000 + case psToBolt (toPs lt) of + BoltLocalTime lt' -> lt' `shouldBe` lt + other -> expectationFailure $ "Expected BoltLocalTime, got: " <> show other + + it "converts DateTime PsStructure to BoltDateTime" $ do + let dt = DateTime 1705312800 0 3600 + case psToBolt (toPs dt) of + BoltDateTime dt' -> dt' `shouldBe` dt + other -> expectationFailure $ "Expected BoltDateTime, got: " <> show other + + it "converts DateTimeZoneId PsStructure to BoltDateTimeZoneId" $ do + let dtz = DateTimeZoneId 1705312800 0 "Europe/Paris" + case psToBolt (toPs dtz) of + BoltDateTimeZoneId dtz' -> dtz' `shouldBe` dtz + other -> expectationFailure $ "Expected BoltDateTimeZoneId, got: " <> show other + + it "converts LocalDateTime PsStructure to BoltLocalDateTime" $ do + let ldt = LocalDateTime 1705312800 500000000 + case psToBolt (toPs ldt) of + BoltLocalDateTime ldt' -> ldt' `shouldBe` ldt + other -> expectationFailure $ "Expected BoltLocalDateTime, got: " <> show other + + it "converts Duration PsStructure to BoltDuration" $ do + let dur = Duration 14 10 3600 0 + case psToBolt (toPs dur) of + BoltDuration dur' -> dur' `shouldBe` dur + other -> expectationFailure $ "Expected BoltDuration, got: " <> show other + + it "converts Point2D PsStructure to BoltPoint2D" $ do + let p = Point2D 7203 1.5 2.5 + case psToBolt (toPs p) of + BoltPoint2D p' -> p' `shouldBe` p + other -> expectationFailure $ "Expected BoltPoint2D, got: " <> show other + + it "converts Point3D PsStructure to BoltPoint3D" $ do + let p = Point3D 9157 1.0 2.0 3.0 + case psToBolt (toPs p) of + BoltPoint3D p' -> p' `shouldBe` p + other -> expectationFailure $ "Expected BoltPoint3D, got: " <> show other + + it "unknown structure tag returns BoltNull" $ do + psToBolt (PsStructure 0xFF V.empty) `shouldBe` BoltNull + + +boltToPsRoundTripTests :: TopSpec +boltToPsRoundTripTests = describe "boltToPs round-trips" $ do + + it "round-trips BoltNode" $ do + let n = Node 1 (V.singleton "Person") (H.singleton "name" (PsString "Alice")) "4:abc:1" + let bolt = BoltNode n + psToBolt (boltToPs bolt) `shouldBe` bolt + + it "round-trips BoltRelationship" $ do + let r = Relationship 1 10 20 "KNOWS" H.empty "4:abc:1" "4:abc:10" "4:abc:20" + let bolt = BoltRelationship r + psToBolt (boltToPs bolt) `shouldBe` bolt + + it "round-trips BoltDate" $ do + let bolt = BoltDate (Date 19738) + psToBolt (boltToPs bolt) `shouldBe` bolt + + it "round-trips BoltDateTime" $ do + let bolt = BoltDateTime (DateTime 1705312800 0 3600) + psToBolt (boltToPs bolt) `shouldBe` bolt + + it "round-trips BoltLocalDateTime" $ do + let bolt = BoltLocalDateTime (LocalDateTime 1705312800 500000000) + psToBolt (boltToPs bolt) `shouldBe` bolt + + it "round-trips BoltDuration" $ do + let bolt = BoltDuration (Duration 14 10 3600 0) + psToBolt (boltToPs bolt) `shouldBe` bolt + + it "round-trips BoltPoint2D" $ do + let bolt = BoltPoint2D (Point2D 7203 1.5 2.5) + psToBolt (boltToPs bolt) `shouldBe` bolt + + it "round-trips BoltPoint3D" $ do + let bolt = BoltPoint3D (Point3D 9157 1.0 2.0 3.0) + psToBolt (boltToPs bolt) `shouldBe` bolt + + +-- = patch_bolt tests + +patchBoltTests :: TopSpec +patchBoltTests = describe "patch_bolt in HELLO" $ do + + it "HELLO with patchBolt=True includes patch_bolt key" $ do + let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "pass") NoRouting True + let ps = toPs (RHello hello) + case ps of + PsStructure 0x01 fields -> case V.head fields of + PsDictionary m -> case H.lookup "patch_bolt" m of + Just (PsList v) -> V.toList v `shouldBe` [PsString "utc"] + _ -> expectationFailure "expected patch_bolt list" + _ -> expectationFailure "expected dictionary" + _ -> expectationFailure "expected structure" + + it "HELLO with patchBolt=False omits patch_bolt key" $ do + let hello = Hello (UserAgent "bolty" "2.0") (Basic "neo4j" "pass") NoRouting False + let ps = toPs (RHello hello) + case ps of + PsStructure 0x01 fields -> case V.head fields of + PsDictionary m -> H.member "patch_bolt" m `shouldBe` False + _ -> expectationFailure "expected dictionary" + _ -> expectationFailure "expected structure" + + +-- = ResultSet tests + +resultSetTests :: TopSpec +resultSetTests = describe "ResultSet" $ do + let cols = V.fromList ["name", "age"] + let mkRecord n a = V.fromList [BoltString n, BoltInteger a] + let rs = ResultSet cols $ V.fromList + [ mkRecord "Alice" 30 + , mkRecord "Bob" 25 + , mkRecord "Carol" 35 + ] + + describe "decodeResultSet" $ do + it "decodes 2-column, 3-row result" $ do + let decoder = (,) <$> field "name" Database.Bolty.text <*> field "age" int64 + decodeResultSet decoder rs `shouldBe` + Right (V.fromList [("Alice", 30), ("Bob", 25), ("Carol", 35)]) + + it "returns empty vector for empty result set" $ do + let emptyRs = ResultSet cols V.empty + decodeResultSet (field "name" Database.Bolty.text) emptyRs `shouldBe` Right V.empty + + it "returns MissingField for absent column" $ do + decodeResultSet (field "email" Database.Bolty.text) rs `shouldBe` Left (MissingField "email") + + it "returns TypeMismatch for wrong type" $ do + case decodeResultSet (field "name" int64) rs of + Left (TypeMismatch _ _) -> pure () + other -> expectationFailure $ "Expected TypeMismatch, got: " <> show other + + describe "groupByField" $ do + let groupCols = V.fromList ["parent", "child"] + let mkGroupRec p c = V.fromList [p, c] + + it "groups 4 rows into 2 groups of 2" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec (BoltString "A") (BoltString "c1") + , mkGroupRec (BoltString "A") (BoltString "c2") + , mkGroupRec (BoltString "B") (BoltString "c3") + , mkGroupRec (BoltString "B") (BoltString "c4") + ] + case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of + Right groups -> do + V.length groups `shouldBe` 2 + fst (groups V.! 0) `shouldBe` "A" + V.length (RS.records (snd (groups V.! 0))) `shouldBe` 2 + fst (groups V.! 1) `shouldBe` "B" + V.length (RS.records (snd (groups V.! 1))) `shouldBe` 2 + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "skips NULL keys (does not break consecutive run)" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec (BoltString "A") (BoltString "c1") + , mkGroupRec BoltNull (BoltString "c2") + , mkGroupRec (BoltString "A") (BoltString "c3") + ] + case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of + Right groups -> do + -- NULL rows are simply dropped; "A" remains current group + V.length groups `shouldBe` 1 + fst (groups V.! 0) `shouldBe` "A" + V.length (RS.records (snd (groups V.! 0))) `shouldBe` 2 + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "NULL between different keys does not merge them" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec (BoltString "A") (BoltString "c1") + , mkGroupRec BoltNull (BoltString "c2") + , mkGroupRec (BoltString "B") (BoltString "c3") + ] + case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of + Right groups -> do + V.length groups `shouldBe` 2 + fst (groups V.! 0) `shouldBe` "A" + fst (groups V.! 1) `shouldBe` "B" + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "consecutive grouping: [A, A, B, A] produces 3 groups" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec (BoltString "A") (BoltString "c1") + , mkGroupRec (BoltString "A") (BoltString "c2") + , mkGroupRec (BoltString "B") (BoltString "c3") + , mkGroupRec (BoltString "A") (BoltString "c4") + ] + case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of + Right groups -> do + V.length groups `shouldBe` 3 + fst (groups V.! 0) `shouldBe` "A" + fst (groups V.! 1) `shouldBe` "B" + fst (groups V.! 2) `shouldBe` "A" + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "returns empty vector for empty result set" $ do + let emptyRs = ResultSet groupCols V.empty + groupByField (field "parent" (nullable Database.Bolty.text)) emptyRs `shouldBe` Right V.empty + + it "returns empty vector when all keys are NULL" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec BoltNull (BoltString "c1") + , mkGroupRec BoltNull (BoltString "c2") + ] + groupByField (field "parent" (nullable Database.Bolty.text)) groupRs `shouldBe` Right V.empty + + it "single record produces one group" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec (BoltString "A") (BoltString "c1") ] + case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of + Right groups -> do + V.length groups `shouldBe` 1 + fst (groups V.! 0) `shouldBe` "A" + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "propagates decode error" $ do + case groupByField (field "missing" (nullable Database.Bolty.text)) rs of + Left (MissingField "missing") -> pure () + other -> expectationFailure $ "Expected MissingField, got: " <> show other + + it "preserves field names in sub-ResultSets" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec (BoltString "A") (BoltString "c1") + , mkGroupRec (BoltString "A") (BoltString "c2") + ] + case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of + Right groups -> do + V.length groups `shouldBe` 1 + RS.fields (snd (groups V.! 0)) `shouldBe` groupCols + Left e -> expectationFailure $ "Expected success, got: " <> show e + + it "full pipeline: group then decode within groups" $ do + let groupRs = ResultSet groupCols $ V.fromList + [ mkGroupRec (BoltString "A") (BoltString "c1") + , mkGroupRec (BoltString "A") (BoltString "c2") + , mkGroupRec (BoltString "B") (BoltString "c3") + ] + case groupByField (field "parent" (nullable Database.Bolty.text)) groupRs of + Right groups -> do + V.length groups `shouldBe` 2 + let childDecoder = field "child" Database.Bolty.text + case decodeResultSet childDecoder (snd (groups V.! 0)) of + Right children -> children `shouldBe` V.fromList ["c1", "c2"] + Left e -> expectationFailure $ "Decode failed: " <> show e + case decodeResultSet childDecoder (snd (groups V.! 1)) of + Right children -> children `shouldBe` V.fromList ["c3"] + Left e -> expectationFailure $ "Decode failed: " <> show e + Left e -> expectationFailure $ "Expected success, got: " <> show e + + +-- = Main + +main :: IO () +main = runSandwichWithCommandLineArgs defaultOptions $ do + configTests + versionTests + version5xTests + extractorTests + recordTests + packstreamRoundTripTests + messageTests + logonLogoffTests + structureRoundTripTests + poolConfigTests + retryTests + routeTests + routingTableTests + parseAddressTests + routingPoolConfigTests + routingErrorTests + bookmarkTests + sessionConfigTests + validationStrategyTests + versionHelperTests + loggingConfigTests + notificationTests + statsTests + planTests + profileTests + serverHintTests + decodeTests + sigLocalDateTimeTest + psToBoltTests + boltToPsRoundTripTests + patchBoltTests + resultSetTests