Wire.hs (33852B)
1 {-# LANGUAGE DeriveGeneric #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 4 module Wire 5 ( Bundle (..) 6 , BundleManifest (..) 7 , TreeSpec (..) 8 , NodeHashSpec (..) 9 , RuntimeSpec (..) 10 , BundleRoot (..) 11 , BundleExport (..) 12 , BundleMetadata 13 , ClosureMode (..) 14 , BundleNode (..) 15 , encodeBundle 16 , decodeBundle 17 , verifyBundle 18 , buildBundle 19 , reconstructBundleTerms 20 , defaultExportNames 21 ) where 22 23 import Research hiding (Node) 24 25 import Control.Monad (foldM, forM_, unless, when) 26 import Data.Bits (shiftL, shiftR, (.|.), (.&.)) 27 import Data.ByteString (ByteString) 28 import Data.Foldable (traverse_) 29 import qualified Data.Foldable as Foldable 30 import Data.List (mapAccumL) 31 import Data.Map (Map) 32 import qualified Data.Map as Map 33 import Data.Sequence (Seq, (|>)) 34 import qualified Data.Sequence as Seq 35 import Data.Set (Set) 36 import qualified Data.Set as Set 37 import Data.Text (Text, unpack) 38 import Data.Text.Encoding (decodeUtf8', encodeUtf8) 39 import Data.Vector (Vector) 40 import qualified Data.Vector as V 41 import qualified Data.Vector.Mutable as MV 42 import Data.Word (Word16, Word32, Word64, Word8) 43 import GHC.Generics (Generic) 44 45 import qualified Data.ByteString as BS 46 import qualified Data.Text as T 47 48 -- --------------------------------------------------------------------------- 49 -- Container constants 50 -- --------------------------------------------------------------------------- 51 52 bundleMajorVersion :: Word16 53 bundleMajorVersion = 1 54 55 bundleMinorVersion :: Word16 56 bundleMinorVersion = 0 57 58 bundleMagic :: ByteString 59 bundleMagic = BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x43, 0x58] 60 61 headerLength :: Int 62 headerLength = 32 63 64 sectionEntryLength :: Int 65 sectionEntryLength = 32 66 67 sectionManifest, sectionNodes :: Word32 68 sectionManifest = 1 69 sectionNodes = 2 70 71 flagCritical :: Word16 72 flagCritical = 0x0001 73 74 compressionNone :: Word16 75 compressionNone = 0 76 77 -- --------------------------------------------------------------------------- 78 -- Manifest constants 79 -- --------------------------------------------------------------------------- 80 81 manifestMagic :: ByteString 82 manifestMagic = "ARBMNFST" 83 84 manifestMajorVersion :: Word16 85 manifestMajorVersion = 1 86 87 manifestMinorVersion :: Word16 88 manifestMinorVersion = 1 89 90 closureToByte :: ClosureMode -> Word8 91 closureToByte = \case 92 ClosureComplete -> 0 93 ClosurePartial -> 1 94 95 closureFromByte :: Word8 -> Either String ClosureMode 96 closureFromByte = \case 97 0 -> Right ClosureComplete 98 1 -> Right ClosurePartial 99 n -> Left $ "unsupported closure byte: " ++ show n 100 101 tagPackage, tagVersion, tagDescription, tagLicense, tagCreatedBy :: Word16 102 tagPackage = 1 103 tagVersion = 2 104 tagDescription = 3 105 tagLicense = 4 106 tagCreatedBy = 5 107 108 -- --------------------------------------------------------------------------- 109 -- Text encoding helpers 110 -- --------------------------------------------------------------------------- 111 112 encodeLengthPrefixedText :: Text -> ByteString 113 encodeLengthPrefixedText t = encode32 (fromIntegral $ BS.length bs) <> bs 114 where bs = encodeUtf8 t 115 116 decodeLengthPrefixedText :: ByteString -> Either String (Text, ByteString) 117 decodeLengthPrefixedText bs = do 118 (len, rest) <- decode32be "text_length" bs 119 let payloadLen = fromIntegral len 120 when (BS.length rest < payloadLen) $ 121 Left "decodeLengthPrefixedText: string extends beyond input" 122 let (textBytes, after) = BS.splitAt payloadLen rest 123 case decodeUtf8' textBytes of 124 Right txt -> Right (txt, after) 125 Left _ -> Left "decodeLengthPrefixedText: invalid UTF-8" 126 127 encodeMetadataTLV :: Word16 -> ByteString -> ByteString 128 encodeMetadataTLV tag val = encode16 tag <> encode32 (fromIntegral $ BS.length val) <> val 129 130 -- --------------------------------------------------------------------------- 131 -- Manifest encoders 132 -- --------------------------------------------------------------------------- 133 134 encodeManifest :: BundleManifest -> ByteString 135 encodeManifest m = 136 manifestMagic 137 <> encode16 manifestMajorVersion 138 <> encode16 manifestMinorVersion 139 <> encodeLengthPrefixedText (manifestSchema m) 140 <> encodeLengthPrefixedText (manifestBundleType m) 141 <> encodeLengthPrefixedText (treeCalculus (manifestTree m)) 142 <> encodeLengthPrefixedText (nodeHashAlgorithm (treeNodeHash (manifestTree m))) 143 <> encodeLengthPrefixedText (nodeHashDomain (treeNodeHash (manifestTree m))) 144 <> encodeLengthPrefixedText (treeNodePayload (manifestTree m)) 145 <> encodeLengthPrefixedText (runtimeSemantics (manifestRuntime m)) 146 <> encodeLengthPrefixedText (runtimeEvaluation (manifestRuntime m)) 147 <> encodeLengthPrefixedText (runtimeAbi (manifestRuntime m)) 148 <> encode32 (fromIntegral $ length (runtimeCapabilities (manifestRuntime m))) 149 <> encodeCapabilities (runtimeCapabilities (manifestRuntime m)) 150 <> BS.pack [closureToByte (manifestClosure m)] 151 <> encode32 (fromIntegral $ length (manifestRoots m)) 152 <> encodeRoots (manifestRoots m) 153 <> encode32 (fromIntegral $ length (manifestExports m)) 154 <> encodeExports (manifestExports m) 155 <> encodeMetadataTLVs (manifestMetadata m) 156 <> encode32 0 157 158 encodeCapabilities :: [Text] -> ByteString 159 encodeCapabilities = mconcat . map encodeLengthPrefixedText 160 161 encodeRoots :: [BundleRoot] -> ByteString 162 encodeRoots = mconcat . map encodeRoot 163 164 encodeRoot :: BundleRoot -> ByteString 165 encodeRoot root = encode32 (rootIndex root) <> encodeLengthPrefixedText (rootRole root) 166 167 encodeExports :: [BundleExport] -> ByteString 168 encodeExports = mconcat . map encodeExport 169 170 encodeExport :: BundleExport -> ByteString 171 encodeExport exp = 172 encodeLengthPrefixedText (exportName exp) 173 <> encode32 (exportRoot exp) 174 <> encodeLengthPrefixedText (exportKind exp) 175 <> encodeLengthPrefixedText (exportAbi exp) 176 177 encodeMetadataTLVs :: BundleMetadata -> ByteString 178 encodeMetadataTLVs m = 179 let entries = metadataTLVEntries m 180 in encode32 (fromIntegral $ length entries) <> encodeTLVs entries 181 182 metadataTLVEntries :: BundleMetadata -> [(Word16, ByteString)] 183 metadataTLVEntries m = 184 maybeEntry tagPackage (metadataPackage m) 185 ++ maybeEntry tagVersion (metadataVersion m) 186 ++ maybeEntry tagDescription (metadataDescription m) 187 ++ maybeEntry tagLicense (metadataLicense m) 188 ++ maybeEntry tagCreatedBy (metadataCreatedBy m) 189 where 190 maybeEntry _ Nothing = [] 191 maybeEntry tag (Just value) = [(tag, encodeUtf8 value)] 192 193 encodeTLVs :: [(Word16, ByteString)] -> ByteString 194 encodeTLVs = mconcat . map (uncurry encodeMetadataTLV) 195 196 -- --------------------------------------------------------------------------- 197 -- Manifest decoders 198 -- --------------------------------------------------------------------------- 199 200 decodeManifest :: ByteString -> Either String BundleManifest 201 decodeManifest bs = do 202 when (BS.length bs < 8) $ Left "manifest too short for magic" 203 when (BS.take 8 bs /= manifestMagic) $ Left "invalid manifest magic" 204 let rest = BS.drop 8 bs 205 (major, rest') <- decode16be "major" rest 206 (minor, rest'') <- decode16be "minor" rest' 207 when (major /= manifestMajorVersion) $ 208 Left $ "unsupported manifest major version: " ++ show major 209 when (minor /= manifestMinorVersion) $ 210 Left $ "unsupported manifest minor version: " ++ show minor 211 212 (schema, r1) <- decodeLengthPrefixedText rest'' 213 (bundleType, r2) <- decodeLengthPrefixedText r1 214 (calc, r3) <- decodeLengthPrefixedText r2 215 (alg, r4) <- decodeLengthPrefixedText r3 216 (domain, r5) <- decodeLengthPrefixedText r4 217 (payload, r6) <- decodeLengthPrefixedText r5 218 (sem, r7) <- decodeLengthPrefixedText r6 219 (eval, r8) <- decodeLengthPrefixedText r7 220 (abi, r9) <- decodeLengthPrefixedText r8 221 222 (capCount, r10) <- decode32be "capability_count" r9 223 (caps, r11) <- decodeCapabilities (fromIntegral capCount) r10 224 225 when (BS.length r11 < 1) $ Left "manifest truncated: missing closure byte" 226 let (closureByte, r12) = BS.splitAt 1 r11 227 closure <- closureFromByte (head $ BS.unpack closureByte) 228 229 (rootCount, r13) <- decode32be "root_count" r12 230 (roots, r14) <- decodeRoots (fromIntegral rootCount) r13 231 232 (exportCount, r15) <- decode32be "export_count" r14 233 (exports, r16) <- decodeExports (fromIntegral exportCount) r15 234 235 (metadata, _ext) <- decodeMetadataAndExtensions r16 236 237 pure BundleManifest 238 { manifestSchema = schema 239 , manifestBundleType = bundleType 240 , manifestTree = TreeSpec 241 { treeCalculus = calc 242 , treeNodeHash = NodeHashSpec 243 { nodeHashAlgorithm = alg 244 , nodeHashDomain = domain 245 } 246 , treeNodePayload = payload 247 } 248 , manifestRuntime = RuntimeSpec 249 { runtimeSemantics = sem 250 , runtimeEvaluation = eval 251 , runtimeAbi = abi 252 , runtimeCapabilities = caps 253 } 254 , manifestClosure = closure 255 , manifestRoots = roots 256 , manifestExports = exports 257 , manifestMetadata = metadata 258 } 259 260 decodeCapabilities :: Int -> ByteString -> Either String ([Text], ByteString) 261 decodeCapabilities 0 bs = Right ([], bs) 262 decodeCapabilities n bs = do 263 (txt, rest) <- decodeLengthPrefixedText bs 264 (restTxts, restFinal) <- decodeCapabilities (n - 1) rest 265 Right (txt : restTxts, restFinal) 266 267 decodeRoots :: Int -> ByteString -> Either String ([BundleRoot], ByteString) 268 decodeRoots 0 bs = Right ([], bs) 269 decodeRoots n bs = do 270 (idx, rest1) <- decode32be "root_index" bs 271 (role, rest2) <- decodeLengthPrefixedText rest1 272 (restRoots, restFinal) <- decodeRoots (n - 1) rest2 273 Right (BundleRoot idx role : restRoots, restFinal) 274 275 decodeExports :: Int -> ByteString -> Either String ([BundleExport], ByteString) 276 decodeExports 0 bs = Right ([], bs) 277 decodeExports n bs = do 278 (name, r1) <- decodeLengthPrefixedText bs 279 (idx, r2) <- decode32be "export_root" r1 280 (kind, r3) <- decodeLengthPrefixedText r2 281 (abi, r4) <- decodeLengthPrefixedText r3 282 (restExports, restFinal) <- decodeExports (n - 1) r4 283 Right (BundleExport name idx kind abi : restExports, restFinal) 284 285 decodeMetadataAndExtensions :: ByteString -> Either String (BundleMetadata, ByteString) 286 decodeMetadataAndExtensions bs = do 287 (metadataCount, rest1) <- decode32be "metadata_field_count" bs 288 (metadataTlvs, rest2) <- decodeTLVs (fromIntegral metadataCount) rest1 289 metadata <- decodeMetadataTLVs metadataTlvs 290 (extensionCount, rest3) <- decode32be "extension_field_count" rest2 291 (_extensionTlvs, rest4) <- decodeTLVs (fromIntegral extensionCount) rest3 292 unless (BS.null rest4) $ Left "trailing bytes after manifest TLV tail" 293 Right (metadata, rest4) 294 295 decodeTLVs :: Int -> ByteString -> Either String ([TLVEntry], ByteString) 296 decodeTLVs 0 bs = Right ([], bs) 297 decodeTLVs n bs = do 298 (tag, r1) <- decode16be "tlv_tag" bs 299 (len, r2) <- decode32be "tlv_length" r1 300 let payloadLen = fromIntegral len 301 when (BS.length r2 < payloadLen) $ Left "TLV value extends beyond input" 302 let (value, after) = BS.splitAt payloadLen r2 303 (restTlvs, restFinal) <- decodeTLVs (n - 1) after 304 Right ((tag, value) : restTlvs, restFinal) 305 306 decodeMetadataTLVs :: [(Word16, ByteString)] -> Either String BundleMetadata 307 decodeMetadataTLVs tlvs = do 308 pkg <- lookupText tagPackage 309 ver <- lookupText tagVersion 310 desc <- lookupText tagDescription 311 lic <- lookupText tagLicense 312 by <- lookupText tagCreatedBy 313 pure BundleMetadata 314 { metadataPackage = pkg 315 , metadataVersion = ver 316 , metadataDescription = desc 317 , metadataLicense = lic 318 , metadataCreatedBy = by 319 } 320 where 321 lookupTag t = go t tlvs 322 go _ [] = Nothing 323 go t ((tag, val):rest) 324 | tag == t = Just val 325 | otherwise = go t rest 326 lookupText tag = 327 case lookupTag tag of 328 Nothing -> Right Nothing 329 Just raw -> case decodeUtf8' raw of 330 Right txt -> Right (Just txt) 331 Left _ -> Left $ "metadata TLV has invalid UTF-8 for tag " ++ show tag 332 333 type TLVEntry = (Word16, ByteString) 334 335 -- --------------------------------------------------------------------------- 336 -- Data types 337 -- --------------------------------------------------------------------------- 338 339 data ClosureMode = ClosureComplete | ClosurePartial 340 deriving (Show, Eq, Ord, Generic) 341 342 data NodeHashSpec = NodeHashSpec 343 { nodeHashAlgorithm :: Text 344 , nodeHashDomain :: Text 345 } deriving (Show, Eq, Ord, Generic) 346 347 data TreeSpec = TreeSpec 348 { treeCalculus :: Text 349 , treeNodeHash :: NodeHashSpec 350 , treeNodePayload :: Text 351 } deriving (Show, Eq, Ord, Generic) 352 353 data RuntimeSpec = RuntimeSpec 354 { runtimeSemantics :: Text 355 , runtimeEvaluation :: Text 356 , runtimeAbi :: Text 357 , runtimeCapabilities :: [Text] 358 } deriving (Show, Eq, Ord, Generic) 359 360 data BundleRoot = BundleRoot 361 { rootIndex :: Word32 362 , rootRole :: Text 363 } deriving (Show, Eq, Ord, Generic) 364 365 data BundleExport = BundleExport 366 { exportName :: Text 367 , exportRoot :: Word32 368 , exportKind :: Text 369 , exportAbi :: Text 370 } deriving (Show, Eq, Ord, Generic) 371 372 data BundleMetadata = BundleMetadata 373 { metadataPackage :: Maybe Text 374 , metadataVersion :: Maybe Text 375 , metadataDescription :: Maybe Text 376 , metadataLicense :: Maybe Text 377 , metadataCreatedBy :: Maybe Text 378 } deriving (Show, Eq, Ord, Generic) 379 380 data BundleManifest = BundleManifest 381 { manifestSchema :: Text 382 , manifestBundleType :: Text 383 , manifestTree :: TreeSpec 384 , manifestRuntime :: RuntimeSpec 385 , manifestClosure :: ClosureMode 386 , manifestRoots :: [BundleRoot] 387 , manifestExports :: [BundleExport] 388 , manifestMetadata :: BundleMetadata 389 } deriving (Show, Eq, Generic) 390 391 data BundleNode 392 = BNLeaf 393 | BNStem !Word32 394 | BNFork !Word32 !Word32 395 deriving (Show, Eq) 396 397 data Bundle = Bundle 398 { bundleVersion :: Word16 399 , bundleRoots :: [Word32] 400 , bundleNodes :: Seq BundleNode 401 , bundleManifest :: BundleManifest 402 , bundleManifestBytes :: ByteString 403 } deriving (Show, Eq) 404 405 -- --------------------------------------------------------------------------- 406 -- Bundle construction 407 -- --------------------------------------------------------------------------- 408 409 data NodeKey = KeyLeaf | KeyStem !Word32 | KeyFork !Word32 !Word32 410 deriving (Eq, Ord, Show) 411 412 buildBundle :: [(Text, T)] -> Bundle 413 buildBundle namedTerms = 414 let go :: T -> (Seq BundleNode, Map NodeKey Word32) -> (Word32, (Seq BundleNode, Map NodeKey Word32)) 415 go Leaf (nodes, seen) = 416 case Map.lookup KeyLeaf seen of 417 Just idx -> (idx, (nodes, seen)) 418 Nothing -> 419 let idx = fromIntegral (Seq.length nodes) 420 in (idx, (nodes |> BNLeaf, Map.insert KeyLeaf idx seen)) 421 go (Stem child) (nodes, seen) = 422 let (childIdx, state1) = go child (nodes, seen) 423 (nodes1, seen1) = state1 424 in case Map.lookup (KeyStem childIdx) seen1 of 425 Just idx -> (idx, state1) 426 Nothing -> 427 let idx = fromIntegral (Seq.length nodes1) 428 in (idx, (nodes1 |> BNStem childIdx, Map.insert (KeyStem childIdx) idx seen1)) 429 go (Fork left right) (nodes, seen) = 430 let (leftIdx, state1) = go left (nodes, seen) 431 (rightIdx, state2) = go right state1 432 (nodes2, seen2) = state2 433 in case Map.lookup (KeyFork leftIdx rightIdx) seen2 of 434 Just idx -> (idx, state2) 435 Nothing -> 436 let idx = fromIntegral (Seq.length nodes2) 437 in (idx, (nodes2 |> BNFork leftIdx rightIdx, Map.insert (KeyFork leftIdx rightIdx) idx seen2)) 438 439 processExport state (_, t) = let (idx, newState) = go t state in (newState, idx) 440 ((finalNodes, _), rootIndices) = mapAccumL processExport (Seq.empty, Map.empty) namedTerms 441 442 roots = zipWith mkRoot [0 :: Int ..] rootIndices 443 exports = zipWith mkExport namedTerms rootIndices 444 manifest = makeManifest roots exports 445 manifestBytes = encodeManifest manifest 446 in Bundle 447 { bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion 448 , bundleRoots = rootIndices 449 , bundleNodes = finalNodes 450 , bundleManifest = manifest 451 , bundleManifestBytes = manifestBytes 452 } 453 where 454 mkRoot 0 idx = BundleRoot idx "default" 455 mkRoot _ idx = BundleRoot idx "root" 456 mkExport (name, _) idx = BundleExport name idx "term" "arboricx.abi.tree.v1" 457 458 makeManifest :: [BundleRoot] -> [BundleExport] -> BundleManifest 459 makeManifest roots exports = BundleManifest 460 { manifestSchema = "arboricx.bundle.manifest.v1" 461 , manifestBundleType = "tree-calculus-executable-object" 462 , manifestTree = TreeSpec 463 { treeCalculus = "tree-calculus.v1" 464 , treeNodeHash = NodeHashSpec 465 { nodeHashAlgorithm = "indexed" 466 , nodeHashDomain = "arboricx.indexed.node.v1" 467 } 468 , treeNodePayload = "arboricx.indexed.payload.v1" 469 } 470 , manifestRuntime = RuntimeSpec 471 { runtimeSemantics = "tree-calculus.v1" 472 , runtimeEvaluation = "normal-order" 473 , runtimeAbi = "arboricx.abi.tree.v1" 474 , runtimeCapabilities = [] 475 } 476 , manifestClosure = ClosureComplete 477 , manifestRoots = roots 478 , manifestExports = exports 479 , manifestMetadata = BundleMetadata 480 { metadataPackage = Nothing 481 , metadataVersion = Nothing 482 , metadataDescription = Nothing 483 , metadataLicense = Nothing 484 , metadataCreatedBy = Just "arboricx" 485 } 486 } 487 488 -- --------------------------------------------------------------------------- 489 -- Bundle encoding / decoding 490 -- --------------------------------------------------------------------------- 491 492 encodeBundle :: Bundle -> ByteString 493 encodeBundle bundle = 494 let nodeSection = encodeNodeSection (bundleNodes bundle) 495 manifestBytes = bundleManifestBytes bundle 496 sectionCount = 2 497 dirOffset = fromIntegral headerLength 498 sectionDirLength = sectionCount * sectionEntryLength 499 manifestOffset = fromIntegral (headerLength + sectionDirLength) 500 nodesOffset = manifestOffset + fromIntegral (BS.length manifestBytes) 501 manifestEntry = encodeSectionEntry sectionManifest 1 flagCritical compressionNone 502 manifestOffset (fromIntegral $ BS.length manifestBytes) 503 nodesEntry = encodeSectionEntry sectionNodes 1 flagCritical compressionNone 504 nodesOffset (fromIntegral $ BS.length nodeSection) 505 header = encodeHeader bundleMajorVersion bundleMinorVersion 506 (fromIntegral sectionCount) 0 dirOffset 507 in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection 508 509 decodeBundle :: ByteString -> Either String Bundle 510 decodeBundle bs 511 | BS.take (BS.length bundleMagic) bs /= bundleMagic = Left "invalid magic" 512 | otherwise = do 513 (major, minor, sectionCount, _flags, dirOffset) <- decodePortableHeader bs 514 when (major /= bundleMajorVersion) $ 515 Left $ "unsupported bundle major version: " ++ show major 516 let dirStart = fromIntegral dirOffset 517 dirBytes = fromIntegral sectionCount * sectionEntryLength 518 when (BS.length bs < dirStart + dirBytes) $ 519 Left "bundle truncated in section directory" 520 let dirRaw = BS.take dirBytes $ BS.drop dirStart bs 521 entries <- decodeSectionEntries sectionCount dirRaw 522 traverse_ rejectUnknownCritical entries 523 manifestEntry <- requireSection sectionManifest entries 524 nodesEntry <- requireSection sectionNodes entries 525 manifestBytes <- readAndVerifySection bs manifestEntry 526 nodesBytes <- readAndVerifySection bs nodesEntry 527 manifest <- decodeManifest manifestBytes 528 when (treeNodePayload (manifestTree manifest) /= "arboricx.indexed.payload.v1") $ 529 Left "manifest does not use indexed payload" 530 nodes <- decodeNodeSection nodesBytes 531 let rootIndices = map rootIndex (manifestRoots manifest) 532 return Bundle 533 { bundleVersion = major * 1000 + minor 534 , bundleRoots = rootIndices 535 , bundleNodes = nodes 536 , bundleManifest = manifest 537 , bundleManifestBytes = manifestBytes 538 } 539 540 -- --------------------------------------------------------------------------- 541 -- Container encoding / decoding 542 -- --------------------------------------------------------------------------- 543 544 data SectionEntry = SectionEntry 545 { seType :: Word32 546 , seVersion :: Word16 547 , seFlags :: Word16 548 , seCompression :: Word16 549 , seOffset :: Word64 550 , seLength :: Word64 551 } deriving (Show, Eq) 552 553 encodeHeader :: Word16 -> Word16 -> Word32 -> Word64 -> Word64 -> ByteString 554 encodeHeader major minor sectionCount flags dirOffset = 555 bundleMagic 556 <> encode16 major 557 <> encode16 minor 558 <> encode32 sectionCount 559 <> encode64 flags 560 <> encode64 dirOffset 561 562 encodeSectionEntry :: Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> Word64 -> ByteString 563 encodeSectionEntry sectionType sectionVersion sectionFlags compression offset lengthBytes = 564 encode32 sectionType 565 <> encode16 sectionVersion 566 <> encode16 sectionFlags 567 <> encode16 compression 568 <> encode16 0 -- reserved 569 <> encode64 offset 570 <> encode64 lengthBytes 571 <> encode32 0 -- reserved padding 572 573 decodePortableHeader :: ByteString -> Either String (Word16, Word16, Word32, Word64, Word64) 574 decodePortableHeader bs 575 | BS.length bs < headerLength = Left "bundle too short for header" 576 | BS.take 8 bs /= bundleMagic = Left "invalid portable bundle magic" 577 | otherwise = do 578 (major, r1) <- decode16be "major_version" (BS.drop 8 bs) 579 (minor, r2) <- decode16be "minor_version" r1 580 (sectionCount, r3) <- decode32be "section_count" r2 581 (flags, r4) <- decode64be "flags" r3 582 (dirOffset, _) <- decode64be "directory_offset" r4 583 Right (major, minor, sectionCount, flags, dirOffset) 584 585 decodeSectionEntries :: Word32 -> ByteString -> Either String [SectionEntry] 586 decodeSectionEntries count bytes = reverse <$> go count bytes [] 587 where 588 go 0 _ acc = Right acc 589 go n bs acc = do 590 when (BS.length bs < sectionEntryLength) $ 591 Left "section directory truncated" 592 (sectionType, r1) <- decode32be "section_type" bs 593 (sectionVersion, r2) <- decode16be "section_version" r1 594 (sectionFlags, r3) <- decode16be "section_flags" r2 595 (compression, r4) <- decode16be "compression_codec" r3 596 (_reserved, r5) <- decode16be "reserved" r4 597 (offset, r6) <- decode64be "section_offset" r5 598 (len, r7) <- decode64be "section_length" r6 599 (_reserved2, rest) <- decode32be "reserved" r7 600 let entry = SectionEntry sectionType sectionVersion sectionFlags compression offset len 601 go (n - 1) rest (entry : acc) 602 603 rejectUnknownCritical :: SectionEntry -> Either String () 604 rejectUnknownCritical entry = 605 let known = seType entry `elem` [sectionManifest, sectionNodes] 606 critical = seFlags entry .&. flagCritical /= 0 607 in when (critical && not known) $ 608 Left $ "unknown critical section type: " ++ show (seType entry) 609 610 requireSection :: Word32 -> [SectionEntry] -> Either String SectionEntry 611 requireSection sectionType entries = 612 case filter ((== sectionType) . seType) entries of 613 [entry] -> Right entry 614 [] -> Left $ "missing required section type: " ++ show sectionType 615 _ -> Left $ "duplicate section type: " ++ show sectionType 616 617 readAndVerifySection :: ByteString -> SectionEntry -> Either String ByteString 618 readAndVerifySection bs entry = do 619 when (seCompression entry /= compressionNone) $ 620 Left $ "unsupported compression codec in section " ++ show (seType entry) 621 let offset = fromIntegral (seOffset entry) 622 len = fromIntegral (seLength entry) 623 when (offset < 0 || len < 0 || BS.length bs < offset + len) $ 624 Left $ "section extends beyond bundle end: " ++ show (seType entry) 625 Right $ BS.take len $ BS.drop offset bs 626 627 -- --------------------------------------------------------------------------- 628 -- Node section encoding / decoding 629 -- --------------------------------------------------------------------------- 630 631 serializeBundleNode :: BundleNode -> ByteString 632 serializeBundleNode BNLeaf = BS.pack [0x00] 633 serializeBundleNode (BNStem child) = BS.pack [0x01] <> encode32 child 634 serializeBundleNode (BNFork left right) = BS.pack [0x02] <> encode32 left <> encode32 right 635 636 encodeNodeSection :: Seq BundleNode -> ByteString 637 encodeNodeSection nodes = 638 encode64 (fromIntegral $ Seq.length nodes) 639 <> foldMap encodeNodeEntry nodes 640 where 641 encodeNodeEntry node = 642 let payload = serializeBundleNode node 643 in encode32 (fromIntegral $ BS.length payload) <> payload 644 645 decodeNodeSection :: ByteString -> Either String (Seq BundleNode) 646 decodeNodeSection bs = do 647 (nodeCount, rest) <- decode64be "node_count" bs 648 decodeNodeEntries nodeCount rest 649 650 decodeNodeEntries :: Word64 -> ByteString -> Either String (Seq BundleNode) 651 decodeNodeEntries count bs = go count bs Seq.empty 652 where 653 go 0 rest acc 654 | BS.null rest = Right acc 655 | otherwise = Left "trailing bytes after node section" 656 go n bytes acc 657 | BS.length bytes < 4 = 658 Left "not enough bytes for node entry length" 659 | otherwise = do 660 (plen, rest) <- decode32be "payload_len" bytes 661 let payloadLen = fromIntegral plen 662 if BS.length rest < payloadLen 663 then Left "payload extends beyond node section end" 664 else do 665 let (payload, after) = BS.splitAt payloadLen rest 666 node <- deserializeBundleNode payload 667 go (n - 1) after (acc |> node) 668 669 deserializeBundleNode :: ByteString -> Either String BundleNode 670 deserializeBundleNode payload = 671 case BS.uncons payload of 672 Just (0x00, rest) 673 | BS.null rest -> Right BNLeaf 674 | otherwise -> Left "invalid leaf payload length" 675 Just (0x01, rest) 676 | BS.length rest == 4 -> Right $ BNStem (decodeU32 rest) 677 | otherwise -> Left "invalid stem payload length" 678 Just (0x02, rest) 679 | BS.length rest == 8 -> 680 let (leftBytes, rightBytes) = BS.splitAt 4 rest 681 in Right $ BNFork (decodeU32 leftBytes) (decodeU32 rightBytes) 682 | otherwise -> Left "invalid fork payload length" 683 _ -> Left "invalid node payload" 684 685 decodeU32 :: ByteString -> Word32 686 decodeU32 bs = 687 let b0 = fromIntegral (BS.index bs 0) :: Word32 688 b1 = fromIntegral (BS.index bs 1) :: Word32 689 b2 = fromIntegral (BS.index bs 2) :: Word32 690 b3 = fromIntegral (BS.index bs 3) :: Word32 691 in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3 692 693 -- --------------------------------------------------------------------------- 694 -- Bundle verification 695 -- --------------------------------------------------------------------------- 696 697 verifyBundle :: Bundle -> Either String () 698 verifyBundle bundle 699 | bundleVersion bundle < 1 = Left $ "unsupported bundle version: " ++ show (bundleVersion bundle) 700 | Seq.null (bundleNodes bundle) = Left "bundle has no nodes" 701 verifyBundle bundle = do 702 verifyManifestConstraints (bundleManifest bundle) 703 let nodeCount = fromIntegral $ Seq.length (bundleNodes bundle) 704 traverse_ (\idx -> when (idx >= nodeCount) $ Left $ "root index out of bounds: " ++ show idx) 705 (bundleRoots bundle) 706 traverse_ (\exp -> when (exportRoot exp >= nodeCount) $ Left $ "export index out of bounds: " ++ show (exportRoot exp)) 707 (manifestExports $ bundleManifest bundle) 708 709 let verifyNode i node = case node of 710 BNLeaf -> Right () 711 BNStem child -> do 712 when (child >= i) $ Left $ "stem at index " ++ show i ++ " references child " ++ show child 713 when (child >= nodeCount) $ Left $ "stem at index " ++ show i ++ " references child out of bounds" 714 Right () 715 BNFork left right -> do 716 when (left >= i) $ Left $ "fork at index " ++ show i ++ " references left " ++ show left 717 when (right >= i) $ Left $ "fork at index " ++ show i ++ " references right " ++ show right 718 when (left >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references left out of bounds" 719 when (right >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references right out of bounds" 720 Right () 721 722 mapM_ (\i -> case Seq.lookup (fromIntegral i) (bundleNodes bundle) of 723 Nothing -> Left $ "internal error: node " ++ show i ++ " not found" 724 Just node -> verifyNode i node) [0 :: Word32 .. nodeCount - 1] 725 726 let dupCheck = foldM (\seen (i, node) -> case node of 727 BNLeaf -> if Set.member (0 :: Word8, 0 :: Word32, 0 :: Word32) seen 728 then Left $ "duplicate leaf at index " ++ show i 729 else Right $ Set.insert (0, 0, 0) seen 730 BNStem child -> if Set.member (1, child, 0) seen 731 then Left $ "duplicate stem at index " ++ show i 732 else Right $ Set.insert (1, child, 0) seen 733 BNFork left right -> if Set.member (2, left, right) seen 734 then Left $ "duplicate fork at index " ++ show i 735 else Right $ Set.insert (2, left, right) seen) Set.empty (zip [0 :: Word32 ..] (Foldable.toList $ bundleNodes bundle)) 736 _ <- dupCheck 737 Right () 738 739 verifyManifestConstraints :: BundleManifest -> Either String () 740 verifyManifestConstraints manifest = do 741 when (manifestSchema manifest /= "arboricx.bundle.manifest.v1") $ 742 Left $ "unsupported manifest schema: " ++ unpack (manifestSchema manifest) 743 when (manifestBundleType manifest /= "tree-calculus-executable-object") $ 744 Left $ "unsupported bundle type: " ++ unpack (manifestBundleType manifest) 745 let treeSpec = manifestTree manifest 746 hashSpec = treeNodeHash treeSpec 747 runtimeSpec = manifestRuntime manifest 748 when (treeCalculus treeSpec /= "tree-calculus.v1") $ 749 Left $ "unsupported calculus: " ++ unpack (treeCalculus treeSpec) 750 when (nodeHashAlgorithm hashSpec /= "indexed") $ 751 Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec) 752 when (nodeHashDomain hashSpec /= "arboricx.indexed.node.v1") $ 753 Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec) 754 when (treeNodePayload treeSpec /= "arboricx.indexed.payload.v1") $ 755 Left $ "unsupported node payload: " ++ unpack (treeNodePayload treeSpec) 756 when (runtimeSemantics runtimeSpec /= "tree-calculus.v1") $ 757 Left $ "unsupported runtime semantics: " ++ unpack (runtimeSemantics runtimeSpec) 758 when (runtimeAbi runtimeSpec /= "arboricx.abi.tree.v1") $ 759 Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec) 760 when (not (null (runtimeCapabilities runtimeSpec))) $ 761 Left "unsupported runtime capabilities" 762 when (manifestClosure manifest /= ClosureComplete) $ 763 Left "bundle requires closure = complete" 764 when (null $ manifestRoots manifest) $ 765 Left "manifest has no roots" 766 when (null $ manifestExports manifest) $ 767 Left "manifest has no exports" 768 traverse_ verifyExport (manifestExports manifest) 769 where 770 verifyExport exported = do 771 when (T.null $ exportName exported) $ 772 Left "manifest export has empty name" 773 774 -- --------------------------------------------------------------------------- 775 -- Bundle reconstruction 776 -- --------------------------------------------------------------------------- 777 778 reconstructBundleTerms :: Seq BundleNode -> Vector T 779 reconstructBundleTerms nodes = V.create $ do 780 let n = Seq.length nodes 781 vec <- MV.new n 782 forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do 783 t <- case node of 784 BNLeaf -> return Leaf 785 BNStem child -> Stem <$> MV.read vec (fromIntegral child) 786 BNFork left right -> do 787 l <- MV.read vec (fromIntegral left) 788 r <- MV.read vec (fromIntegral right) 789 return $ Fork l r 790 MV.write vec i t 791 return vec 792 793 -- --------------------------------------------------------------------------- 794 -- Primitive binary helpers 795 -- --------------------------------------------------------------------------- 796 797 encode16 :: Word16 -> ByteString 798 encode16 w = BS.pack 799 [ fromIntegral (shiftR w 8) 800 , fromIntegral w 801 ] 802 803 encode32 :: Word32 -> ByteString 804 encode32 w = BS.pack 805 [ fromIntegral (shiftR w 24) 806 , fromIntegral (shiftR w 16) 807 , fromIntegral (shiftR w 8) 808 , fromIntegral w 809 ] 810 811 encode64 :: Word64 -> ByteString 812 encode64 w = BS.pack 813 [ fromIntegral (shiftR w 56) 814 , fromIntegral (shiftR w 48) 815 , fromIntegral (shiftR w 40) 816 , fromIntegral (shiftR w 32) 817 , fromIntegral (shiftR w 24) 818 , fromIntegral (shiftR w 16) 819 , fromIntegral (shiftR w 8) 820 , fromIntegral w 821 ] 822 823 decode16be :: String -> ByteString -> Either String (Word16, ByteString) 824 decode16be label bs 825 | BS.length bs < 2 = Left (label ++ ": not enough bytes for u16") 826 | otherwise = 827 let b0 = fromIntegral (BS.index bs 0) :: Word16 828 b1 = fromIntegral (BS.index bs 1) :: Word16 829 in Right ((b0 `shiftL` 8) .|. b1, BS.drop 2 bs) 830 831 decode32be :: String -> ByteString -> Either String (Word32, ByteString) 832 decode32be label bs 833 | BS.length bs < 4 = Left (label ++ ": not enough bytes for u32") 834 | otherwise = 835 let b0 = fromIntegral (BS.index bs 0) :: Word32 836 b1 = fromIntegral (BS.index bs 1) :: Word32 837 b2 = fromIntegral (BS.index bs 2) :: Word32 838 b3 = fromIntegral (BS.index bs 3) :: Word32 839 in Right ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3, BS.drop 4 bs) 840 841 decode64be :: String -> ByteString -> Either String (Word64, ByteString) 842 decode64be label bs 843 | BS.length bs < 8 = Left (label ++ ": not enough bytes for u64") 844 | otherwise = 845 let b0 = fromIntegral (BS.index bs 0) :: Word64 846 b1 = fromIntegral (BS.index bs 1) :: Word64 847 b2 = fromIntegral (BS.index bs 2) :: Word64 848 b3 = fromIntegral (BS.index bs 3) :: Word64 849 b4 = fromIntegral (BS.index bs 4) :: Word64 850 b5 = fromIntegral (BS.index bs 5) :: Word64 851 b6 = fromIntegral (BS.index bs 6) :: Word64 852 b7 = fromIntegral (BS.index bs 7) :: Word64 853 in Right ((b0 `shiftL` 56) .|. (b1 `shiftL` 48) .|. (b2 `shiftL` 40) .|. (b3 `shiftL` 32) 854 .|. (b4 `shiftL` 24) .|. (b5 `shiftL` 16) .|. (b6 `shiftL` 8) .|. b7, BS.drop 8 bs) 855 856 -- --------------------------------------------------------------------------- 857 -- Helpers 858 -- --------------------------------------------------------------------------- 859 860 defaultExportNames :: Int -> [Text] 861 defaultExportNames n = 862 case n of 863 0 -> [] 864 1 -> ["root"] 865 _ -> ["root" <> T.pack (show i) | i <- [0 :: Int .. n - 1]]