Skip to content

Commit

Permalink
add Document serialisation with format and version
Browse files Browse the repository at this point in the history
  • Loading branch information
rsoeldner committed Nov 1, 2023
1 parent 27d1c99 commit ece3c80
Show file tree
Hide file tree
Showing 3 changed files with 152 additions and 42 deletions.
118 changes: 76 additions & 42 deletions pact-core-tests/Pact/Core/Test/SerialiseTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,59 +2,93 @@

module Pact.Core.Test.SerialiseTests where

import Data.ByteString
import Pact.Core.Serialise
import Pact.Core.Gen.Serialise
import Pact.Core.Serialise.CBOR ()
import Codec.Serialise
import qualified Codec.Serialise as S

import Test.Tasty
import Test.Tasty.Hedgehog
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

serialiseRoundtrip :: forall a. (Serialise a, Show a, Eq a) => Gen a -> Property
serialiseRoundtrip :: forall a. (S.Serialise a, Show a, Eq a) => Gen a -> Property
serialiseRoundtrip g = property $ do
expr <- forAll g
deserialise (serialise expr) === expr
S.deserialise (S.serialise expr) === expr

documentFormatGen :: Gen DocumentFormat
documentFormatGen = Gen.element [minBound .. maxBound]

documentVersionGen :: Gen DocumentVersion
documentVersionGen = DocumentVersion <$> Gen.word32 (Range.linear 0 100)

documentGen :: Gen a -> Gen (Document a)
documentGen g = Document <$> documentVersionGen <*> documentFormatGen <*> g

serialiseModule :: Property
serialiseModule = property $ do
m <- forAll evalModuleGen
let
encoded = _encodeModule serialiseCBOR m
case _decodeModule serialiseCBOR encoded of
Left _ -> fail "asas"
Right (Document v f c) -> do
v === DocumentVersion 0
f === DocumentCBOR
m === c

tests :: TestTree
tests = testGroup "Serialise Roundtrip"
[ testProperty "NamespaceName" $ serialiseRoundtrip namespaceNameGen
, testProperty "ModuleName" $ serialiseRoundtrip moduleNameGen
, testProperty "KeySetName" $ serialiseRoundtrip keySetNameGen
, testProperty "QualifiedName" $ serialiseRoundtrip qualifiedNameGen
, testProperty "BareName" $ serialiseRoundtrip bareNameGen
, testProperty "DynamicName" $ serialiseRoundtrip dynamicNameGen
, testProperty "ParsedName" $ serialiseRoundtrip parsedNameGen
, testProperty "Hash" $ serialiseRoundtrip hashGen
, testProperty "ModuleHash" $ serialiseRoundtrip moduleHashGen
, testProperty "FullyQualifiedName" $ serialiseRoundtrip fullyQualifiedNameGen
, testProperty "DynamicRef" $ serialiseRoundtrip dynamicRefGen
, testProperty "NameKind" $ serialiseRoundtrip nameKindGen
, testProperty "Name" $ serialiseRoundtrip nameGen
, testProperty "resolvedGov" $ serialiseRoundtrip resolvedGovGen
, testProperty "Governance" $ serialiseRoundtrip governanceGen
, testProperty "PrimType" $ serialiseRoundtrip tyPrimGen
, testProperty "Field" $ serialiseRoundtrip fieldGen
, testProperty "Schema" $ serialiseRoundtrip schemaGen
, testProperty "Types" $ serialiseRoundtrip typeGen
, testProperty "Arg" $ serialiseRoundtrip argGen
, testProperty "Import" $ serialiseRoundtrip importGen
, testProperty "SpanInfo" $ serialiseRoundtrip infoGen
, testProperty "Builtin" $ serialiseRoundtrip builtinGen
, testProperty "Literal" $ serialiseRoundtrip literalGen
, testProperty "LamInfo" $ serialiseRoundtrip lamInfoGen
, testProperty "BuiltinForm" $ serialiseRoundtrip builtinFormGen
, testProperty "Term" $ serialiseRoundtrip termGen
, testProperty "Defun" $ serialiseRoundtrip defunGen
, testProperty "DefConst" $ serialiseRoundtrip defConstGen
, testProperty "FQNameRef" $ serialiseRoundtrip fqNameRefGen
, testProperty "DefManagedMeta" $ serialiseRoundtrip defManagedMetaGen
, testProperty "DefCapMeta" $ serialiseRoundtrip defCapMetaGen
, testProperty "DefCap" $ serialiseRoundtrip defCapGen
, testProperty "Def" $ serialiseRoundtrip defGen
, testProperty "Module" $ serialiseRoundtrip evalModuleGen
, testProperty "DefSchema" $ serialiseRoundtrip defSchemaGen
, testProperty "DefTable" $ serialiseRoundtrip defTableGen
, testProperty "Step" $ serialiseRoundtrip stepGen
, testProperty "DefPact" $ serialiseRoundtrip defPactGen
[ testGroup "Document"
[ testProperty "DocumentFormat" $ serialiseRoundtrip documentFormatGen
, testProperty "DocumentVersion" $ serialiseRoundtrip documentVersionGen
, testProperty "Document" $ serialiseRoundtrip (documentGen (Gen.constant ()))
]
, testGroup "CBOR"
[ testProperty "NamespaceName" $ serialiseRoundtrip namespaceNameGen
, testProperty "ModuleName" $ serialiseRoundtrip moduleNameGen
, testProperty "KeySetName" $ serialiseRoundtrip keySetNameGen
, testProperty "QualifiedName" $ serialiseRoundtrip qualifiedNameGen
, testProperty "BareName" $ serialiseRoundtrip bareNameGen
, testProperty "DynamicName" $ serialiseRoundtrip dynamicNameGen
, testProperty "ParsedName" $ serialiseRoundtrip parsedNameGen
, testProperty "Hash" $ serialiseRoundtrip hashGen
, testProperty "ModuleHash" $ serialiseRoundtrip moduleHashGen
, testProperty "FullyQualifiedName" $ serialiseRoundtrip fullyQualifiedNameGen
, testProperty "DynamicRef" $ serialiseRoundtrip dynamicRefGen
, testProperty "NameKind" $ serialiseRoundtrip nameKindGen
, testProperty "Name" $ serialiseRoundtrip nameGen
, testProperty "resolvedGov" $ serialiseRoundtrip resolvedGovGen
, testProperty "Governance" $ serialiseRoundtrip governanceGen
, testProperty "PrimType" $ serialiseRoundtrip tyPrimGen
, testProperty "Field" $ serialiseRoundtrip fieldGen
, testProperty "Schema" $ serialiseRoundtrip schemaGen
, testProperty "Types" $ serialiseRoundtrip typeGen
, testProperty "Arg" $ serialiseRoundtrip argGen
, testProperty "Import" $ serialiseRoundtrip importGen
, testProperty "SpanInfo" $ serialiseRoundtrip infoGen
, testProperty "Builtin" $ serialiseRoundtrip builtinGen
, testProperty "Literal" $ serialiseRoundtrip literalGen
, testProperty "LamInfo" $ serialiseRoundtrip lamInfoGen
, testProperty "BuiltinForm" $ serialiseRoundtrip builtinFormGen
, testProperty "Term" $ serialiseRoundtrip termGen
, testProperty "Defun" $ serialiseRoundtrip defunGen
, testProperty "DefConst" $ serialiseRoundtrip defConstGen
, testProperty "FQNameRef" $ serialiseRoundtrip fqNameRefGen
, testProperty "DefManagedMeta" $ serialiseRoundtrip defManagedMetaGen
, testProperty "DefCapMeta" $ serialiseRoundtrip defCapMetaGen
, testProperty "DefCap" $ serialiseRoundtrip defCapGen
, testProperty "Def" $ serialiseRoundtrip defGen
, testProperty "Module" $ serialiseRoundtrip evalModuleGen
, testProperty "DefSchema" $ serialiseRoundtrip defSchemaGen
, testProperty "DefTable" $ serialiseRoundtrip defTableGen
, testProperty "Step" $ serialiseRoundtrip stepGen
, testProperty "DefPact" $ serialiseRoundtrip defPactGen
],
testGroup "CBOR Serialise"
[ testProperty "Module roundtrip" serialiseModule
]
]
1 change: 1 addition & 0 deletions pact-core.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -128,6 +128,7 @@ library
Pact.Core.Repl.Compile

-- Serialization
Pact.Core.Serialise
Pact.Core.Serialise.CBOR

library typed-core
Expand Down
75 changes: 75 additions & 0 deletions pact-core/Pact/Core/Serialise.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,75 @@
-- |

module Pact.Core.Serialise where

import Data.ByteString (ByteString, fromStrict)
import Data.Word (Word32)

import Pact.Core.Info
import Pact.Core.Builtin
import Pact.Core.IR.Term
import qualified Codec.Serialise as S
import qualified Codec.CBOR.Encoding as S
import qualified Codec.CBOR.Decoding as S
import Codec.CBOR.Write (toStrictByteString)

import Pact.Core.Serialise.CBOR ()
import Data.Bifunctor

import Data.Int (Int64)

-- | Document version
newtype DocumentVersion
= DocumentVersion { unDocumentVersion :: Word32 }
deriving (Show, Eq, Ord)


-- | Supported Document Formats
data DocumentFormat
= DocumentCBOR
deriving (Show, Eq, Enum, Bounded)


data DecodeError
= DecodeFailure Int64 String
deriving (Show, Eq)


data Document a
= Document
{ _documentVersion :: DocumentVersion
, _documentFormat :: DocumentFormat
, _documentContent :: a
} deriving (Show, Eq)

data Serialise
= Serialise
{ _encodeModule :: EvalModule RawBuiltin SpanInfo -> ByteString
, _decodeModule :: ByteString -> Either DecodeError (Document (EvalModule RawBuiltin SpanInfo))
}


serialiseCBOR :: Serialise
serialiseCBOR = Serialise
{ _encodeModule = toStrictByteString . S.encode . Document version format
, _decodeModule = first toErr . S.deserialiseOrFail . fromStrict
}
where
version = DocumentVersion 0
format = DocumentCBOR
toErr (S.DeserialiseFailure offset msg) = DecodeFailure offset msg

instance S.Serialise a => S.Serialise (Document a) where
encode (Document v f c) = S.encode v <> S.encode f <> S.encode c
decode = Document <$> S.decode <*> S.decode <*> S.decode

instance S.Serialise DocumentVersion where
encode (DocumentVersion v) = S.encode v
decode = DocumentVersion <$> S.decode

instance S.Serialise DocumentFormat where
encode = \case
DocumentCBOR -> S.encodeWord 0
decode = S.decodeWord >>= \case
0 -> pure DocumentCBOR
_ -> fail "unexpected decoding"

0 comments on commit ece3c80

Please sign in to comment.