Drop CBOR for simple custom manifest
This commit is contained in:
544
src/Wire.hs
544
src/Wire.hs
@@ -24,40 +24,22 @@ module Wire
|
||||
import ContentStore (getNodeMerkle, loadTree, putMerkleNode, storeTerm)
|
||||
import Research
|
||||
|
||||
import Codec.CBOR.Decoding ( Decoder
|
||||
, decodeString
|
||||
, decodeBytes
|
||||
, decodeListLen
|
||||
, decodeMapLen
|
||||
)
|
||||
import Control.Monad (replicateM, forM)
|
||||
import Codec.CBOR.Encoding ( Encoding
|
||||
, encodeMapLen
|
||||
, encodeListLen
|
||||
, encodeString
|
||||
, encodeBytes
|
||||
)
|
||||
import Codec.CBOR.Write (toLazyByteString)
|
||||
import Data.Monoid (mconcat)
|
||||
import Codec.CBOR.Read (deserialiseFromBytes, DeserialiseFailure(..))
|
||||
|
||||
import Control.Exception (SomeException, evaluate, try)
|
||||
import Control.Monad (foldM, unless, when)
|
||||
import Crypto.Hash (Digest, SHA256, hash)
|
||||
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
|
||||
import Data.Bits ((.|.), (.&.), shiftL, shiftR)
|
||||
import Data.ByteArray (convert)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Map (Map)
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Data.Word (Word16, Word32, Word64)
|
||||
import Data.Text.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
|
||||
import Data.Word (Word16, Word32, Word64, Word8)
|
||||
import Database.SQLite.Simple (Connection)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as Base16
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
@@ -91,92 +73,316 @@ compressionNone = 0
|
||||
digestSha256 = 1
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- CBOR encoding helpers
|
||||
-- Manifest binary constants
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Canonical CBOR map length encoder.
|
||||
cmkLen :: Int -> Encoding
|
||||
cmkLen n = encodeMapLen (fromIntegral n)
|
||||
-- | Magic prefix identifying the fixed-order manifest v1 format.
|
||||
manifestMagic :: ByteString
|
||||
manifestMagic = "ARBMNFST"
|
||||
|
||||
-- | Decode a CBOR array of n elements.
|
||||
decodeListN :: Decoder s a -> Int -> Decoder s [a]
|
||||
decodeListN dec n = replicateM n dec
|
||||
-- | Manifest major version.
|
||||
manifestMajorVersion :: Word16
|
||||
manifestMajorVersion = 1
|
||||
|
||||
-- | Decode a CBOR map (sequence of key-value pairs).
|
||||
decodeMapN :: Decoder s a -> Decoder s b -> Int -> Decoder s [(a, b)]
|
||||
decodeMapN keyDec valDec n = forM [1..n] $ \_ ->
|
||||
keyDec >>= \k -> valDec >>= \v -> pure (k, v)
|
||||
-- | Manifest minor version.
|
||||
manifestMinorVersion :: Word16
|
||||
manifestMinorVersion = 0
|
||||
|
||||
decodeKey :: Text -> Decoder s ()
|
||||
decodeKey expected = do
|
||||
actual <- decodeString
|
||||
unless (actual == expected) $
|
||||
fail $ "expected key " ++ show expected ++ ", got " ++ show actual
|
||||
-- | Closure mode to byte.
|
||||
closureToByte :: ClosureMode -> Word8
|
||||
closureToByte = \case
|
||||
ClosureComplete -> 0
|
||||
ClosurePartial -> 1
|
||||
|
||||
-- | Canonical CBOR array length encoder.
|
||||
cakLen :: Int -> Encoding
|
||||
cakLen n = encodeListLen (fromIntegral n)
|
||||
closureFromByte :: Word8 -> Either String ClosureMode
|
||||
closureFromByte = \case
|
||||
0 -> Right ClosureComplete
|
||||
1 -> Right ClosurePartial
|
||||
n -> Left $ "unsupported closure byte: " ++ show n
|
||||
|
||||
-- | Encode a canonical CBOR map with key-value pairs as flat sequence.
|
||||
cmkPairs :: [(Text, Encoding)] -> Encoding
|
||||
cmkPairs [] = cmkLen 0
|
||||
cmkPairs kvs = cmkLen (length kvs) <> mconcat [encodeString k <> v | (k, v) <- kvs]
|
||||
|
||||
-- | Encode a canonical CBOR array.
|
||||
cakSeq :: [Encoding] -> Encoding
|
||||
cakSeq [] = cakLen 0
|
||||
cakSeq xs = cakLen (length xs) <> mconcat xs
|
||||
|
||||
-- | Encode a canonical CBOR text string.
|
||||
encText :: Text -> Encoding
|
||||
encText = encodeString
|
||||
|
||||
-- | Encode a canonical CBOR byte string.
|
||||
encBytes :: ByteString -> Encoding
|
||||
encBytes = encodeBytes
|
||||
-- | Metadata tag constants.
|
||||
tagPackage, tagVersion, tagDescription, tagLicense, tagCreatedBy :: Word16
|
||||
tagPackage = 1
|
||||
tagVersion = 2
|
||||
tagDescription = 3
|
||||
tagLicense = 4
|
||||
tagCreatedBy = 5
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Data types with CBOR instances
|
||||
-- Fixed-order manifest binary helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode a UTF-8 text string as: u32 length + UTF-8 bytes.
|
||||
encodeLengthPrefixedText :: Text -> ByteString
|
||||
encodeLengthPrefixedText t = encode32 (fromIntegral $ BS.length bs) <> bs
|
||||
where bs = encodeUtf8 t
|
||||
|
||||
-- | Decode a length-prefixed UTF-8 text string.
|
||||
-- Returns the decoded Text and the remaining ByteString.
|
||||
decodeLengthPrefixedText :: ByteString -> Either String (Text, ByteString)
|
||||
decodeLengthPrefixedText bs =
|
||||
case decode32be "text_length" bs of
|
||||
Left err -> Left $ "decodeLengthPrefixedText: " ++ err
|
||||
Right (len, rest) -> do
|
||||
let payloadLen = fromIntegral len
|
||||
when (BS.length rest < payloadLen) $
|
||||
Left "decodeLengthPrefixedText: string extends beyond input"
|
||||
let (textBytes, after) = BS.splitAt payloadLen rest
|
||||
case decodeUtf8' textBytes of
|
||||
Right txt -> Right (txt, after)
|
||||
Left _ -> Left "decodeLengthPrefixedText: invalid UTF-8"
|
||||
|
||||
-- | Encode a metadata value as a TLV entry: u16 tag + u32 length + raw bytes.
|
||||
encodeMetadataTLV :: Word16 -> ByteString -> ByteString
|
||||
encodeMetadataTLV tag val = encode16 tag <> encode32 (fromIntegral $ BS.length val) <> val
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Fixed-order manifest encoders
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode the entire manifest in fixed-order core + TLV tail layout.
|
||||
encodeManifest :: BundleManifest -> ByteString
|
||||
encodeManifest m =
|
||||
manifestMagic
|
||||
<> encode16 manifestMajorVersion
|
||||
<> encode16 manifestMinorVersion
|
||||
<> encodeLengthPrefixedText (manifestSchema m)
|
||||
<> encodeLengthPrefixedText (manifestBundleType m)
|
||||
<> encodeLengthPrefixedText (treeCalculus (manifestTree m))
|
||||
<> encodeLengthPrefixedText (nodeHashAlgorithm (treeNodeHash (manifestTree m)))
|
||||
<> encodeLengthPrefixedText (nodeHashDomain (treeNodeHash (manifestTree m)))
|
||||
<> encodeLengthPrefixedText (treeNodePayload (manifestTree m))
|
||||
<> encodeLengthPrefixedText (runtimeSemantics (manifestRuntime m))
|
||||
<> encodeLengthPrefixedText (runtimeEvaluation (manifestRuntime m))
|
||||
<> encodeLengthPrefixedText (runtimeAbi (manifestRuntime m))
|
||||
<> encode32 (fromIntegral $ length (runtimeCapabilities (manifestRuntime m)))
|
||||
<> encodeCapabilities (runtimeCapabilities (manifestRuntime m))
|
||||
<> BS.pack [closureToByte (manifestClosure m)]
|
||||
<> encode32 (fromIntegral $ length (manifestRoots m))
|
||||
<> encodeRoots (manifestRoots m)
|
||||
<> encode32 (fromIntegral $ length (manifestExports m))
|
||||
<> encodeExports (manifestExports m)
|
||||
<> encodeMetadataTLVs (manifestMetadata m)
|
||||
<> encode32 0 -- zero extension fields
|
||||
|
||||
encodeCapabilities :: [Text] -> ByteString
|
||||
encodeCapabilities caps = mconcat (map encodeLengthPrefixedText caps)
|
||||
|
||||
encodeRoots :: [BundleRoot] -> ByteString
|
||||
encodeRoots = mconcat . map encodeRoot
|
||||
|
||||
encodeRoot :: BundleRoot -> ByteString
|
||||
encodeRoot root =
|
||||
merkleHashToRaw (rootHash root)
|
||||
<> encodeLengthPrefixedText (rootRole root)
|
||||
|
||||
encodeExports :: [BundleExport] -> ByteString
|
||||
encodeExports = mconcat . map encodeExport
|
||||
|
||||
encodeExport :: BundleExport -> ByteString
|
||||
encodeExport exp =
|
||||
encodeLengthPrefixedText (exportName exp)
|
||||
<> merkleHashToRaw (exportRoot exp)
|
||||
<> encodeLengthPrefixedText (exportKind exp)
|
||||
<> encodeLengthPrefixedText (exportAbi exp)
|
||||
|
||||
-- | Encode metadata as: u32 field count + TLV entries for present fields.
|
||||
-- Metadata TLV values are raw UTF-8 bytes; the TLV length already carries size.
|
||||
encodeMetadataTLVs :: BundleMetadata -> ByteString
|
||||
encodeMetadataTLVs m =
|
||||
let entries = metadataTLVEntries m
|
||||
in encode32 (fromIntegral $ length entries) <> encodeTLVs entries
|
||||
|
||||
metadataTLVEntries :: BundleMetadata -> [(Word16, ByteString)]
|
||||
metadataTLVEntries m =
|
||||
maybeEntry tagPackage (metadataPackage m)
|
||||
++ maybeEntry tagVersion (metadataVersion m)
|
||||
++ maybeEntry tagDescription (metadataDescription m)
|
||||
++ maybeEntry tagLicense (metadataLicense m)
|
||||
++ maybeEntry tagCreatedBy (metadataCreatedBy m)
|
||||
where
|
||||
maybeEntry _ Nothing = []
|
||||
maybeEntry tag (Just value) = [(tag, encodeUtf8 value)]
|
||||
|
||||
encodeTLVs :: [(Word16, ByteString)] -> ByteString
|
||||
encodeTLVs tlvs = mconcat (map (uncurry encodeMetadataTLV) tlvs)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Fixed-order manifest decoders
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Decode the manifest from fixed-order core + TLV tail bytes.
|
||||
-- All remaining bytes after the core fields are treated as the TLV tail.
|
||||
decodeManifest :: ByteString -> Either String BundleManifest
|
||||
decodeManifest bs = do
|
||||
-- Header
|
||||
when (BS.length bs < 8) $ Left "manifest too short for magic"
|
||||
when (BS.take 8 bs /= manifestMagic) $ Left "invalid manifest magic"
|
||||
let rest = BS.drop 8 bs
|
||||
(major, rest') <- decode16be "major" rest
|
||||
when (major /= manifestMajorVersion) $ Left $ "unsupported manifest major version: " ++ show major
|
||||
(_minor, rest'') <- decode16be "minor" rest'
|
||||
|
||||
-- Core strings
|
||||
(schema, rest''') <- decodeLengthPrefixedText rest''
|
||||
(bundleType, rest'''') <- decodeLengthPrefixedText rest'''
|
||||
|
||||
-- Tree spec fields (flat)
|
||||
(calc, rest1) <- decodeLengthPrefixedText rest''''
|
||||
(alg, rest2) <- decodeLengthPrefixedText rest1
|
||||
(domain, rest3) <- decodeLengthPrefixedText rest2
|
||||
(payload, rest4) <- decodeLengthPrefixedText rest3
|
||||
|
||||
-- Runtime spec fields (flat)
|
||||
(sem, restR1) <- decodeLengthPrefixedText rest4
|
||||
(eval, restR2) <- decodeLengthPrefixedText restR1
|
||||
(abi, restR3) <- decodeLengthPrefixedText restR2
|
||||
|
||||
(capCount, restR4) <- decode32be "capability_count" restR3
|
||||
let capLen = fromIntegral capCount
|
||||
(caps, restR5) <- decodeCapabilities capLen restR4
|
||||
|
||||
-- Closure
|
||||
when (BS.length restR5 < 1) $ Left "manifest truncated: missing closure byte"
|
||||
let (closureByte, restR6) = BS.splitAt 1 restR5
|
||||
closure <- closureFromByte (head $ BS.unpack closureByte)
|
||||
|
||||
-- Roots
|
||||
(rootCount, restR7) <- decode32be "root_count" restR6
|
||||
let rootCountInt = fromIntegral rootCount
|
||||
(roots, restR8) <- decodeRoots rootCountInt restR7
|
||||
|
||||
-- Exports
|
||||
(exportCount, restR9) <- decode32be "export_count" restR8
|
||||
let exportCountInt = fromIntegral exportCount
|
||||
(exports, restR10) <- decodeExports exportCountInt restR9
|
||||
|
||||
-- TLV tail
|
||||
(metadata, _ext) <- decodeMetadataAndExtensions restR10
|
||||
|
||||
pure BundleManifest
|
||||
{ manifestSchema = schema
|
||||
, manifestBundleType = bundleType
|
||||
, manifestTree = TreeSpec
|
||||
{ treeCalculus = calc
|
||||
, treeNodeHash = NodeHashSpec
|
||||
{ nodeHashAlgorithm = alg
|
||||
, nodeHashDomain = domain
|
||||
}
|
||||
, treeNodePayload = payload
|
||||
}
|
||||
, manifestRuntime = RuntimeSpec
|
||||
{ runtimeSemantics = sem
|
||||
, runtimeEvaluation = eval
|
||||
, runtimeAbi = abi
|
||||
, runtimeCapabilities = caps
|
||||
}
|
||||
, manifestClosure = closure
|
||||
, manifestRoots = roots
|
||||
, manifestExports = exports
|
||||
, manifestMetadata = metadata
|
||||
}
|
||||
|
||||
-- | Decode length-prefixed capability strings.
|
||||
decodeCapabilities :: Int -> ByteString -> Either String ([Text], ByteString)
|
||||
decodeCapabilities 0 bs = Right ([], bs)
|
||||
decodeCapabilities n bs = do
|
||||
(txt, rest) <- decodeLengthPrefixedText bs
|
||||
(restTxts, restFinal) <- decodeCapabilities (n - 1) rest
|
||||
Right (txt : restTxts, restFinal)
|
||||
|
||||
-- | Decode root entries.
|
||||
decodeRoots :: Int -> ByteString -> Either String ([BundleRoot], ByteString)
|
||||
decodeRoots 0 bs = Right ([], bs)
|
||||
decodeRoots n bs = do
|
||||
when (BS.length bs < 32) $ Left "decodeRoots: truncated root hash"
|
||||
let (hashBytes, rest) = BS.splitAt 32 bs
|
||||
role <- decodeLengthPrefixedText rest
|
||||
(restRoots, restFinal) <- decodeRoots (n - 1) (snd role)
|
||||
Right (BundleRoot (rawToMerkleHash hashBytes) (fst role) : restRoots, restFinal)
|
||||
|
||||
-- | Decode export entries.
|
||||
decodeExports :: Int -> ByteString -> Either String ([BundleExport], ByteString)
|
||||
decodeExports 0 bs = Right ([], bs)
|
||||
decodeExports n bs = do
|
||||
name <- decodeLengthPrefixedText bs
|
||||
when (BS.length (snd name) < 32) $ Left "decodeExports: truncated export root hash"
|
||||
let (hashBytes, rest) = BS.splitAt 32 (snd name)
|
||||
kind <- decodeLengthPrefixedText rest
|
||||
abi <- decodeLengthPrefixedText (snd kind)
|
||||
(restExports, restFinal) <- decodeExports (n - 1) (snd abi)
|
||||
Right (BundleExport (fst name) (rawToMerkleHash hashBytes) (fst kind) (fst abi) : restExports, restFinal)
|
||||
|
||||
-- | Decode TLV tail into metadata and extensions.
|
||||
-- Layout: u32 metadata-count, metadata TLVs, u32 extension-count, extension TLVs.
|
||||
-- For now, known metadata tags are decoded and extension TLVs are skipped.
|
||||
decodeMetadataAndExtensions :: ByteString -> Either String (BundleMetadata, ByteString)
|
||||
decodeMetadataAndExtensions bs = do
|
||||
(metadataCount, rest1) <- decode32be "metadata_field_count" bs
|
||||
(metadataTlvs, rest2) <- decodeTLVs (fromIntegral metadataCount) rest1
|
||||
metadata <- decodeMetadataTLVs metadataTlvs
|
||||
(extensionCount, rest3) <- decode32be "extension_field_count" rest2
|
||||
(_extensionTlvs, rest4) <- decodeTLVs (fromIntegral extensionCount) rest3
|
||||
unless (BS.null rest4) $ Left "trailing bytes after manifest TLV tail"
|
||||
Right (metadata, rest4)
|
||||
|
||||
-- | Decode a fixed number of TLV entries.
|
||||
decodeTLVs :: Int -> ByteString -> Either String ([TLVEntry], ByteString)
|
||||
decodeTLVs 0 bs = Right ([], bs)
|
||||
decodeTLVs n bs = do
|
||||
(tag, rest1) <- decode16be "tlv_tag" bs
|
||||
(len, rest2) <- decode32be "tlv_length" rest1
|
||||
let payloadLen = fromIntegral len
|
||||
when (BS.length rest2 < payloadLen) $ Left "TLV value extends beyond input"
|
||||
let (value, after) = BS.splitAt payloadLen rest2
|
||||
(restTlvs, restFinal) <- decodeTLVs (n - 1) after
|
||||
Right ((tag, value) : restTlvs, restFinal)
|
||||
|
||||
-- | Decode known metadata TLV entries into BundleMetadata.
|
||||
-- Unknown tags are ignored.
|
||||
decodeMetadataTLVs :: [(Word16, ByteString)] -> Either String BundleMetadata
|
||||
decodeMetadataTLVs tlvs = do
|
||||
pkg <- decodeOptionalMetadataText tagPackage
|
||||
ver <- decodeOptionalMetadataText tagVersion
|
||||
desc <- decodeOptionalMetadataText tagDescription
|
||||
lic <- decodeOptionalMetadataText tagLicense
|
||||
by <- decodeOptionalMetadataText tagCreatedBy
|
||||
pure BundleMetadata
|
||||
{ metadataPackage = pkg
|
||||
, metadataVersion = ver
|
||||
, metadataDescription = desc
|
||||
, metadataLicense = lic
|
||||
, metadataCreatedBy = by
|
||||
}
|
||||
where
|
||||
lookupTag t = go t tlvs
|
||||
go _ [] = Nothing
|
||||
go t ((tag, val):rest)
|
||||
| tag == t = Just val
|
||||
| otherwise = go t rest
|
||||
decodeOptionalMetadataText tag =
|
||||
case lookupTag tag of
|
||||
Nothing -> Right Nothing
|
||||
Just raw -> case decodeUtf8' raw of
|
||||
Right txt -> Right (Just txt)
|
||||
Left _ -> Left $ "metadata TLV has invalid UTF-8 for tag " ++ show tag
|
||||
|
||||
type TLVEntry = (Word16, ByteString)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Data types
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Closure declaration.
|
||||
data ClosureMode = ClosureComplete | ClosurePartial
|
||||
deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
toCBORClosure :: ClosureMode -> Encoding
|
||||
toCBORClosure = encText . \case
|
||||
ClosureComplete -> "complete"
|
||||
ClosurePartial -> "partial"
|
||||
|
||||
closureFromCBOR :: Decoder s ClosureMode
|
||||
closureFromCBOR = decodeString >>= \case
|
||||
"complete" -> pure ClosureComplete
|
||||
"partial" -> pure ClosurePartial
|
||||
other -> fail $ "ClosureMode: " ++ show other
|
||||
|
||||
-- | Hash specification (algorithm + domain strings).
|
||||
data NodeHashSpec = NodeHashSpec
|
||||
{ nodeHashAlgorithm :: Text
|
||||
, nodeHashDomain :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
toCBORNodeHashSpec :: NodeHashSpec -> Encoding
|
||||
toCBORNodeHashSpec (NodeHashSpec alg dom) =
|
||||
cmkPairs
|
||||
[ ("algorithm", encText alg)
|
||||
, ("domain", encText dom)
|
||||
]
|
||||
|
||||
nodeHashSpecFromCBOR :: Decoder s NodeHashSpec
|
||||
nodeHashSpecFromCBOR = do
|
||||
n <- decodeMapLen
|
||||
unless (n == 2) $ fail "NodeHashSpec: must have exactly 2 entries"
|
||||
decodeKey "algorithm"
|
||||
alg <- decodeString
|
||||
decodeKey "domain"
|
||||
dom <- decodeString
|
||||
pure (NodeHashSpec alg dom)
|
||||
|
||||
-- | Tree specification.
|
||||
data TreeSpec = TreeSpec
|
||||
{ treeCalculus :: Text
|
||||
@@ -184,26 +390,6 @@ data TreeSpec = TreeSpec
|
||||
, treeNodePayload :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
toCBORTreeSpec :: TreeSpec -> Encoding
|
||||
toCBORTreeSpec (TreeSpec calc hspec payload) =
|
||||
cmkPairs
|
||||
[ ("calculus", encText calc)
|
||||
, ("nodeHash", toCBORNodeHashSpec hspec)
|
||||
, ("nodePayload", encText payload)
|
||||
]
|
||||
|
||||
treeSpecFromCBOR :: Decoder s TreeSpec
|
||||
treeSpecFromCBOR = do
|
||||
n <- decodeMapLen
|
||||
unless (n == 3) $ fail "TreeSpec: must have exactly 3 entries"
|
||||
decodeKey "calculus"
|
||||
calc <- decodeString
|
||||
decodeKey "nodeHash"
|
||||
hspec <- nodeHashSpecFromCBOR
|
||||
decodeKey "nodePayload"
|
||||
payload <- decodeString
|
||||
pure (TreeSpec calc hspec payload)
|
||||
|
||||
-- | Runtime specification.
|
||||
data RuntimeSpec = RuntimeSpec
|
||||
{ runtimeSemantics :: Text
|
||||
@@ -212,53 +398,12 @@ data RuntimeSpec = RuntimeSpec
|
||||
, runtimeCapabilities :: [Text]
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
toCBORRuntimeSpec :: RuntimeSpec -> Encoding
|
||||
toCBORRuntimeSpec (RuntimeSpec sem eval abi caps) =
|
||||
cmkPairs
|
||||
[ ("semantics", encText sem)
|
||||
, ("evaluation", encText eval)
|
||||
, ("abi", encText abi)
|
||||
, ("capabilities", cakSeq (map encText caps))
|
||||
]
|
||||
|
||||
runtimeSpecFromCBOR :: Decoder s RuntimeSpec
|
||||
runtimeSpecFromCBOR = do
|
||||
n <- decodeMapLen
|
||||
unless (n == 4) $ fail "RuntimeSpec: must have exactly 4 entries"
|
||||
decodeKey "semantics"
|
||||
sem <- decodeString
|
||||
decodeKey "evaluation"
|
||||
eval <- decodeString
|
||||
decodeKey "abi"
|
||||
abi <- decodeString
|
||||
decodeKey "capabilities"
|
||||
clen <- decodeListLen
|
||||
caps <- decodeListN decodeString clen
|
||||
pure (RuntimeSpec sem eval abi caps)
|
||||
|
||||
-- | A root hash reference.
|
||||
data BundleRoot = BundleRoot
|
||||
{ rootHash :: MerkleHash
|
||||
, rootRole :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
toCBORBundleRoot :: BundleRoot -> Encoding
|
||||
toCBORBundleRoot (BundleRoot h role) =
|
||||
cmkPairs
|
||||
[ ("hash", encBytes (merkleHashToRaw h))
|
||||
, ("role", encText role)
|
||||
]
|
||||
|
||||
bundleRootFromCBOR :: Decoder s BundleRoot
|
||||
bundleRootFromCBOR = do
|
||||
n <- decodeMapLen
|
||||
unless (n == 2) $ fail "BundleRoot: must have exactly 2 entries"
|
||||
decodeKey "hash"
|
||||
hRaw <- decodeBytes
|
||||
decodeKey "role"
|
||||
role <- decodeString
|
||||
pure (BundleRoot (rawToMerkleHash hRaw) role)
|
||||
|
||||
-- | An export entry.
|
||||
data BundleExport = BundleExport
|
||||
{ exportName :: Text
|
||||
@@ -267,29 +412,6 @@ data BundleExport = BundleExport
|
||||
, exportAbi :: Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
toCBORBundleExport :: BundleExport -> Encoding
|
||||
toCBORBundleExport (BundleExport name h kind abi) =
|
||||
cmkPairs
|
||||
[ ("name", encText name)
|
||||
, ("root", encBytes (merkleHashToRaw h))
|
||||
, ("kind", encText kind)
|
||||
, ("abi", encText abi)
|
||||
]
|
||||
|
||||
bundleExportFromCBOR :: Decoder s BundleExport
|
||||
bundleExportFromCBOR = do
|
||||
n <- decodeMapLen
|
||||
unless (n == 4) $ fail "BundleExport: must have exactly 4 entries"
|
||||
decodeKey "name"
|
||||
name <- decodeString
|
||||
decodeKey "root"
|
||||
hRaw <- decodeBytes
|
||||
decodeKey "kind"
|
||||
kind <- decodeString
|
||||
decodeKey "abi"
|
||||
abi <- decodeString
|
||||
pure (BundleExport name (rawToMerkleHash hRaw) kind abi)
|
||||
|
||||
-- | Optional package metadata.
|
||||
data BundleMetadata = BundleMetadata
|
||||
{ metadataPackage :: Maybe Text
|
||||
@@ -299,33 +421,6 @@ data BundleMetadata = BundleMetadata
|
||||
, metadataCreatedBy :: Maybe Text
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
metadataFromCBOR :: Decoder s BundleMetadata
|
||||
metadataFromCBOR = do
|
||||
mlen <- decodeMapLen
|
||||
entries <- decodeMapN decodeString decodeString mlen
|
||||
let lookupText k = go k entries
|
||||
go _ [] = Nothing
|
||||
go k ((k', v):rest)
|
||||
| k == k' = Just v
|
||||
| otherwise = go k rest
|
||||
pure BundleMetadata
|
||||
{ metadataPackage = lookupText "package"
|
||||
, metadataVersion = lookupText "version"
|
||||
, metadataDescription = lookupText "description"
|
||||
, metadataLicense = lookupText "license"
|
||||
, metadataCreatedBy = lookupText "createdBy"
|
||||
}
|
||||
|
||||
metadataToCBOR :: BundleMetadata -> Encoding
|
||||
metadataToCBOR (BundleMetadata pkg ver desc lic by) =
|
||||
let pairs =
|
||||
maybe [] (\v -> [("package", encText v)]) pkg
|
||||
++ maybe [] (\v -> [("version", encText v)]) ver
|
||||
++ maybe [] (\v -> [("description", encText v)]) desc
|
||||
++ maybe [] (\v -> [("license", encText v)]) lic
|
||||
++ maybe [] (\v -> [("createdBy", encText v)]) by
|
||||
in cmkPairs pairs
|
||||
|
||||
-- | The manifest: top-level bundle metadata.
|
||||
data BundleManifest = BundleManifest
|
||||
{ manifestSchema :: Text
|
||||
@@ -338,43 +433,6 @@ data BundleManifest = BundleManifest
|
||||
, manifestMetadata :: BundleMetadata
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
manifestToCBOR :: BundleManifest -> Encoding
|
||||
manifestToCBOR m =
|
||||
cmkPairs
|
||||
[ ("schema", encText (manifestSchema m))
|
||||
, ("bundleType", encText (manifestBundleType m))
|
||||
, ("tree", toCBORTreeSpec (manifestTree m))
|
||||
, ("runtime", toCBORRuntimeSpec (manifestRuntime m))
|
||||
, ("closure", toCBORClosure (manifestClosure m))
|
||||
, ("roots", cakSeq (map toCBORBundleRoot (manifestRoots m)))
|
||||
, ("exports", cakSeq (map toCBORBundleExport (manifestExports m)))
|
||||
, ("metadata", metadataToCBOR (manifestMetadata m))
|
||||
]
|
||||
|
||||
manifestFromCBOR :: Decoder s BundleManifest
|
||||
manifestFromCBOR = do
|
||||
n <- decodeMapLen
|
||||
unless (n == 8) $ fail "BundleManifest: must have exactly 8 entries"
|
||||
decodeKey "schema"
|
||||
schema <- decodeString
|
||||
decodeKey "bundleType"
|
||||
bundleType <- decodeString
|
||||
decodeKey "tree"
|
||||
tree <- treeSpecFromCBOR
|
||||
decodeKey "runtime"
|
||||
runtime <- runtimeSpecFromCBOR
|
||||
decodeKey "closure"
|
||||
closure <- closureFromCBOR
|
||||
decodeKey "roots"
|
||||
rlen <- decodeListLen
|
||||
roots <- decodeListN bundleRootFromCBOR rlen
|
||||
decodeKey "exports"
|
||||
elen <- decodeListLen
|
||||
exports <- decodeListN bundleExportFromCBOR elen
|
||||
decodeKey "metadata"
|
||||
metadata <- metadataFromCBOR
|
||||
pure (BundleManifest schema bundleType tree runtime closure roots exports metadata)
|
||||
|
||||
-- | Portable executable-object bundle.
|
||||
--
|
||||
-- Merkle node payloads remain the language-neutral executable core:
|
||||
@@ -388,28 +446,12 @@ data Bundle = Bundle
|
||||
, bundleManifestBytes :: ByteString
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- CBOR manifest serialization
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode the manifest as canonical CBOR.
|
||||
encodeManifest :: BundleManifest -> ByteString
|
||||
encodeManifest m = BL.toStrict (toLazyByteString (manifestToCBOR m))
|
||||
|
||||
-- | Decode a manifest from CBOR bytes.
|
||||
decodeManifest :: ByteString -> Either String BundleManifest
|
||||
decodeManifest bs =
|
||||
case deserialiseFromBytes manifestFromCBOR (BL.fromStrict bs) of
|
||||
Right (rest, m)
|
||||
| BS.null (BL.toStrict rest) -> Right m
|
||||
| otherwise -> Left "trailing bytes after manifest CBOR"
|
||||
Left (DeserialiseFailure _ msg) -> Left msg
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bundle encoding
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
-- | Encode a Bundle to portable Bundle v1 bytes.
|
||||
-- The manifest is serialized using the fixed-order core + TLV tail format.
|
||||
encodeBundle :: Bundle -> ByteString
|
||||
encodeBundle bundle =
|
||||
let nodeSection = encodeNodeSection (bundleNodes bundle)
|
||||
|
||||
Reference in New Issue
Block a user