packstream-bolt (empty) → 0.1.0.0
raw patch · 18 files changed
+2171/−0 lines, 18 filesdep +basedep +bytestringdep +deepseqsetup-changed
Dependencies added: base, bytestring, deepseq, hashable, int-cast, persist, text, text-show, time, unordered-containers, vector
Files
- LICENSE +52/−0
- Setup.hs +2/−0
- changelog.md +15/−0
- packstream-bolt.cabal +92/−0
- readme.md +130/−0
- src/Compat/Binary.hs +164/−0
- src/Compat/Prelude.hs +17/−0
- src/Data/PackStream.hs +91/−0
- src/Data/PackStream/Assoc.hs +19/−0
- src/Data/PackStream/Generic.hs +151/−0
- src/Data/PackStream/Get.hs +34/−0
- src/Data/PackStream/Get/Internal.hs +165/−0
- src/Data/PackStream/Integer.hs +249/−0
- src/Data/PackStream/Ps.hs +425/−0
- src/Data/PackStream/Put.hs +102/−0
- src/Data/PackStream/Result.hs +36/−0
- src/Data/PackStream/Tags.hs +299/−0
- src/Data/PackStream/Timestamp.hs +128/−0
+ LICENSE view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,15 @@+# Changelog for `packstream`++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+- PackStream binary format encoding and decoding+- Support for all PackStream types: Null, Bool, Integer, Float, String, Bytes, List, Map, Structure+- Persist-based serialization backend+- TextShow instances for all types
+ packstream-bolt.cabal view
@@ -0,0 +1,92 @@+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: packstream-bolt+version: 0.1.0.0+synopsis: PackStream binary serialization format+description: Implementation of the PackStream binary serialization format,+ used as the wire format by Neo4j's BOLT protocol.+ Similar to MessagePack but with additional structure types.+category: Database, Serialization+homepage: https://github.com/philippedev101/packstream#readme+bug-reports: https://github.com/philippedev101/packstream/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/packstream++flag dev+ description: Turn on -Werror and other developer flags+ manual: True+ default: False++library+ exposed-modules:+ Data.PackStream+ Data.PackStream.Ps+ Data.PackStream.Result+ Data.PackStream.Tags+ Data.PackStream.Timestamp+ Compat.Binary+ Compat.Prelude+ Data.PackStream.Assoc+ Data.PackStream.Generic+ Data.PackStream.Get+ Data.PackStream.Get.Internal+ Data.PackStream.Integer+ Data.PackStream.Put+ other-modules:+ Paths_packstream_bolt+ 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-overlapping-patterns -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe+ build-depends:+ base >=4.18 && <5+ , bytestring >=0.11 && <0.13+ , deepseq >=1.4 && <1.6+ , hashable >=1.4 && <1.6+ , int-cast ==0.2.*+ , persist ==1.0.*+ , text >=2.0 && <2.2+ , text-show >=3.10 && <3.12+ , time >=1.11 && <1.15+ , unordered-containers ==0.2.*+ , vector ==0.13.*+ default-language: GHC2021+ if flag(dev)+ ghc-options: -Werror
+ readme.md view
@@ -0,0 +1,130 @@+# packstream++Haskell implementation of the [PackStream](https://neo4j.com/docs/bolt/current/packstream/) binary serialization format, used as the wire format by Neo4j's BOLT protocol.++PackStream is similar to [MessagePack](https://msgpack.org/) but adds a `Structure` type for encoding typed graph objects (nodes, relationships, temporal values, spatial points, etc.).++> **Note:** Most users should depend on [bolty](https://github.com/philippedev101/bolty) instead, which provides a full Neo4j driver. This package is useful if you need to work with the PackStream wire format directly.++## Types++PackStream defines 9 value types, represented by the `Ps` algebraic data type:++| PackStream type | Haskell constructor | Description |+|---|---|---|+| Null | `PsNull` | Missing or empty value |+| Boolean | `PsBoolean !Bool` | True or false |+| Integer | `PsInteger !PSInteger` | Signed integer (up to 64-bit) |+| Float | `PsFloat !Double` | 64-bit IEEE 754 float |+| Bytes | `PsBytes !ByteString` | Raw byte array |+| String | `PsString !Text` | UTF-8 text |+| List | `PsList !(Vector Ps)` | Ordered collection |+| Dictionary | `PsDictionary !(HashMap Text Ps)` | Key-value map (text keys) |+| Structure | `PsStructure !Tag !(Vector Ps)` | Tagged composite (tag byte + positional fields) |++Integers use a variable-width encoding: values in `[-16, 127]` are encoded in a single byte (no tag), with `INT_8`, `INT_16`, `INT_32`, and `INT_64` for larger values.++## The `PackStream` type class++Convert between Haskell types and `Ps` values:++```haskell+class PackStream a where+ toPs :: a -> Ps -- encode to Ps AST+ toBinary :: a -> Put -- encode directly to wire format (optional, defaults to putPs . toPs)+ fromPs :: Ps -> Result a -- decode from Ps AST+```++Built-in instances exist for `Bool`, `Int`, `Int64`, `Word8`, `Word16`, `Word32`, `Double`, `Text`, `ByteString`, `Vector`, `HashMap Text`, `Maybe`, tuples (up to 9), and more.++## Quick start++### Encoding and decoding `Ps` values++```haskell+import Data.PackStream (pack, unpack)+import Data.PackStream.Ps (Ps(..))+import qualified Data.HashMap.Lazy as H++-- Encode a dictionary to binary+let ps = PsDictionary $ H.fromList+ [ ("name", PsString "Alice")+ , ("age", PsInteger 30)+ ]+let bytes = pack ps -- :: Lazy ByteString++-- Decode binary back to a Ps value+case unpack bytes of+ Right val -> print (val :: Ps)+ Left err -> putStrLn $ "Decode error: " <> show err+```++### Custom types++```haskell+import Data.PackStream.Ps (PackStream(..), Ps(..), (.:), withDictionary)+import Data.PackStream.Result (Result(..))+import qualified Data.HashMap.Lazy as H++data Person = Person { name :: Text, age :: Int64 }++instance PackStream Person where+ toPs Person{name, age} = PsDictionary $ H.fromList+ [ ("name", toPs name)+ , ("age", toPs age)+ ]++ fromPs = withDictionary "Person" $ \m -> do+ name <- m .: "name" -- uses (.:) operator for key lookup + decode+ age <- m .: "age"+ pure $ Person name age+```++### Structures++Structures are the key differentiator from MessagePack. They carry a tag byte identifying the type and positional fields:++```haskell+import Data.PackStream.Ps (Ps(..), PackStream(..))+import qualified Data.Vector as V++-- A Date structure (tag 0x44) with one field: days since Unix epoch+let date = PsStructure 0x44 (V.singleton (PsInteger 19737))++-- Define a custom structure type+data MyDate = MyDate { days :: Int64 }++instance PackStream MyDate where+ toPs (MyDate d) = PsStructure 0x44 (V.singleton (toPs d))+ fromPs (PsStructure 0x44 fs) | V.length fs == 1 = MyDate <$> fromPs (fs V.! 0)+ fromPs other = typeMismatch "MyDate" other+```++Neo4j uses structures for graph types (Node `0x4E`, Relationship `0x52`, Path `0x50`), temporal types (Date `0x44`, Time `0x54`, DateTime `0x49`, Duration `0x45`), and spatial types (Point2D `0x58`, Point3D `0x59`).++## Module structure++**Public API:**++- `Data.PackStream` — top-level `pack`/`unpack` + re-exports+- `Data.PackStream.Ps` — core `Ps` type, `PackStream` class, operators+- `Data.PackStream.Result` — `Result` type (`Success`/`Error`)+- `Data.PackStream.Tags` — wire format tag constants+- `Data.PackStream.Timestamp` — helpers for epoch-based temporal conversions++**Internal modules** (exposed but not part of the stable API):++- `Data.PackStream.Get` / `Data.PackStream.Get.Internal` — binary decoding primitives+- `Data.PackStream.Put` — binary encoding primitives+- `Data.PackStream.Integer` — variable-width integer encoding+- `Data.PackStream.Generic` — GHC.Generics-based deriving (experimental)+- `Data.PackStream.Assoc` — ordered association lists+- `Compat.Binary` / `Compat.Prelude` — compatibility wrappers++## Supported GHC versions++9.6.7, 9.8.4, 9.10.3, 9.12.3++## License++Apache-2.0
+ src/Compat/Binary.hs view
@@ -0,0 +1,164 @@+-- | Compat layer for serialization+--+-- Wraps @persist@ library+module Compat.Binary+ ( Persist(put, get)++ , runPut', runPut, runPutLazy, Put, PutM+ , runGet', runGet, Get++ , getWord64be, putWord64be+ , getWord32be, putWord32be+ , getWord16be, putWord16be+ , getWord8 , putWord8++ , getInt64be, putInt64be+ , getInt32be, putInt32be+ , getInt16be, putInt16be+ , getInt8 , putInt8++ , getFloat64be, putFloat64be++ , getByteString, putByteString+ ) where++import Compat.Prelude++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Kind (Type)+import qualified Data.Text as T++import Data.Persist (Persist(put, get), Get)+import qualified Data.Persist as P+import GHC.Float (castDoubleToWord64, castWord64ToDouble)++-- | The serialization monad (alias for @persist@'s 'P.Put' @()@).+type Put :: Type+type Put = P.Put ()++-- | The serialization monad parameterized by its result type.+type PutM :: Type -> Type+type PutM = P.Put++-- | Run a 'Put' action and return a strict 'BS.ByteString'.+runPut :: Put -> BS.ByteString+runPut = P.runPut++-- | Alias for 'runPut'.+runPut' :: Put -> BS.ByteString+runPut' = P.runPut++-- | Run a 'Put' action and return a lazy 'BL.ByteString'.+runPutLazy :: Put -> BL.ByteString+runPutLazy = P.runPutLazy++-- | Run a 'Get' parser on a strict 'BS.ByteString'.+runGet' :: BS.ByteString -> Get a -> Either T.Text a+runGet' bs g = case P.runGet g bs of+ Left e -> Left (T.pack e)+ Right x -> Right x++-- | Run a 'Get' parser on a lazy 'BL.ByteString'.+runGet :: BL.ByteString -> Get a -> Either T.Text a+runGet bs g = runGet' (BL.toStrict bs) g++-- | Deserialize a single byte.+{-# INLINE getWord8 #-}+getWord8 :: Get Word8+getWord8 = P.get++-- | Serialize a single byte.+{-# INLINE putWord8 #-}+putWord8 :: Word8 -> Put+putWord8 = P.put++-- | Deserialize a big-endian 'Word16'.+{-# INLINE getWord16be #-}+getWord16be :: Get Word16+getWord16be = P.getBE++-- | Serialize a big-endian 'Word16'.+{-# INLINE putWord16be #-}+putWord16be :: Word16 -> Put+putWord16be = P.putBE++-- | Deserialize a big-endian 'Word32'.+{-# INLINE getWord32be #-}+getWord32be :: Get Word32+getWord32be = P.getBE++-- | Serialize a big-endian 'Word32'.+{-# INLINE putWord32be #-}+putWord32be :: Word32 -> Put+putWord32be = P.putBE++-- | Deserialize a big-endian 'Word64'.+{-# INLINE getWord64be #-}+getWord64be :: Get Word64+getWord64be = P.getBE++-- | Serialize a big-endian 'Word64'.+{-# INLINE putWord64be #-}+putWord64be :: Word64 -> Put+putWord64be = P.putBE++-- | Deserialize a signed 8-bit integer.+{-# INLINE getInt8 #-}+getInt8 :: Get Int8+getInt8 = intCastIso <$> P.get @Word8++-- | Deserialize a big-endian signed 16-bit integer.+{-# INLINE getInt16be #-}+getInt16be :: Get Int16+getInt16be = intCastIso <$> P.getBE @Word16++-- | Deserialize a big-endian signed 32-bit integer.+{-# INLINE getInt32be #-}+getInt32be :: Get Int32+getInt32be = intCastIso <$> P.getBE @Word32++-- | Deserialize a big-endian signed 64-bit integer.+{-# INLINE getInt64be #-}+getInt64be :: Get Int64+getInt64be = intCastIso <$> P.getBE @Word64++-- | Serialize a signed 8-bit integer.+{-# INLINE putInt8 #-}+putInt8 :: Int8 -> Put+putInt8 x = P.put (intCastIso x :: Word8)++-- | Serialize a big-endian signed 16-bit integer.+{-# INLINE putInt16be #-}+putInt16be :: Int16 -> Put+putInt16be x = P.putBE (intCastIso x :: Word16)++-- | Serialize a big-endian signed 32-bit integer.+{-# INLINE putInt32be #-}+putInt32be :: Int32 -> Put+putInt32be x = P.putBE (intCastIso x :: Word32)++-- | Serialize a big-endian signed 64-bit integer.+{-# INLINE putInt64be #-}+putInt64be :: Int64 -> Put+putInt64be x = P.putBE (intCastIso x :: Word64)++-- | Serialize a big-endian 64-bit IEEE 754 double.+{-# INLINE putFloat64be #-}+putFloat64be :: Double -> Put+putFloat64be x = P.putBE (castDoubleToWord64 x)++-- | Deserialize a big-endian 64-bit IEEE 754 double.+{-# INLINE getFloat64be #-}+getFloat64be :: Get Double+getFloat64be = castWord64ToDouble <$> P.getBE @Word64++-- | Deserialize exactly @n@ bytes into a strict 'BS.ByteString'.+{-# INLINE getByteString #-}+getByteString :: Int -> Get BS.ByteString+getByteString = P.getByteString++-- | Serialize a strict 'BS.ByteString' directly into the output.+{-# INLINE putByteString #-}+putByteString :: BS.ByteString -> Put+putByteString = P.putByteString
+ src/Compat/Prelude.hs view
@@ -0,0 +1,17 @@+-- | Common Prelude-ish module+module Compat.Prelude+ ( module X+ ) where++import Control.Applicative as X+import Control.DeepSeq as X (NFData (rnf))+import Control.Monad as X+import Data.Bits as X (complement, shiftL, shiftR, (.&.),+ (.|.))+import Data.Foldable as X (Foldable)+import Data.Int as X+import Data.IntCast as X+import Data.Traversable as X (Traversable)+import Data.Typeable as X (Typeable)+import Data.Word as X+import GHC.Generics as X (Generic)
+ src/Data/PackStream.hs view
@@ -0,0 +1,91 @@+-- | PackStream serialization: encode and decode Haskell values to\/from+-- the Neo4j PackStream binary format.+module Data.PackStream (+ -- * Simple interface to pack and unpack msgpack binary+ -- ** Lazy 'L.ByteString'+ pack, unpack,++ -- ** Strict 'L.ByteString'+ pack', unpack',++ lookupWithError, fromOneField,++ lookupMaybe, lookupMaybeError,++ -- * Re-export modules+ module Data.PackStream.Assoc,+ module Data.PackStream.Get,+ module Data.PackStream.Ps,+ module Data.PackStream.Put,+ module Data.PackStream.Result,+ ) where++import Compat.Binary (get, runGet, runGet', runPutLazy, runPut')+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T++import Data.PackStream.Assoc+import Data.PackStream.Get+import Data.PackStream.Ps+import Data.PackStream.Put+import Data.PackStream.Result+import Data.Vector as V+import Data.HashMap.Lazy as H++-- | Pack a Haskell value to PackStream binary.+pack :: PackStream a => a -> L.ByteString+pack = runPutLazy . toBinary++-- | Unpack PackStream binary to a Haskell value. If it fails, it returns 'Left' with an error message.+unpack :: PackStream a => L.ByteString -> Either T.Text a+unpack bs = do+ obj <- runGet bs get+ case fromPs obj of+ Success a -> Right a+ Error e -> Left e+++-- | Variant of 'pack' serializing to a strict 'ByteString'+pack' :: PackStream a => a -> S.ByteString+pack' = runPut' . toBinary++-- | Variant of 'unpack' serializing to a strict 'ByteString'+unpack' :: PackStream a => S.ByteString -> Either T.Text a+unpack' bs = do+ obj <- runGet' bs get+ case fromPs obj of+ Success a -> Right a+ Error e -> Left e++-- | Look up a key in a dictionary, returning a custom error if absent.+lookupWithError :: PackStream v => T.Text -> H.HashMap T.Text Ps -> T.Text -> Result v+lookupWithError key map err =+ case H.lookup key map of+ Nothing -> Error err+ Just val -> fromPs val++-- | Decode a single-field structure vector, applying the constructor on success.+fromOneField :: PackStream a => V.Vector Ps -> (a -> b) -> T.Text -> Result b+fromOneField fields constructor error =+ if V.length fields /= 1 then+ Error error+ else do+ arg <- fromPs $ V.unsafeHead fields+ Success $ constructor arg++-- | Look up an optional key in a dictionary, returning 'Nothing' if absent.+lookupMaybe :: PackStream v => T.Text -> HashMap T.Text Ps -> Result (Maybe v)+lookupMaybe key map =+ case H.lookup key map of+ Nothing -> Success Nothing+ Just val -> fmap Just $ fromPs val++-- | Look up a required key in a dictionary, returning 'Left' with an error if absent.+lookupMaybeError :: PackStream v => T.Text -> HashMap T.Text Ps -> Either T.Text v+lookupMaybeError key map =+ case H.lookup key map of+ Nothing -> Left $ "\"" <> key <> "\" could not be found"+ Just val -> case fromPs val of+ Error err -> Left err+ Success v -> Right v
+ src/Data/PackStream/Assoc.hs view
@@ -0,0 +1,19 @@+-- | Internal module. Not part of the public API.+module Data.PackStream.Assoc (+ Assoc(..)+ ) where++import Compat.Prelude++import Data.Kind (Type)++-- | Newtype wrapper for associative (dictionary-like) PackStream encoding.+--+-- not defined for general Functor for performance reason.+-- (ie. you would want to write custom instances for each type using specialized mapM-like functions)+type Assoc :: Type -> Type+type role Assoc representational+newtype Assoc a+ = Assoc { unAssoc :: a }+ deriving stock (Show, Read, Eq, Ord)+ deriving newtype NFData
+ src/Data/PackStream/Generic.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Internal module. Not part of the public API.+module Data.PackStream.Generic+ ( GPackStream+ , genericToPs+ , genericFromPs+ , GenericPackStream(..)+ ) where++import Compat.Prelude++import Data.Kind (Constraint, Type)+import GHC.Generics++import Data.PackStream.Ps+import Data.PackStream.Result++-- | Convert a value with a 'Generic' instance to a 'Ps' value.+genericToPs :: (Generic a, GPackStream (Rep a)) => a -> Ps+genericToPs = gToPs . from++-- | Decode a 'Ps' value into a type with a 'Generic' instance.+genericFromPs :: (Generic a, GPackStream (Rep a)) => Ps -> Result a+genericFromPs x = to <$> gFromPs x++-- | Newtype wrapper providing a 'PackStream' instance via 'GHC.Generics'.+type GenericPackStream :: Type -> Type+type role GenericPackStream representational+newtype GenericPackStream a = GenericPackStream a++instance (Generic a, GPackStream (Rep a)) => PackStream (GenericPackStream a) where+ toPs (GenericPackStream a) = genericToPs a+ fromPs a = GenericPackStream <$> genericFromPs a++-- | Generic representation class for PackStream encoding\/decoding.+type GPackStream :: (Type -> Type) -> Constraint+class GPackStream f where+ gToPs :: f a -> Ps+ gFromPs :: Ps -> Result (f a)++instance GPackStream U1 where+ gToPs U1 = PsNull+ gFromPs PsNull = return U1+ gFromPs _ = fail "invalid encoding for custom unit type"++instance (GPackStream a, GProdPack b) => GPackStream (a :*: b) where+ gToPs = toPs . prodToPs+ gFromPs = fromPs >=> prodFromPs++instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GPackStream (a :+: b) where+ gToPs = sumToPs 0 size+ where+ size = unTagged (sumSize :: Tagged (a :+: b) Int64)++ gFromPs = \case+ PsInteger code -> checkSumFromPs0 size (fromIntegral code)+ o -> fromPs o >>= uncurry (checkSumFromPs size)+ where+ size = unTagged (sumSize :: Tagged (a :+: b) Int64)++instance GPackStream a => GPackStream (M1 t c a) where+ gToPs (M1 x) = gToPs x+ gFromPs x = M1 <$> gFromPs x++instance PackStream a => GPackStream (K1 i a) where+ gToPs (K1 x) = toPs x+ gFromPs o = K1 <$> fromPs o+++-- Product type packing.++type GProdPack :: (Type -> Type) -> Constraint+class GProdPack f where+ prodToPs :: f a -> [Ps]+ prodFromPs :: [Ps] -> Result (f a)+++instance (GPackStream a, GProdPack b) => GProdPack (a :*: b) where+ prodToPs (a :*: b) = gToPs a : prodToPs b+ prodFromPs (a:b) = (:*:) <$> gFromPs a <*> prodFromPs b+ prodFromPs _ = fail "invalid encoding for product type"++instance GPackStream a => GProdPack (M1 t c a) where+ prodToPs (M1 x) = [gToPs x]+ prodFromPs [x] = M1 <$> gFromPs x+ prodFromPs _ = fail "invalid encoding for product type"+++-- Sum type packing.++checkSumFromPs0 :: GSumPack f => Int64 -> Int64 -> Result (f a)+checkSumFromPs0 size code+ | code < size = sumFromPs code size PsNull+ | otherwise = fail "invalid encoding for sum type"+++checkSumFromPs :: (GSumPack f) => Int64 -> Int64 -> Ps -> Result (f a)+checkSumFromPs size code x+ | code < size = sumFromPs code size x+ | otherwise = fail "invalid encoding for sum type"+++type GSumPack :: (Type -> Type) -> Constraint+class GSumPack f where+ sumToPs :: Int64 -> Int64 -> f a -> Ps+ sumFromPs :: Int64 -> Int64 -> Ps -> Result (f a)+++instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where+ sumToPs code size = \case+ L1 x -> sumToPs code sizeL x+ R1 x -> sumToPs (code + sizeL) sizeR x+ where+ sizeL = size `shiftR` 1+ sizeR = size - sizeL++ sumFromPs code size x+ | code < sizeL = L1 <$> sumFromPs code sizeL x+ | otherwise = R1 <$> sumFromPs (code - sizeL) sizeR x+ where+ sizeL = size `shiftR` 1+ sizeR = size - sizeL+++instance {-# OVERLAPPING #-} GSumPack (C1 c U1) where+ sumToPs code _ _ = toPs code+ sumFromPs _ _ = gFromPs+++instance {-# OVERLAPPABLE #-} GPackStream a => GSumPack (C1 c a) where+ sumToPs code _ x = toPs (code, gToPs x)+ sumFromPs _ _ = gFromPs+++-- Sum size.++type SumSize :: (Type -> Type) -> Constraint+class SumSize f where+ sumSize :: Tagged f Int64++type Tagged :: (Type -> Type) -> Type -> Type+type role Tagged phantom representational+newtype Tagged (s :: Type -> Type) b = Tagged { unTagged :: b }++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+ sumSize = Tagged $ unTagged (sumSize :: Tagged a Int64) ++ unTagged (sumSize :: Tagged b Int64)++instance SumSize (C1 c a) where+ sumSize = Tagged 1
+ src/Data/PackStream/Get.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE PatternSynonyms #-}++-- | Internal module. Not part of the public API.+module Data.PackStream.Get+ ( -- * Primitive decoders+ getNull+ , getBoolean+ , getFloat+ -- * Integer decoders+ , getInt+ , getInt64+ -- * Container decoders+ , getString+ , getBytes+ , getList+ , getDictionary+ ) where++import Compat.Binary+import Compat.Prelude+import Data.PackStream.Get.Internal+import Data.PackStream.Integer++-- | Deserialize an integer into an 'Int'+--+-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Int' type.+getInt :: Get Int+getInt = maybe (fail "integer out of Int range") pure =<< fromPSInteger <$> get++-- | Deserialize an integer into an 'Int64'+--+-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Int64' type.+getInt64 :: Get Int64+getInt64 = maybe (fail "integer out of Int64 range") pure =<< fromPSInteger <$> get
+ src/Data/PackStream/Get/Internal.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE PatternSynonyms #-}++-- | Internal module. Not part of the public API.+module Data.PackStream.Get.Internal+ ( getNull, tryNull+ , getBoolean, tryBoolean++ , getFloat, tryFloat++ , getString, tryString+ , getBytes, tryBytes++ , getList, tryList+ , getDictionary, tryDictionary+ , tryStructure+ ) where++import Compat.Prelude++import qualified Data.ByteString as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import qualified Data.HashMap.Lazy as H+import Data.Hashable (Hashable)++import Compat.Binary+import Data.PackStream.Tags++mkGet :: (Word8 -> t -> Get a -> Get b) -> t -> String -> Get b+mkGet tryT f n = do { tag <- getWord8; tryT tag f (fail n) }++-- | Decode a PackStream null value.+getNull :: Get ()+getNull = mkGet tryNull id "expected PackStream null"++-- | Decode a PackStream boolean value.+getBoolean :: Get Bool+getBoolean = mkGet tryBoolean id "expected PackStream boolean"++-- | Decode a PackStream 64-bit float.+getFloat :: Get Double+getFloat = mkGet tryFloat id "expected PackStream float"++-- | Decode a PackStream UTF-8 string.+getString :: Get T.Text+getString = mkGet tryString id "expected PackStream string"++-- | Decode a PackStream byte array.+getBytes :: Get S.ByteString+getBytes = mkGet tryBytes id "expected PackStream bytes"++-- | Decode a PackStream list using the given element decoder.+getList :: Get a -> Get (V.Vector a)+getList g = mkGet (tryList g) id "expected PackStream list"++-- | Decode a PackStream dictionary using the given key and value decoders.+getDictionary :: Hashable a => Get a -> Get b -> Get (H.HashMap a b)+getDictionary k v = mkGet (tryDictionary k v) id "Dictionary"+++----------------------------------------------------------------------------+-- primitives that take a tag as first argument++-- | Try to decode null given a tag byte; apply @f@ on success or fall through to the continuation.+{-# INLINE tryNull #-}+tryNull :: Word8 -> (() -> a) -> Get a -> Get a+tryNull tag f cont = case tag of+ TAG_Null -> pure $! f ()+ _ -> cont++-- | Try to decode a boolean given a tag byte; apply @f@ on success or fall through to the continuation.+{-# INLINE tryBoolean #-}+tryBoolean :: Word8 -> (Bool -> a) -> Get a -> Get a+tryBoolean tag f cont = case tag of+ TAG_false -> pure $! f False+ TAG_true -> pure $! f True+ _ -> cont+++-- | Try to decode a float given a tag byte; apply @f@ on success or fall through to the continuation.+{-# INLINE tryFloat #-}+tryFloat :: Word8 -> (Double -> a) -> Get a -> Get a+tryFloat tag f cont = case tag of+ TAG_Float -> f <$> getFloat64be+ _ -> cont++-- | Try to decode a string given a tag byte; apply @f@ on success or fall through to the continuation.+{-# INLINE tryString #-}+tryString :: Word8 -> (T.Text -> a) -> Get a -> Get a+tryString tag f cont = case tag of+ t | Just sz <- is_TAG_STRING_SHORT t -> cont' sz+ TAG_STRING_8 -> cont' . intCast =<< getWord8+ TAG_STRING_16 -> cont' . intCast =<< getWord16be+ TAG_STRING_32 -> cont' =<< getWord32be+ _ -> cont+ where+ cont' len = do+ len' <- fromSizeM "tryString: data exceeds capacity of ByteString/Text" len+ bs <- getByteString len'+ case T.decodeUtf8' bs of+ Left _ -> fail "tryString: invalid UTF-8 encoding"+ Right v -> pure $! f v++-- | Try to decode a byte array given a tag byte; apply @f@ on success or fall through to the continuation.+{-# INLINE tryBytes #-}+tryBytes :: Word8 -> (S.ByteString -> a) -> Get a -> Get a+tryBytes tag f cont = case tag of+ TAG_BYTE_ARRAY_8 -> cont' . intCast =<< getWord8+ TAG_BYTE_ARRAY_16 -> cont' . intCast =<< getWord16be+ TAG_BYTE_ARRAY_32 -> cont' =<< getWord32be+ _ -> cont+ where+ cont' len = do+ len' <- fromSizeM "tryBytes: data exceeds capacity of ByteString" len+ f <$> getByteString len'++-- | Try to decode a list given a tag byte; apply @f@ on success or fall through to the continuation.+{-# INLINE tryList #-}+tryList :: Get b -> Word8 -> (V.Vector b -> a) -> Get a -> Get a+tryList g tag f cont = case tag of+ t | Just sz <- is_TAG_LIST_SHORT t -> cont' sz+ TAG_LIST_8 -> cont' . intCast =<< getWord8+ TAG_LIST_16 -> cont' . intCast =<< getWord16be+ TAG_LIST_32 -> cont' =<< getWord32be+ _ -> cont+ where+ cont' len = do+ len' <- fromSizeM "tryList: data exceeds capacity of Vector" len+ f <$> V.replicateM len' g++-- | Try to decode a dictionary given a tag byte; apply @f@ on success or fall through to the continuation.+{-# INLINE tryDictionary #-}+tryDictionary :: Hashable k => Get k -> Get v -> Word8 -> (H.HashMap k v -> a) -> Get a -> Get a+tryDictionary k v tag f cont = case tag of+ t | Just sz <- is_TAG_DICTIONARY_SHORT t -> cont' sz+ TAG_DICTIONARY_8 -> cont' . intCast =<< getWord8+ TAG_DICTIONARY_16 -> cont' . intCast =<< getWord16be+ TAG_DICTIONARY_32 -> cont' =<< getWord32be+ _ -> cont+ where+ cont' len = do+ len' <- fromSizeM "tryDictionary: data exceeds capacity of Vector" len+ fmap (f . H.fromList) $ replicateM len' ((,) <$> k <*> v)+ -- fmap f $ V.replicateM len' ((,) <$> k <*> v)++-- {-# INLINE tryStructure #-}+-- tryStructure :: Word8 -> (H.HashMap T.Text Ps -> a) -> Get a -> Get a+-- tryStructure tag f cont = case tag of+-- TAG_float64 -> f <$> getFloat64be+-- _ -> cont++-- | Try to decode a structure given a tag byte; returns (structTag, fields) via @f@ on success.+{-# INLINE tryStructure #-}+tryStructure :: Get b -> Word8 -> ((Word8, V.Vector b) -> a) -> Get a -> Get a+tryStructure g tag f cont = case is_TAG_STRUCTURE tag of+ Just nfields -> do+ structTag <- getWord8+ nfields' <- fromSizeM "tryStructure: data exceeds capacity of Vector" nfields+ fields <- V.replicateM nfields' g+ pure $! f (structTag, fields)+ Nothing -> cont++fromSizeM :: String -> Word32 -> Get Int+fromSizeM label sz = maybe (fail label) pure (intCastMaybe sz)
+ src/Data/PackStream/Integer.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE PatternSynonyms #-}++-- | PackStream integer type covering the full @[-2^63, 2^64-1]@ range.+module Data.PackStream.Integer+ ( PSInteger+ , ToPSInteger(..)+ , FromPSInteger(..)+ , fromIntegerTry++ -- ** Internal helper+ , tryPSInteger+ ) where++import Compat.Prelude++import Control.Exception (ArithException (DivideByZero, Overflow, Underflow),+ throw)+import Data.Kind (Constraint, Type)+import TextShow+import TextShow.Generic+-- import GHC.Generics++import Compat.Binary+import Data.PackStream.Tags+++-- | Integer type that represents the value range of integral numbers in PackStream; i.e. \( \left[ -2^{63}, 2^{64}-1 \right] \).+-- In other words, `PSInteger` provides the union of the value ranges of `Word64` and `Int64`.+--+-- This type can be unboxed (i.e. via @{-# UNPACK #-}@).+type PSInteger :: Type+data PSInteger = PSInteger {-# UNPACK #-} !Int64+ deriving stock (Eq, Ord, Generic)+ deriving TextShow via FromGeneric (PSInteger)++-- NOTE: Internal invariant of 'PSInteger'+--+-- 'isW64' MUST be true IFF the value range of `Int64` cannot represent the semantic value of 'value'+--+-- Consequently, when 'isW64' is true, 'value :: Int64' must be negative.++-- NB: only valid if isW64 is true+-- toW64 :: Int64 -> Word64+-- toW64 = intCastIso++-- | Types that can be losslessly converted to 'PSInteger'.+type ToPSInteger :: Type -> Constraint+class ToPSInteger a where+ toPSInteger :: a -> PSInteger++instance ToPSInteger Int8 where toPSInteger i = PSInteger (intCast i)+instance ToPSInteger Int16 where toPSInteger i = PSInteger (intCast i)+instance ToPSInteger Int32 where toPSInteger i = PSInteger (intCast i)+instance ToPSInteger Int64 where toPSInteger = PSInteger +instance ToPSInteger Int where toPSInteger i = PSInteger (intCast i)++instance ToPSInteger Word8 where toPSInteger w = PSInteger (intCast w)+instance ToPSInteger Word16 where toPSInteger w = PSInteger (intCast w)+instance ToPSInteger Word32 where toPSInteger w = PSInteger (intCast w)+-- instance ToPSInteger Word64 where toPSInteger w = PSInteger (i<0) i where i = fromIntegral w+-- instance ToPSInteger Word where toPSInteger w = PSInteger (i<0) i where i = fromIntegral w++-- | Convert a 'PSInteger' value to something else if possible+--+-- The instances for 'FromPSInteger' are supposed to be consistent with the respective instances for 'ToPSInteger', e.g.+--+-- > fromPSInteger . toPSInteger == Just+--+type FromPSInteger :: Type -> Constraint+class FromPSInteger a where+ fromPSInteger :: PSInteger -> Maybe a++-- instance FromPSInteger Word where+-- fromPSInteger (PSInteger w) = intCastMaybe (toW64 w)+-- fromPSInteger (PSInteger i) = intCastMaybe i++-- instance FromPSInteger Word64 where+-- fromPSInteger (PSInteger w) = Just $! toW64 w+-- fromPSInteger (PSInteger i) = intCastMaybe i++instance FromPSInteger Word32 where+ fromPSInteger (PSInteger i) = intCastMaybe i++instance FromPSInteger Word16 where+ fromPSInteger (PSInteger i) = intCastMaybe i++instance FromPSInteger Word8 where+ fromPSInteger (PSInteger i) = intCastMaybe i++-----++instance FromPSInteger Int where+ fromPSInteger (PSInteger i) = intCastMaybe i++instance FromPSInteger Int64 where+ fromPSInteger (PSInteger i) = Just i++instance FromPSInteger Int32 where+ fromPSInteger (PSInteger i) = intCastMaybe i++instance FromPSInteger Int16 where+ fromPSInteger (PSInteger i) = intCastMaybe i++instance FromPSInteger Int8 where+ fromPSInteger (PSInteger i) = intCastMaybe i++----------------------------------------------------------------------------++instance Bounded PSInteger where+ minBound = PSInteger minBound+ maxBound = PSInteger (-1) -- this is why we can't autoderive++instance Enum PSInteger where+ toEnum i = PSInteger (toEnum i)+ -- fromEnum (PSInteger i) = fromEnum (toW64 i)+ fromEnum (PSInteger i) = fromEnum i++instance Show PSInteger where+ showsPrec p (PSInteger v) = showsPrec p v+ -- showsPrec p (PSInteger v) = showsPrec p (toW64 v)++instance Read PSInteger where+ readsPrec p s = [ (i, rest) | (j, rest) <- readsPrec p s, Right i <- [fromIntegerTry j] ]++instance NFData PSInteger where+ rnf (PSInteger _) = ()++-- | Try to convert 'Integer' into 'PSInteger'+--+-- Will return @'Left' 'Underflow'@ or @'Left' 'Overflow'@ respectively if out of range+fromIntegerTry :: Integer -> Either ArithException PSInteger+fromIntegerTry i+ | i < toInteger (minBound :: Int64) = Left Underflow+ | i <= toInteger (maxBound :: Int64) = Right $! PSInteger (fromInteger i)+ | i <= toInteger (maxBound :: Word64) = Right $! PSInteger (fromInteger i)+ | otherwise = Left Overflow++-- | This instance will throw the respective arithmetic 'Underflow' and 'Overflow' exception if the range of 'PSInteger' is exceeded.+instance Num PSInteger where+ fromInteger i = either throw id (fromIntegerTry i)++ negate (PSInteger v)+ | v == minBound = PSInteger v -- NB: for the usual twos complement integers, `negate minBound == minBound`+ | otherwise = PSInteger (negate v)+ negate (PSInteger v)+ | v == minBound = PSInteger v+ | otherwise = throw Underflow++ -- addition+ PSInteger 0 + x = x+ x + PSInteger 0 = x++ PSInteger _ + PSInteger _ = throw Overflow++ x@(PSInteger _) + y@(PSInteger _) = y + x+ PSInteger y + PSInteger x+ | y > 0 = if z < 0 then PSInteger z else throw Overflow+ | otherwise = PSInteger z+ where+ z = x + y++ PSInteger y + PSInteger x+ | x > 0, y > 0, z < 0 = PSInteger z+ | x < 0, y < 0, z > 0 = throw Underflow+ | otherwise = PSInteger z+ where+ z = x + y++ signum (PSInteger _) = PSInteger 1+ signum (PSInteger v) = PSInteger (signum v)++ abs v@(PSInteger _) = v+ abs v0@(PSInteger v)+ | v >= 0 = v0+ | v == minBound = PSInteger v+ | otherwise = PSInteger (negate v)+++ PSInteger _ * PSInteger _ = throw Overflow+ PSInteger 0 * PSInteger _ = PSInteger 0+ PSInteger 1 * x = x+ PSInteger _ * PSInteger 0 = PSInteger 0+ x * PSInteger 1 = x++ -- cheat+ x * y = fromInteger (toInteger x * toInteger y)++instance Real PSInteger where+ toRational (PSInteger i) = toRational i+ -- toRational (PSInteger u) = toRational (toW64 u)++instance Integral PSInteger where+ toInteger (PSInteger i) = toInteger i+ -- toInteger (PSInteger u) = toInteger (toW64 u)++ quotRem _ (PSInteger 0) = throw DivideByZero+ quotRem x (PSInteger 1) = (x, PSInteger 0)+ quotRem x (PSInteger (-1)) = (negate x, PSInteger 0)++ quotRem (PSInteger x) (PSInteger y)+ | (x',y') <- quotRem x y = (PSInteger x', PSInteger y')++ -- cheat+ quotRem x y+ | (x',y') <- quotRem (toInteger x) (toInteger y) = (fromInteger x', fromInteger y')++----------------------------------------------------------------------------++-- | This 'Persist' instance encodes\/decodes to\/from PackStream format+--+-- When serializing 'PSInteger's via 'get' the shortest encoding is+-- used. Moreoever, for non-negative integers the unsigned encoding is+-- always used.+--+-- Deserialization via 'get' will only fail if a non-integer PackStream tag is encountered.+--+instance Persist PSInteger where+ get = getPSInteger+ put = putPSInteger++-- | Serializes 'PSInteger' to PackStream+--+-- The shortest encoding is used to serialize+-- 'PSInteger's. Moreoever, for non-negative integers the unsigned+-- encoding is always used.+putPSInteger :: PSInteger -> Put+putPSInteger (PSInteger i)+ | i >= -16 && i <= 127 = putInt8 (fromIntegral i)+ | i >= -0x80 && i < 0x80 = putWord8 TAG_INT_8 >> putInt8 (fromIntegral i)+ | i >= -0x8000 && i < 0x8000 = putWord8 TAG_INT_16 >> putInt16be (fromIntegral i)+ | i >= -0x80000000 && i < 0x80000000 = putWord8 TAG_INT_32 >> putInt32be (fromIntegral i)+ | otherwise = putWord8 TAG_INT_64 >> putInt64be i++-- | Deserializes 'PSInteger' from PackStream+--+-- This operation will only fail if a non-integer PackStream tag is encountered.+getPSInteger :: Get PSInteger+getPSInteger = do { tag <- getWord8; tryPSInteger tag id (fail "expected PackStream int") }++-- | Try to decode a 'PSInteger' given a tag byte, applying @f@ on success or falling through to the continuation.+{-# INLINE tryPSInteger #-}+tryPSInteger :: Word8 -> (PSInteger -> a) -> Get a -> Get a+tryPSInteger tag' f cont = case tag' of+ c | is_TAG_TINY_INT c -> pure $! f $! toPSInteger (intCastIso c :: Int8)+ TAG_INT_8 -> f . toPSInteger <$> getInt8+ TAG_INT_16 -> f . toPSInteger <$> getInt16be+ TAG_INT_32 -> f . toPSInteger <$> getInt32be+ TAG_INT_64 -> f . toPSInteger <$> getInt64be+ _ -> cont
+ src/Data/PackStream/Ps.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE OverloadedLists #-}++-- | Core PackStream AST: the 'Ps' type and the 'PackStream' type class for+-- converting between Haskell types and PackStream values.+--+-- Specification: <https://neo4j.com/docs/bolt/current/packstream/>+module Data.PackStream.Ps+ ( -- * Core types+ Tag+ , Ps(..)+ , structFromDict+ , structureSingleton+ -- * PackStream class+ , PackStream(..)+ -- * Operators+ , (.:), (.=)+ -- * Accessors+ , getPs, putPs+ -- * Type matching+ , typeMismatch+ , withNull, withBoolean, withInteger, withFloat+ , withBytes, withString, withList, withDictionary+ ) where++import Compat.Prelude+import Prelude hiding (putStr)++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as SBS+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Typeable+import qualified Data.Vector as V+import qualified Data.HashMap.Lazy as H++import Data.PackStream.Get.Internal+import Data.PackStream.Integer+import Data.PackStream.Put+import Data.PackStream.Result+import Data.PackStream.Tags ()++import Compat.Binary+import TextShow (showt)+++-- | Structure tag byte identifying a PackStream structure type.+type Tag :: Type+type Tag = Word8++-- | A PackStream value. This is the intermediate AST used for serialization.+type Ps :: Type+data Ps+ = PsNull+ -- ^ missing or empty value+ | PsBoolean !Bool+ -- ^ true or false+ | PsInteger !PSInteger+ -- ^ signed 64-bit integer+ | PsFloat !Double+ -- ^ 64-bit floating point number+ | PsBytes !S.ByteString+ -- ^ byte array+ | PsString !T.Text+ -- ^ unicode text, UTF-8+ | PsList !(V.Vector Ps)+ -- ^ ordered collection of values+ | PsDictionary !(H.HashMap T.Text Ps)+ -- ^ collection of key-value entries (no order guaranteed)+ | PsStructure !Tag !(V.Vector Ps)+ -- ^ composite value with a type signature+ --+ -- fields being a Vector is a bit wasteful, but the spec demands it+ -- in practice there is always just 1 field, which is a dictionary+ -- Control messages all use dictionaries: https://neo4j.com/docs/bolt/current/bolt/message/#messages+ -- Datatypes all use dictionaries: https://neo4j.com/docs/bolt/current/bolt/structure-semantics/+ deriving stock (Show, Eq)++-- | Build a structure with a single dictionary field.+structFromDict :: Tag -> H.HashMap T.Text Ps -> Ps+structFromDict tag map = PsStructure tag $ V.singleton $ PsDictionary map++-- | Build a structure with exactly one field.+structureSingleton :: Tag -> Ps -> Ps+structureSingleton tag ps = PsStructure tag $ V.singleton ps+++-- | Look up a key in a 'PsDictionary' and decode the value.+(.:) :: PackStream a => Ps -> T.Text -> Result a+(PsDictionary m) .: key = case H.lookup key m of+ Nothing -> Error $ "missing key \"" <> key <> "\""+ Just v -> fromPs v+m .: _ = Error $ ("expected PsDictionary got " :: T.Text) <> (showt . typeOf $ m)++-- | Build a key-value pair for constructing a 'PsDictionary'.+(.=) :: PackStream a => T.Text -> a -> (Ps, Ps)+k .= a = (PsString k, toPs a)++instance NFData Ps where+ rnf obj = case obj of+ PsList a -> rnf a+ PsDictionary m -> rnf m+ _ -> ()++-- | Decode any PackStream value from the binary stream.+getPs :: Get Ps+getPs = do+ tag <- getWord8++ tryNull tag (const PsNull) $+ tryBoolean tag PsBoolean $+ tryPSInteger tag PsInteger $+ tryFloat tag PsFloat $+ tryString tag PsString $+ tryBytes tag PsBytes $+ tryList getPs tag PsList $+ tryDictionary getString getPs tag PsDictionary $+ tryStructure getPs tag (uncurry PsStructure) $+ fail ("getPs: internal error " ++ show tag) -- should never happen++-- | Encode any PackStream value to the binary stream.+putPs :: Ps -> Put+putPs = \case+ PsNull -> putNull+ PsBoolean b -> putBoolean b+ PsInteger n -> put n+ PsFloat d -> putFloat d+ PsString t -> putString t+ PsBytes b -> putBytes b+ PsList a -> putList putPs a+ PsDictionary m -> putDictionary putString putPs m+ PsStructure t fs -> do+ let nfields = V.length fs+ putWord8 (0xB0 .|. fromIntegral nfields)+ putWord8 t+ V.mapM_ putPs fs++-- | This 'Persist' instance encodes\/decodes to\/from PackStream format+instance Persist Ps where+ get = getPs+ put = putPs++-- | Class for converting between PackStream 'Ps's and native Haskell types.+type PackStream :: Type -> Constraint+class PackStream a where+ toPs :: a -> Ps++ -- | Encodes directly to 'Put' monad bypassing the intermediate 'Ps' AST+ --+ -- @since 1.1.0.0+ toBinary :: a -> Put+ toBinary = putPs . toPs++ fromPs :: Ps -> Result a++-- core instances++-- | The trivial identity 'PackStream' instance+instance PackStream Ps where+ toPs = id+ toBinary = putPs+ fromPs = pure++-- | Encodes as 'PsNull'+instance PackStream () where+ toPs _ = PsNull+ toBinary _ = putNull+ fromPs = withNull "()" (pure ())++instance PackStream Bool where+ toPs = PsBoolean+ toBinary = putBoolean+ fromPs = withBoolean "Boolean" pure++----------------------------------------------------------------------------++instance PackStream PSInteger where+ toPs = PsInteger+ toBinary = put+ fromPs = withInteger "PSInteger" pure++fromPsInteger :: FromPSInteger i => T.Text -> Ps -> Result i+fromPsInteger expected = withInteger expected go+ where+ go j = case fromPSInteger j of+ Just j' -> pure j'+ Nothing -> fail $ T.unpack $ "PackStream integer " <> showt j <> " cannot be decoded into " <> expected++instance PackStream Word32 where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Word32"++instance PackStream Word16 where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Word16"++instance PackStream Word8 where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Word8"++instance PackStream Int64 where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Int64"++instance PackStream Int32 where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Int32"++instance PackStream Int16 where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Int16"++instance PackStream Int8 where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Int8"++instance PackStream Int where+ toPs = PsInteger . toPSInteger+ toBinary = put . toPSInteger+ fromPs = fromPsInteger "Int"++----------------------------------------------------------------------------++-- | This instance decodes 64bit and 32bit floats from PackStream streams into a 'Double'+instance PackStream Double where+ toPs = PsFloat+ toBinary = putFloat+ fromPs = withFloat "Double" pure++instance PackStream S.ByteString where+ toPs = PsBytes+ toBinary = putBytes+ fromPs = withBytes "ByteString" pure++-- Because of overlapping instance, this must be above [a]+instance PackStream String where+ toPs = toPs . T.pack+ toBinary = putString . T.pack+ fromPs obj = T.unpack <$> fromPs obj++instance PackStream a => PackStream (V.Vector a) where+ toPs = PsList . V.map toPs+ toBinary = putList toBinary+ fromPs = withList "Vector" (traverse fromPs)++++-- | 'Maybe's are encoded as nullable types, i.e. 'Nothing' is encoded as @nil@.+--+-- __NOTE__: Encoding nested 'Maybe's or 'Maybe's enclosing types which encode to @nil@ (such as '()') will break round-tripping+instance PackStream a => PackStream (Maybe a) where+ toPs = \case+ Just a -> toPs a+ Nothing -> PsNull+ toBinary = \case+ Just a -> toBinary a+ Nothing -> putNull++ fromPs = \case+ PsNull -> pure Nothing+ obj -> Just <$> fromPs obj++-- UTF8 string like++instance PackStream L.ByteString where+ toPs = PsBytes . L.toStrict+ toBinary = putBytes . L.toStrict+ fromPs obj = L.fromStrict <$> fromPs obj++instance PackStream SBS.ShortByteString where+ toPs = PsBytes . SBS.fromShort+ toBinary = putBytes . SBS.fromShort+ fromPs obj = SBS.toShort <$> fromPs obj++instance PackStream T.Text where+ toPs = PsString+ toBinary = putString+ fromPs = withString "Text" pure++instance PackStream LT.Text where+ toPs = toPs . LT.toStrict+ toBinary = putString . LT.toStrict+ fromPs obj = LT.fromStrict <$> fromPs obj++-- array like++instance PackStream a => PackStream [a] where+ toPs = toPs . V.fromList+ toBinary = putList toBinary . V.fromList+ fromPs obj = V.toList <$> fromPs obj++instance PackStream a => PackStream (NonEmpty a) where+ toPs = toPs . NEL.toList+ toBinary = toBinary . NEL.toList+ fromPs o = do+ lst <- fromPs o+ case NEL.nonEmpty lst of+ Just as -> Success as+ Nothing -> Error "empty list"++-- dictionary like++instance (PackStream v) => PackStream (HashMap.HashMap T.Text v) where+ toPs = PsDictionary . H.map toPs+ toBinary = putDictionary putString toBinary . H.fromList . HashMap.toList+ fromPs = withDictionary "HashMap" (traverse fromPs)++++-- tuples++instance (PackStream a1, PackStream a2) => PackStream (a1, a2) where+ toPs (a1, a2) = PsList [toPs a1, toPs a2]+ toBinary (a1, a2) = putList' 2 $ do { toBinary a1; toBinary a2 }+ fromPs (PsList [a1, a2]) = (,) <$> fromPs a1 <*> fromPs a2+ fromPs obj = typeMismatch "2-tuple" obj++instance (PackStream a1, PackStream a2, PackStream a3) => PackStream (a1, a2, a3) where+ toPs (a1, a2, a3) = PsList [toPs a1, toPs a2, toPs a3]+ toBinary (a1, a2, a3) = putList' 3 $ do { toBinary a1; toBinary a2; toBinary a3 }+ fromPs (PsList [a1, a2, a3]) = (,,) <$> fromPs a1 <*> fromPs a2 <*> fromPs a3+ fromPs obj = typeMismatch "3-tuple" obj++instance (PackStream a1, PackStream a2, PackStream a3, PackStream a4) => PackStream (a1, a2, a3, a4) where+ toPs (a1, a2, a3, a4) = PsList [toPs a1, toPs a2, toPs a3, toPs a4]+ toBinary (a1, a2, a3, a4) = putList' 4 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4 }+ fromPs (PsList [a1, a2, a3, a4]) = (,,,) <$> fromPs a1 <*> fromPs a2 <*> fromPs a3 <*> fromPs a4+ fromPs obj = typeMismatch "4-tuple" obj++instance (PackStream a1, PackStream a2, PackStream a3, PackStream a4, PackStream a5) => PackStream (a1, a2, a3, a4, a5) where+ toPs (a1, a2, a3, a4, a5) = PsList [toPs a1, toPs a2, toPs a3, toPs a4, toPs a5]+ toBinary (a1, a2, a3, a4, a5) = putList' 5 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5 }+ fromPs (PsList [a1, a2, a3, a4, a5]) = (,,,,) <$> fromPs a1 <*> fromPs a2 <*> fromPs a3 <*> fromPs a4 <*> fromPs a5+ fromPs obj = typeMismatch "5-tuple" obj++instance (PackStream a1, PackStream a2, PackStream a3, PackStream a4, PackStream a5, PackStream a6) => PackStream (a1, a2, a3, a4, a5, a6) where+ toPs (a1, a2, a3, a4, a5, a6) = PsList [toPs a1, toPs a2, toPs a3, toPs a4, toPs a5, toPs a6]+ toBinary (a1, a2, a3, a4, a5, a6) = putList' 6 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6 }+ fromPs (PsList [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromPs a1 <*> fromPs a2 <*> fromPs a3 <*> fromPs a4 <*> fromPs a5 <*> fromPs a6+ fromPs obj = typeMismatch "6-tuple" obj++instance (PackStream a1, PackStream a2, PackStream a3, PackStream a4, PackStream a5, PackStream a6, PackStream a7) => PackStream (a1, a2, a3, a4, a5, a6, a7) where+ toPs (a1, a2, a3, a4, a5, a6, a7) = PsList [toPs a1, toPs a2, toPs a3, toPs a4, toPs a5, toPs a6, toPs a7]+ toBinary (a1, a2, a3, a4, a5, a6, a7) = putList' 7 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6; toBinary a7 }+ fromPs (PsList [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromPs a1 <*> fromPs a2 <*> fromPs a3 <*> fromPs a4 <*> fromPs a5 <*> fromPs a6 <*> fromPs a7+ fromPs obj = typeMismatch "7-tuple" obj++instance (PackStream a1, PackStream a2, PackStream a3, PackStream a4, PackStream a5, PackStream a6, PackStream a7, PackStream a8) => PackStream (a1, a2, a3, a4, a5, a6, a7, a8) where+ toPs (a1, a2, a3, a4, a5, a6, a7, a8) = PsList [toPs a1, toPs a2, toPs a3, toPs a4, toPs a5, toPs a6, toPs a7, toPs a8]+ toBinary (a1, a2, a3, a4, a5, a6, a7, a8) = putList' 8 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6; toBinary a7; toBinary a8 }+ fromPs (PsList [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromPs a1 <*> fromPs a2 <*> fromPs a3 <*> fromPs a4 <*> fromPs a5 <*> fromPs a6 <*> fromPs a7 <*> fromPs a8+ fromPs obj = typeMismatch "8-tuple" obj++instance (PackStream a1, PackStream a2, PackStream a3, PackStream a4, PackStream a5, PackStream a6, PackStream a7, PackStream a8, PackStream a9) => PackStream (a1, a2, a3, a4, a5, a6, a7, a8, a9) where+ toPs (a1, a2, a3, a4, a5, a6, a7, a8, a9) = PsList [toPs a1, toPs a2, toPs a3, toPs a4, toPs a5, toPs a6, toPs a7, toPs a8, toPs a9]+ toBinary (a1, a2, a3, a4, a5, a6, a7, a8, a9) = putList' 8 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6; toBinary a7; toBinary a8; toBinary a9 }+ fromPs (PsList [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromPs a1 <*> fromPs a2 <*> fromPs a3 <*> fromPs a4 <*> fromPs a5 <*> fromPs a6 <*> fromPs a7 <*> fromPs a8 <*> fromPs a9+ fromPs obj = typeMismatch "9-tuple" obj++-- | Report a type mismatch error for the expected type and actual 'Ps' value.+typeMismatch :: T.Text -> Ps -> Result a+typeMismatch expected obj = fail $ T.unpack ("PackStream " <> got <> " type cannot be decoded into " <> expected)+ where+ got = case obj of+ PsNull -> "nil"+ PsList v -> "array[" <> showt (V.length v) <> "]"+ PsDictionary v -> "map[" <> showt (H.size v) <> "]"+ PsString _ -> "str"+ PsBoolean _ -> "bool"+ PsInteger _ -> "int"+ PsFloat _ -> "float"+ PsBytes _ -> "bin"+ PsStructure ty _ -> "structure[" <> showt ty <> "]"++-- | Match a 'PsNull', or report a type mismatch.+withNull :: T.Text -> Result a -> Ps -> Result a+withNull _ f PsNull = f+withNull expected _ got = typeMismatch expected got++-- | Match a 'PsBoolean', or report a type mismatch.+withBoolean :: T.Text -> (Bool -> Result a) -> Ps -> Result a+withBoolean _ f (PsBoolean b) = f b+withBoolean expected _ got = typeMismatch expected got++-- | Match a 'PsInteger', or report a type mismatch.+withInteger :: T.Text -> (PSInteger -> Result a) -> Ps -> Result a+withInteger _ f (PsInteger i) = f i+withInteger expected _ got = typeMismatch expected got++-- | Match a 'PsFloat', or report a type mismatch.+withFloat :: T.Text -> (Double -> Result a) -> Ps -> Result a+withFloat _ f (PsFloat x) = f x+withFloat expected _ got = typeMismatch expected got++-- | Match a 'PsBytes', or report a type mismatch.+withBytes :: T.Text -> (S.ByteString -> Result a) -> Ps -> Result a+withBytes _ f (PsBytes i) = f i+withBytes expected _ got = typeMismatch expected got++-- | Match a 'PsString', or report a type mismatch.+withString :: T.Text -> (T.Text -> Result a) -> Ps -> Result a+withString _ f (PsString i) = f i+withString expected _ got = typeMismatch expected got++-- | Match a 'PsList', or report a type mismatch.+withList :: T.Text -> (V.Vector Ps -> Result a) -> Ps -> Result a+withList _ f (PsList xs) = f xs+withList expected _ got = typeMismatch expected got++-- | Match a 'PsDictionary', or report a type mismatch.+withDictionary :: T.Text -> (H.HashMap T.Text Ps -> Result a) -> Ps -> Result a+withDictionary _ f (PsDictionary xs) = f xs+withDictionary expected _ got = typeMismatch expected got
+ src/Data/PackStream/Put.hs view
@@ -0,0 +1,102 @@+-- | Internal module. Not part of the public API.+module Data.PackStream.Put (+ putNull, putBoolean, putFloat,+ putInteger, putInteger64,+ putString, putBytes, putList, putList', putDictionary+ ) where++import Compat.Prelude+import Prelude++import qualified Data.ByteString as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import qualified Data.HashMap.Lazy as H++import Compat.Binary+import Data.PackStream.Integer+import Data.PackStream.Tags++-- | Encode a PackStream null value.+putNull :: Put+putNull = putWord8 TAG_Null++-- | Encode a PackStream boolean value.+putBoolean :: Bool -> Put+putBoolean False = putWord8 TAG_false+putBoolean True = putWord8 TAG_true++-- | Encodes an 'Int' to PackStream+--+-- See also 'PSInteger' and its 'Binary' instance.+putInteger :: Int -> Put+putInteger = put . toPSInteger++-- putWord :: Word -> Put+-- putWord = put . toPSInteger++-- | Encode an 'Int64' to PackStream.+putInteger64 :: Int64 -> Put+putInteger64 = put . toPSInteger++-- putWord64 :: Word64 -> Put+-- putWord64 = put . toPSInteger++-- | Encode a 'Double' as a PackStream 64-bit float.+putFloat :: Double -> Put+putFloat d = putWord8 TAG_Float >> putFloat64be d++-- | Encode a 'T.Text' as a PackStream UTF-8 string.+putString :: T.Text -> Put+putString t = do+ let bs = T.encodeUtf8 t+ toSizeM ("putString: data exceeds 2^32-1 byte limit of PackStream") (S.length bs) >>= \case+ len | len <= 15 -> putWord8 (TAG_STRING_SHORT .|. fromIntegral len)+ | len < 0x100 -> putWord8 TAG_STRING_8 >> putWord8 (fromIntegral len)+ | len < 0x10000 -> putWord8 TAG_STRING_16 >> putWord16be (fromIntegral len)+ | otherwise -> putWord8 TAG_STRING_32 >> putWord32be len+ putByteString bs++-- | Encode a 'S.ByteString' as a PackStream byte array.+putBytes :: S.ByteString -> Put+putBytes bs = do+ toSizeM ("putBytes: data exceeds 2^32-1 byte limit of PackStream") (S.length bs) >>= \case+ len | len < 0x100 -> putWord8 TAG_BYTE_ARRAY_8 >> putWord8 (fromIntegral len)+ | len < 0x10000 -> putWord8 TAG_BYTE_ARRAY_16 >> putWord16be (fromIntegral len)+ | otherwise -> putWord8 TAG_BYTE_ARRAY_32 >> putWord32be len+ putByteString bs++-- | Encode a 'V.Vector' as a PackStream list using the given element encoder.+putList :: (a -> Put) -> V.Vector a -> Put+putList p xs = do+ len <- toSizeM ("putList: data exceeds 2^32-1 element limit of PackStream") (V.length xs)+ putList' len (V.mapM_ p xs)++putList' :: Word32 -- ^ number of array elements+ -> Put -- ^ 'Put' action emitting array elements (__NOTE__: it's the responsibility of the caller to ensure that the declared array length matches exactly the data generated by the 'Put' action)+ -> Put+putList' len putter = do+ case () of+ _ | len <= 15 -> putWord8 (TAG_LIST_SHORT .|. fromIntegral len)+ | len < 0x100 -> putWord8 TAG_LIST_8 >> putWord8 (fromIntegral len)+ | len < 0x10000 -> putWord8 TAG_LIST_16 >> putWord16be (fromIntegral len)+ | otherwise -> putWord8 TAG_LIST_32 >> putWord32be len+ putter++-- | Encode a 'H.HashMap' as a PackStream dictionary using the given key and value encoders.+putDictionary :: (a -> Put) -> (b -> Put) -> H.HashMap a b -> Put+putDictionary p q xs = do+ let len' = H.size xs+ if len' > 2_147_483_647 then+ error "putDictionary: data exceeds 2^32-1 element limit of PackStream"+ else case len' of+ len | len <= 15 -> putWord8 (TAG_DICTIONARY_SHORT .|. fromIntegral len)+ | len < 0x100 -> putWord8 TAG_DICTIONARY_8 >> putWord8 (fromIntegral len)+ | len < 0x10000 -> putWord8 TAG_DICTIONARY_16 >> putWord16be (fromIntegral len)+ | otherwise -> putWord8 TAG_DICTIONARY_32 >> putWord32be (fromIntegral len)+ mapM_ (\(a, b) -> p a >> q b) $ H.toList xs+++toSizeM :: String -> Int -> PutM Word32+toSizeM label len0 = maybe (error label) pure (intCastMaybe len0)
+ src/Data/PackStream/Result.hs view
@@ -0,0 +1,36 @@+-- | Internal module. Not part of the public API.+module Data.PackStream.Result+ ( Result(..)+ ) where++import Compat.Prelude+import qualified Control.Monad.Fail as Fail+import Data.Kind (Type)+import Data.Text++-- | The result of decoding from PackStream+type Result :: Type -> Type+type role Result representational+data Result a = Error Text+ | Success a+ deriving stock (Eq, Show, Functor, Generic, Foldable, Traversable)++instance NFData a => NFData (Result a) where+ rnf (Error e) = rnf e+ rnf (Success a) = rnf a++instance Applicative Result where+ pure = Success+ (<*>) = ap++instance Monad Result where+ Success a >>= m = m a+ Error err >>= _ = Error err++instance Fail.MonadFail Result where+ fail str = Error $ pack str++instance Alternative Result where+ empty = fail "Alternative(empty)"+ a@(Success _) <|> _ = a+ _ <|> b = b
+ src/Data/PackStream/Tags.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+++-- | Internal module. Not part of the public API.+module Data.PackStream.Tags+ ( -- * Masks+ pattern MASK_HIGH_NIBBLE+ , pattern MASK_LOW_NIBBLE+ -- * Null and Boolean+ , pattern TAG_Null+ , pattern TAG_false+ , pattern TAG_true+ -- * Integers+ , is_TAG_TINY_INT+ , pattern TAG_INT_8+ , pattern TAG_INT_16+ , pattern TAG_INT_32+ , pattern TAG_INT_64+ -- * Float+ , pattern TAG_Float+ -- * Byte arrays+ , pattern TAG_BYTE_ARRAY_8+ , pattern TAG_BYTE_ARRAY_16+ , pattern TAG_BYTE_ARRAY_32+ -- * Strings+ , pattern TAG_STRING_SHORT+ , is_TAG_STRING_SHORT+ , pattern TAG_STRING_8+ , pattern TAG_STRING_16+ , pattern TAG_STRING_32+ -- * Lists+ , pattern TAG_LIST_SHORT+ , is_TAG_LIST_SHORT+ , pattern TAG_LIST_8+ , pattern TAG_LIST_16+ , pattern TAG_LIST_32+ -- * Dictionaries+ , pattern TAG_DICTIONARY_SHORT+ , is_TAG_DICTIONARY_SHORT+ , pattern TAG_DICTIONARY_8+ , pattern TAG_DICTIONARY_16+ , pattern TAG_DICTIONARY_32+ -- * Structures+ , is_TAG_STRUCTURE+ ) where++import Compat.Prelude++{-++-- | Test whether tag is a fixint+is_TAG_fixint :: Word8 -> Bool+is_TAG_fixint tag = (tag .&. TAG_MASK_fixintp == TAG_fixintp)+ || (tag .&. TAG_MASK_fixintn == TAG_fixintn)+{-# INLINE is_TAG_fixint #-}++pattern TAG_fixintn = 0xe0 -- 0b111xxxxx [0xe0 .. 0xff] / [-32 .. -1]+pattern TAG_MASK_fixintn = 0xe0 -- 0b11100000++pattern TAG_fixintp = 0x00 -- 0b0xxxxxxx [0x00 .. 0x7f] / [0 .. 127]+pattern TAG_MASK_fixintp = 0x80 -- 0b10000000++-- | Test whether tag is a fixmap and return embedded-size if it is+is_TAG_fixmap :: Word8 -> Maybe Word32+is_TAG_fixmap t+ | t .&. TAG_MASK_fixmap == TAG_fixmap = Just $! intCast (t .&. complement TAG_MASK_fixmap)+ | otherwise = Nothing+{-# INLINE is_TAG_fixmap #-}++pattern TAG_fixmap = 0x80 -- 0b1000xxxx [0x80 .. 0x8f]+pattern TAG_MASK_fixmap = 0xf0 -- 0b11110000++-- | Test whether tag is a fixarray and return embedded-size if it is+is_TAG_fixarray :: Word8 -> Maybe Word32+is_TAG_fixarray t+ | t .&. TAG_MASK_fixarray == TAG_fixarray = Just $! intCast (t .&. complement TAG_MASK_fixarray)+ | otherwise = Nothing+{-# INLINE is_TAG_fixarray #-}++pattern TAG_fixarray = 0x90 -- 0b1001xxxx [0x90 .. 0x9f]+pattern TAG_MASK_fixarray = 0xf0 -- 0b11110000++-- | Test whether tag is a fixstr and return embedded-size if it is+is_TAG_fixstr :: Word8 -> Maybe Word32+is_TAG_fixstr t+ | t .&. TAG_MASK_fixstr == TAG_fixstr = Just $! intCast (t .&. complement TAG_MASK_fixstr)+ | otherwise = Nothing+{-# INLINE is_TAG_fixstr #-}++pattern TAG_fixstr = 0xa0 -- 0b101xxxxx [0xa0 .. 0xbf]+pattern TAG_MASK_fixstr = 0xe0 -- 0b11100000++pattern TAG_nil = 0xc0 -- 0b11000000+pattern TAG_reserved_C1 = 0xc1 -- 0b11000001+pattern TAG_false = 0xc2 -- 0b11000010+pattern TAG_true = 0xc3 -- 0b11000011++pattern TAG_bin8 = 0xc4 -- 0b11000100+pattern TAG_bin16 = 0xc5 -- 0b11000101+pattern TAG_bin32 = 0xc6 -- 0b11000110++pattern TAG_ext8 = 0xc7 -- 0b11000111+pattern TAG_ext16 = 0xc8 -- 0b11001000+pattern TAG_ext32 = 0xc9 -- 0b11001001++pattern TAG_float32 = 0xca -- 0b11001010+pattern TAG_float64 = 0xcb -- 0b11001011++pattern TAG_uint8 = 0xcc -- 0b11001100+pattern TAG_uint16 = 0xcd -- 0b11001101+pattern TAG_uint32 = 0xce -- 0b11001110+pattern TAG_uint64 = 0xcf -- 0b11001111++pattern TAG_int8 = 0xd0 -- 0b11010000+pattern TAG_int16 = 0xd1 -- 0b11010001+pattern TAG_int32 = 0xd2 -- 0b11010010+pattern TAG_int64 = 0xd3 -- 0b11010011++pattern TAG_fixext1 = 0xd4 -- 0b11010100+pattern TAG_fixext2 = 0xd5 -- 0b11010101+pattern TAG_fixext4 = 0xd6 -- 0b11010110+pattern TAG_fixext8 = 0xd7 -- 0b11010111+pattern TAG_fixext16 = 0xd8 -- 0b11011000++pattern TAG_str8 = 0xd9 -- 0b11011001+pattern TAG_str16 = 0xda -- 0b11011010+pattern TAG_str32 = 0xdb -- 0b11011011++pattern TAG_array16 = 0xdc -- 0b11011100+pattern TAG_array32 = 0xdd -- 0b11011101++pattern TAG_map16 = 0xde -- 0b11011110+pattern TAG_map32 = 0xdf -- 0b11011111++-- NOTE: Currently the PackStream specification only defines the @-1@+-- extension type (for timestamps). All remaining negative Int8+-- type-ids are reserved for future use by the PackStream.++-- Used by "Data.PackStream.Timestamp"+pattern XTAG_Timestamp = -1 :: Int8++-}++-- | Bitmask selecting the high nibble (upper 4 bits) of a byte.+pattern MASK_HIGH_NIBBLE :: (Eq a, Num a) => a+pattern MASK_HIGH_NIBBLE = 0xF0++-- | Bitmask selecting the low nibble (lower 4 bits) of a byte.+pattern MASK_LOW_NIBBLE :: (Eq a, Num a) => a+pattern MASK_LOW_NIBBLE = 0x0F+++-- https://neo4j.com/docs/bolt/current/packstream/++-- | Tag byte for Null (0xC0).+pattern TAG_Null :: (Eq a, Num a) => a+pattern TAG_Null = 0xC0++-- | Tag byte for boolean false (0xC2).+pattern TAG_false :: (Eq a, Num a) => a+pattern TAG_false = 0xC2++-- | Tag byte for boolean true (0xC3).+pattern TAG_true :: (Eq a, Num a) => a+pattern TAG_true = 0xC3++-- | Test whether tag is a TINY_INT+is_TAG_TINY_INT :: Word8 -> Bool+is_TAG_TINY_INT tag = tag <= 0x7F || tag >= 0xF0+{-# INLINE is_TAG_TINY_INT #-}++-- | Tag byte for 8-bit signed integer (0xC8).+pattern TAG_INT_8 :: (Eq a, Num a) => a+pattern TAG_INT_8 = 0xC8++-- | Tag byte for 16-bit signed integer (0xC9).+pattern TAG_INT_16 :: (Eq a, Num a) => a+pattern TAG_INT_16 = 0xC9++-- | Tag byte for 32-bit signed integer (0xCA).+pattern TAG_INT_32 :: (Eq a, Num a) => a+pattern TAG_INT_32 = 0xCA++-- | Tag byte for 64-bit signed integer (0xCB).+pattern TAG_INT_64 :: (Eq a, Num a) => a+pattern TAG_INT_64 = 0xCB++-- Not supporting this (except for TINY_INT):+-- Some marker bytes can be used to carry the value of a small integer as well as its type. These markers can be identified by a zero high-order bit (for positive values) or by a high-order nibble containing only ones (for negative values). Specifically, values between 00 and 7F inclusive can be directly translated to and from positive integers with the same value. Similarly, values between F0 and FF inclusive can do the same for negative numbers between -16 and -1.++-- | Tag byte for 64-bit float (0xC1).+pattern TAG_Float :: (Eq a, Num a) => a+pattern TAG_Float = 0xC1++-- | Tag byte for byte array with 8-bit length (0xCC).+pattern TAG_BYTE_ARRAY_8 :: (Eq a, Num a) => a+pattern TAG_BYTE_ARRAY_8 = 0xCC++-- | Tag byte for byte array with 16-bit length (0xCD).+pattern TAG_BYTE_ARRAY_16 :: (Eq a, Num a) => a+pattern TAG_BYTE_ARRAY_16 = 0xCD++-- | Tag byte for byte array with 32-bit length (0xCE).+pattern TAG_BYTE_ARRAY_32 :: (Eq a, Num a) => a+pattern TAG_BYTE_ARRAY_32 = 0xCE++-- | Base tag byte for short strings with length embedded in the low nibble (0x80).+pattern TAG_STRING_SHORT :: (Eq a, Num a) => a+pattern TAG_STRING_SHORT = 0x80++-- is_TAG_STRING_SHORT :: Word8 -> Bool+-- is_TAG_STRING_SHORT tag = tag >= 0x80 && tag <= 0x8F+-- {-# INLINE is_TAG_STRING_SHORT #-}++-- | Test whether tag is a short string; returns embedded length if so.+is_TAG_STRING_SHORT :: Word8 -> Maybe Word32+is_TAG_STRING_SHORT t+ | t .&. MASK_HIGH_NIBBLE == 0x80 = Just $! intCast (t .&. MASK_LOW_NIBBLE)+ | otherwise = Nothing+{-# INLINE is_TAG_STRING_SHORT #-}++-- | Tag byte for string with 8-bit length (0xD0).+pattern TAG_STRING_8 :: (Eq a, Num a) => a+pattern TAG_STRING_8 = 0xD0++-- | Tag byte for string with 16-bit length (0xD1).+pattern TAG_STRING_16 :: (Eq a, Num a) => a+pattern TAG_STRING_16 = 0xD1++-- | Tag byte for string with 32-bit length (0xD3).+pattern TAG_STRING_32 :: (Eq a, Num a) => a+pattern TAG_STRING_32 = 0xD3++-- | Base tag byte for short lists with length embedded in the low nibble (0x90).+pattern TAG_LIST_SHORT :: (Eq a, Num a) => a+pattern TAG_LIST_SHORT = 0x90++-- is_TAG_LIST_SHORT :: Word8 -> Bool+-- is_TAG_LIST_SHORT tag = tag >= 0x90 && tag <= 0x9F+-- {-# INLINE is_TAG_LIST_SHORT #-}++-- | Test whether tag is a short list; returns embedded length if so.+is_TAG_LIST_SHORT :: Word8 -> Maybe Word32+is_TAG_LIST_SHORT t+ | t .&. MASK_HIGH_NIBBLE == 0x90 = Just $! intCast (t .&. MASK_LOW_NIBBLE)+ | otherwise = Nothing+{-# INLINE is_TAG_LIST_SHORT #-}++-- | Tag byte for list with 8-bit length (0xD4).+pattern TAG_LIST_8 :: (Eq a, Num a) => a+pattern TAG_LIST_8 = 0xD4++-- | Tag byte for list with 16-bit length (0xD5).+pattern TAG_LIST_16 :: (Eq a, Num a) => a+pattern TAG_LIST_16 = 0xD5++-- | Tag byte for list with 32-bit length (0xD6).+pattern TAG_LIST_32 :: (Eq a, Num a) => a+pattern TAG_LIST_32 = 0xD6++-- | Base tag byte for short dictionaries with length embedded in the low nibble (0xA0).+pattern TAG_DICTIONARY_SHORT :: (Eq a, Num a) => a+pattern TAG_DICTIONARY_SHORT = 0xA0++-- is_TAG_DICTIONARY_SHORT :: Word8 -> Bool+-- is_TAG_DICTIONARY_SHORT tag = tag >= 0xA0 && tag <= 0xAF+-- {-# INLINE is_TAG_DICTIONARY_SHORT #-}++-- | Test whether tag is a short dictionary; returns embedded length if so.+is_TAG_DICTIONARY_SHORT :: Word8 -> Maybe Word32+is_TAG_DICTIONARY_SHORT t+ | t .&. MASK_HIGH_NIBBLE == 0xA0 = Just $! intCast (t .&. MASK_LOW_NIBBLE)+ | otherwise = Nothing+{-# INLINE is_TAG_DICTIONARY_SHORT #-}+++-- | Tag byte for dictionary with 8-bit length (0xD8).+pattern TAG_DICTIONARY_8 :: (Eq a, Num a) => a+pattern TAG_DICTIONARY_8 = 0xD8++-- | Tag byte for dictionary with 16-bit length (0xD9).+pattern TAG_DICTIONARY_16 :: (Eq a, Num a) => a+pattern TAG_DICTIONARY_16 = 0xD9++-- | Tag byte for dictionary with 32-bit length (0xDA).+pattern TAG_DICTIONARY_32 :: (Eq a, Num a) => a+pattern TAG_DICTIONARY_32 = 0xDA++-- is_TAG_STRUCTURE :: Word8 -> Bool+-- is_TAG_STRUCTURE tag = tag >= 0xB0 && tag <= 0xBF+-- {-# INLINE is_TAG_STRUCTURE #-}++-- | Test whether tag is a structure marker; returns the field count if so.+is_TAG_STRUCTURE :: Word8 -> Maybe Word32+is_TAG_STRUCTURE t+ | t .&. MASK_HIGH_NIBBLE == 0xB0 = Just $! intCast (t .&. MASK_LOW_NIBBLE)+ | otherwise = Nothing+{-# INLINE is_TAG_STRUCTURE #-}
+ src/Data/PackStream/Timestamp.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE PatternSynonyms #-}++-- | Internal module. Not part of the public API.+module Data.PackStream.Timestamp+ ( PSTimestamp++ , mptsFromPosixSeconds+ , mptsFromPosixSeconds2+ , mptsToPosixSeconds2++ , mptsFromPosixNanoseconds+ , mptsToPosixNanoseconds++ , mptsToUTCTime+ , mptsFromUTCTime+ , mptsFromUTCTimeLossy+ ) where++import Compat.Prelude++import Data.Fixed+import Data.Kind (Type)+import qualified Data.Time.Clock as Time+import qualified Data.Time.Clock.POSIX as Time++-- | A PackStream timestamp+--+-- The representable range is @[-292277022657-01-27 08:29:52 UTC .. 292277026596-12-04 15:30:07.999999999 UTC]@ with nanosecond precision.+type PSTimestamp :: Type+data PSTimestamp = PSTimestamp !Int64 !Word32+ deriving stock (Eq, Ord, Show, Read)++instance Bounded PSTimestamp where+ minBound = PSTimestamp minBound 0+ maxBound = PSTimestamp maxBound 999999999++instance NFData PSTimestamp where rnf (PSTimestamp _ _) = ()++-- | Construct 'PSTimestamp' from amount of integral seconds since Unix epoch+mptsFromPosixSeconds :: Int64 -> PSTimestamp+mptsFromPosixSeconds s = PSTimestamp s 0++-- | Construct 'PSTimestamp' from amount of seconds and nanoseconds (must be \( \leq 10^9 \) ) passed since Unix epoch+mptsFromPosixSeconds2 :: Int64 -> Word32 -> Maybe PSTimestamp+mptsFromPosixSeconds2 s ns+ | ns <= 999999999 = Just $! PSTimestamp s ns+ | otherwise = Nothing++-- | Deconstruct 'PSTimestamp' into amount of seconds and nanoseconds passed since Unix epoch+mptsToPosixSeconds2 :: PSTimestamp -> (Int64, Word32)+mptsToPosixSeconds2 (PSTimestamp s ns) = (s, ns)++-- | Construct 'PSTimestamp' from total amount of nanoseconds passed since Unix epoch+mptsFromPosixNanoseconds :: Integer -> Maybe PSTimestamp+mptsFromPosixNanoseconds ns0+ | minI <= ns0, ns0 <= maxI = Just $! PSTimestamp (fromInteger s) (fromInteger ns)+ | otherwise = Nothing+ where+ (s,ns) = divMod ns0 1000000000+ maxI = mptsToPosixNanoseconds maxBound+ minI = mptsToPosixNanoseconds minBound++-- | Deconstruct 'PSTimestamp' into total amount of nanoseconds passed since Unix epoch+mptsToPosixNanoseconds :: PSTimestamp -> Integer+mptsToPosixNanoseconds (PSTimestamp s ns) = (toInteger s * 1000000000) + toInteger ns++-- >>> mptsToUTCTime minBound+-- -292277022657-01-27 08:29:52 UTC++-- >>> mptsToUTCTime maxBound+-- 292277026596-12-04 15:30:07.999999999 UTC++-- >>> mptsToUTCTime (PSTimestamp 0 0)+-- 1970-01-01 00:00:00 UTC++-- >>> mptsToUTCTime (PSTimestamp 0xffffffff 0)+-- 2106-02-07 06:28:15 UTC++-- >>> mptsToUTCTime (PSTimestamp 0x3ffffffff 999999999)+-- 2514-05-30 01:53:03.999999999 UTC++-- | Convert 'PSTimestamp' into 'Time.UTCTime'+mptsToUTCTime :: PSTimestamp -> Time.UTCTime+mptsToUTCTime = picoseconds2utc . (*1000) . mptsToPosixNanoseconds++-- >>> mptsFromUTCTime (mptsToUTCTime minBound) == Just minBound+-- True++-- >>> mptsFromUTCTime (mptsToUTCTime maxBound) == Just maxBound+-- True++utc2picoseconds :: Time.UTCTime -> Integer+utc2picoseconds utc = ps+ where -- NB: this exploits the RULE from time:+ -- "realToFrac/NominalDiffTime->Pico" realToFrac = \(MkNominalDiffTime ps) -> ps+ MkFixed ps = realToFrac (Time.utcTimeToPOSIXSeconds utc) :: Pico++-- NB: exploits the RULE+-- "realToFrac/Pico->NominalDiffTime" realToFrac = MkNominalDiffTime+picoseconds2utc :: Integer -> Time.UTCTime+picoseconds2utc ps = Time.posixSecondsToUTCTime (realToFrac (MkFixed ps :: Pico))++-- | Convert 'Time.UTCTime' into 'PSTimestamp'+--+-- This conversion can fail (i.e. result in 'Nothing') if either the conversion cannot be performed lossless, either because the range of 'PSTimestamp' was exceeded or because of sub-nanosecond fractions.+--+-- See also 'mptsFromUTCTimeLossy'+mptsFromUTCTime :: Time.UTCTime -> Maybe PSTimestamp+mptsFromUTCTime t+ | rest /= 0 = Nothing+ | otherwise = mptsFromPosixNanoseconds ns0+ where+ (ns0,rest) = divMod (utc2picoseconds t) 1000++-- | Version of 'mptsFromUTCTime' which performs a lossy conversion into 'PSTimestamp'+--+-- * sub-nanosecond precision is silently truncated (in the sense of 'floor') to nanosecond precision+--+-- * time values exceeding the range of 'PSTimestamp' are clamped to 'minBound' and 'maxBound' respectively+--+mptsFromUTCTimeLossy :: Time.UTCTime -> PSTimestamp+mptsFromUTCTimeLossy t+ | Just mpts <- mptsFromPosixNanoseconds ns0 = mpts+ | ns0 < 0 = minBound+ | otherwise = maxBound+ where+ ns0 = div (utc2picoseconds t) 1000+