Wire.hs (49827B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE DeriveGeneric #-} 3 {-# LANGUAGE OverloadedStrings #-} 4 5 module Wire 6 ( Bundle (..) 7 , BundleManifest (..) 8 , TreeSpec (..) 9 , NodeHashSpec (..) 10 , RuntimeSpec (..) 11 , BundleRoot (..) 12 , BundleExport (..) 13 , BundleMetadata 14 , ClosureMode (..) 15 , BundleNode (..) 16 , encodeBundle 17 , bundleEncodedLength, emitBundle 18 , decodeBundle 19 , decodeBundleSnapshot 20 , verifyBundle 21 , buildBundle 22 , buildBundleShared 23 , TreeTermBundleBuilder 24 , TreeTermBundleCursor 25 , emptyTreeTermBundle 26 , startTreeTerm 27 , feedTreeTerm 28 , endTreeTerm 29 , finishTreeTermBundle 30 , extractBundleRoot 31 , reconstructBundleTerms 32 , defaultExportNames 33 ) where 34 35 import Runtime hiding (Node) 36 import ContentStore.Snapshot (Snapshot, snapshotLength, readSnapshot) 37 import Control.Monad.Trans.Except (runExceptT, throwE) 38 import Control.Monad.IO.Class (liftIO) 39 40 import Control.Monad (foldM, forM_, unless, when) 41 import Control.Exception (evaluate) 42 import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef') 43 import System.Mem.StableName (StableName, makeStableName, hashStableName) 44 import qualified Data.IntMap.Strict as IntMap 45 import Data.Bits (shiftL, shiftR, (.|.), (.&.)) 46 import Data.ByteString (ByteString) 47 import Data.Foldable (traverse_) 48 import qualified Data.Foldable as Foldable 49 import Data.List (mapAccumL) 50 import Data.Map (Map) 51 import qualified Data.Map.Strict as Map 52 import Data.Sequence (Seq, (|>)) 53 import qualified Data.Sequence as Seq 54 import Data.Set (Set) 55 import qualified Data.Set as Set 56 import Data.Text (Text, unpack) 57 import Data.Text.Encoding (decodeUtf8', encodeUtf8) 58 import Data.Vector (Vector) 59 import qualified Data.Vector as V 60 import qualified Data.Vector.Mutable as MV 61 import Data.Word (Word16, Word32, Word64, Word8) 62 import GHC.Generics (Generic) 63 64 import qualified Data.ByteString as BS 65 import qualified Data.Text as T 66 67 -- --------------------------------------------------------------------------- 68 -- Container constants 69 -- --------------------------------------------------------------------------- 70 71 bundleMajorVersion :: Word16 72 bundleMajorVersion = 1 73 74 bundleMinorVersion :: Word16 75 bundleMinorVersion = 0 76 77 bundleMagic :: ByteString 78 bundleMagic = BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x43, 0x58] 79 80 headerLength :: Int 81 headerLength = 32 82 83 sectionEntryLength :: Int 84 sectionEntryLength = 32 85 86 sectionManifest, sectionNodes :: Word32 87 sectionManifest = 1 88 sectionNodes = 2 89 90 flagCritical :: Word16 91 flagCritical = 0x0001 92 93 compressionNone :: Word16 94 compressionNone = 0 95 96 -- --------------------------------------------------------------------------- 97 -- Manifest constants 98 -- --------------------------------------------------------------------------- 99 100 manifestMagic :: ByteString 101 manifestMagic = "ARBMNFST" 102 103 manifestMajorVersion :: Word16 104 manifestMajorVersion = 1 105 106 manifestMinorVersion :: Word16 107 manifestMinorVersion = 1 108 109 closureToByte :: ClosureMode -> Word8 110 closureToByte = \case 111 ClosureComplete -> 0 112 ClosurePartial -> 1 113 114 closureFromByte :: Word8 -> Either String ClosureMode 115 closureFromByte = \case 116 0 -> Right ClosureComplete 117 1 -> Right ClosurePartial 118 n -> Left $ "unsupported closure byte: " ++ show n 119 120 tagPackage, tagVersion, tagDescription, tagLicense, tagCreatedBy :: Word16 121 tagPackage = 1 122 tagVersion = 2 123 tagDescription = 3 124 tagLicense = 4 125 tagCreatedBy = 5 126 127 -- --------------------------------------------------------------------------- 128 -- Text encoding helpers 129 -- --------------------------------------------------------------------------- 130 131 encodeLengthPrefixedText :: Text -> ByteString 132 encodeLengthPrefixedText t = encode32 (fromIntegral $ BS.length bs) <> bs 133 where bs = encodeUtf8 t 134 135 decodeLengthPrefixedText :: ByteString -> Either String (Text, ByteString) 136 decodeLengthPrefixedText bs = do 137 (len, rest) <- decode32be "text_length" bs 138 let payloadLen = fromIntegral len 139 when (BS.length rest < payloadLen) $ 140 Left "decodeLengthPrefixedText: string extends beyond input" 141 let (textBytes, after) = BS.splitAt payloadLen rest 142 case decodeUtf8' textBytes of 143 Right txt -> Right (txt, after) 144 Left _ -> Left "decodeLengthPrefixedText: invalid UTF-8" 145 146 encodeMetadataTLV :: Word16 -> ByteString -> ByteString 147 encodeMetadataTLV tag val = encode16 tag <> encode32 (fromIntegral $ BS.length val) <> val 148 149 -- --------------------------------------------------------------------------- 150 -- Manifest encoders 151 -- --------------------------------------------------------------------------- 152 153 encodeManifest :: BundleManifest -> ByteString 154 encodeManifest m = 155 manifestMagic 156 <> encode16 manifestMajorVersion 157 <> encode16 manifestMinorVersion 158 <> encodeLengthPrefixedText (manifestSchema m) 159 <> encodeLengthPrefixedText (manifestBundleType m) 160 <> encodeLengthPrefixedText (treeCalculus (manifestTree m)) 161 <> encodeLengthPrefixedText (nodeHashAlgorithm (treeNodeHash (manifestTree m))) 162 <> encodeLengthPrefixedText (nodeHashDomain (treeNodeHash (manifestTree m))) 163 <> encodeLengthPrefixedText (treeNodePayload (manifestTree m)) 164 <> encodeLengthPrefixedText (runtimeSemantics (manifestRuntime m)) 165 <> encodeLengthPrefixedText (runtimeEvaluation (manifestRuntime m)) 166 <> encodeLengthPrefixedText (runtimeAbi (manifestRuntime m)) 167 <> encode32 (fromIntegral $ length (runtimeCapabilities (manifestRuntime m))) 168 <> encodeCapabilities (runtimeCapabilities (manifestRuntime m)) 169 <> BS.pack [closureToByte (manifestClosure m)] 170 <> encode32 (fromIntegral $ length (manifestRoots m)) 171 <> encodeRoots (manifestRoots m) 172 <> encode32 (fromIntegral $ length (manifestExports m)) 173 <> encodeExports (manifestExports m) 174 <> encodeMetadataTLVs (manifestMetadata m) 175 <> encode32 0 176 177 encodeCapabilities :: [Text] -> ByteString 178 encodeCapabilities = mconcat . map encodeLengthPrefixedText 179 180 encodeRoots :: [BundleRoot] -> ByteString 181 encodeRoots = mconcat . map encodeRoot 182 183 encodeRoot :: BundleRoot -> ByteString 184 encodeRoot root = encode32 (rootIndex root) <> encodeLengthPrefixedText (rootRole root) 185 186 encodeExports :: [BundleExport] -> ByteString 187 encodeExports = mconcat . map encodeExport 188 189 encodeExport :: BundleExport -> ByteString 190 encodeExport exp = 191 encodeLengthPrefixedText (exportName exp) 192 <> encode32 (exportRoot exp) 193 <> encodeLengthPrefixedText (exportKind exp) 194 <> encodeLengthPrefixedText (exportAbi exp) 195 196 encodeMetadataTLVs :: BundleMetadata -> ByteString 197 encodeMetadataTLVs m = 198 let entries = metadataTLVEntries m 199 in encode32 (fromIntegral $ length entries) <> encodeTLVs entries 200 201 metadataTLVEntries :: BundleMetadata -> [(Word16, ByteString)] 202 metadataTLVEntries m = 203 maybeEntry tagPackage (metadataPackage m) 204 ++ maybeEntry tagVersion (metadataVersion m) 205 ++ maybeEntry tagDescription (metadataDescription m) 206 ++ maybeEntry tagLicense (metadataLicense m) 207 ++ maybeEntry tagCreatedBy (metadataCreatedBy m) 208 where 209 maybeEntry _ Nothing = [] 210 maybeEntry tag (Just value) = [(tag, encodeUtf8 value)] 211 212 encodeTLVs :: [(Word16, ByteString)] -> ByteString 213 encodeTLVs = mconcat . map (uncurry encodeMetadataTLV) 214 215 -- --------------------------------------------------------------------------- 216 -- Manifest decoders 217 -- --------------------------------------------------------------------------- 218 219 decodeManifest :: ByteString -> Either String BundleManifest 220 decodeManifest bs = do 221 when (BS.length bs < 8) $ Left "manifest too short for magic" 222 when (BS.take 8 bs /= manifestMagic) $ Left "invalid manifest magic" 223 let rest = BS.drop 8 bs 224 (major, rest') <- decode16be "major" rest 225 (minor, rest'') <- decode16be "minor" rest' 226 when (major /= manifestMajorVersion) $ 227 Left $ "unsupported manifest major version: " ++ show major 228 when (minor /= manifestMinorVersion) $ 229 Left $ "unsupported manifest minor version: " ++ show minor 230 231 (schema, r1) <- decodeLengthPrefixedText rest'' 232 (bundleType, r2) <- decodeLengthPrefixedText r1 233 (calc, r3) <- decodeLengthPrefixedText r2 234 (alg, r4) <- decodeLengthPrefixedText r3 235 (domain, r5) <- decodeLengthPrefixedText r4 236 (payload, r6) <- decodeLengthPrefixedText r5 237 (sem, r7) <- decodeLengthPrefixedText r6 238 (eval, r8) <- decodeLengthPrefixedText r7 239 (abi, r9) <- decodeLengthPrefixedText r8 240 241 (capCount, r10) <- decode32be "capability_count" r9 242 (caps, r11) <- decodeCapabilities (fromIntegral capCount) r10 243 244 when (BS.length r11 < 1) $ Left "manifest truncated: missing closure byte" 245 let (closureByte, r12) = BS.splitAt 1 r11 246 closure <- closureFromByte (head $ BS.unpack closureByte) 247 248 (rootCount, r13) <- decode32be "root_count" r12 249 (roots, r14) <- decodeRoots (fromIntegral rootCount) r13 250 251 (exportCount, r15) <- decode32be "export_count" r14 252 (exports, r16) <- decodeExports (fromIntegral exportCount) r15 253 254 (metadata, _ext) <- decodeMetadataAndExtensions r16 255 256 pure BundleManifest 257 { manifestSchema = schema 258 , manifestBundleType = bundleType 259 , manifestTree = TreeSpec 260 { treeCalculus = calc 261 , treeNodeHash = NodeHashSpec 262 { nodeHashAlgorithm = alg 263 , nodeHashDomain = domain 264 } 265 , treeNodePayload = payload 266 } 267 , manifestRuntime = RuntimeSpec 268 { runtimeSemantics = sem 269 , runtimeEvaluation = eval 270 , runtimeAbi = abi 271 , runtimeCapabilities = caps 272 } 273 , manifestClosure = closure 274 , manifestRoots = roots 275 , manifestExports = exports 276 , manifestMetadata = metadata 277 } 278 279 decodeCapabilities :: Int -> ByteString -> Either String ([Text], ByteString) 280 decodeCapabilities 0 bs = Right ([], bs) 281 decodeCapabilities n bs = do 282 (txt, rest) <- decodeLengthPrefixedText bs 283 (restTxts, restFinal) <- decodeCapabilities (n - 1) rest 284 Right (txt : restTxts, restFinal) 285 286 decodeRoots :: Int -> ByteString -> Either String ([BundleRoot], ByteString) 287 decodeRoots 0 bs = Right ([], bs) 288 decodeRoots n bs = do 289 (idx, rest1) <- decode32be "root_index" bs 290 (role, rest2) <- decodeLengthPrefixedText rest1 291 (restRoots, restFinal) <- decodeRoots (n - 1) rest2 292 Right (BundleRoot idx role : restRoots, restFinal) 293 294 decodeExports :: Int -> ByteString -> Either String ([BundleExport], ByteString) 295 decodeExports 0 bs = Right ([], bs) 296 decodeExports n bs = do 297 (name, r1) <- decodeLengthPrefixedText bs 298 (idx, r2) <- decode32be "export_root" r1 299 (kind, r3) <- decodeLengthPrefixedText r2 300 (abi, r4) <- decodeLengthPrefixedText r3 301 (restExports, restFinal) <- decodeExports (n - 1) r4 302 Right (BundleExport name idx kind abi : restExports, restFinal) 303 304 decodeMetadataAndExtensions :: ByteString -> Either String (BundleMetadata, ByteString) 305 decodeMetadataAndExtensions bs = do 306 (metadataCount, rest1) <- decode32be "metadata_field_count" bs 307 (metadataTlvs, rest2) <- decodeTLVs (fromIntegral metadataCount) rest1 308 metadata <- decodeMetadataTLVs metadataTlvs 309 (extensionCount, rest3) <- decode32be "extension_field_count" rest2 310 (_extensionTlvs, rest4) <- decodeTLVs (fromIntegral extensionCount) rest3 311 unless (BS.null rest4) $ Left "trailing bytes after manifest TLV tail" 312 Right (metadata, rest4) 313 314 decodeTLVs :: Int -> ByteString -> Either String ([TLVEntry], ByteString) 315 decodeTLVs 0 bs = Right ([], bs) 316 decodeTLVs n bs = do 317 (tag, r1) <- decode16be "tlv_tag" bs 318 (len, r2) <- decode32be "tlv_length" r1 319 let payloadLen = fromIntegral len 320 when (BS.length r2 < payloadLen) $ Left "TLV value extends beyond input" 321 let (value, after) = BS.splitAt payloadLen r2 322 (restTlvs, restFinal) <- decodeTLVs (n - 1) after 323 Right ((tag, value) : restTlvs, restFinal) 324 325 decodeMetadataTLVs :: [(Word16, ByteString)] -> Either String BundleMetadata 326 decodeMetadataTLVs tlvs = do 327 pkg <- lookupText tagPackage 328 ver <- lookupText tagVersion 329 desc <- lookupText tagDescription 330 lic <- lookupText tagLicense 331 by <- lookupText tagCreatedBy 332 pure BundleMetadata 333 { metadataPackage = pkg 334 , metadataVersion = ver 335 , metadataDescription = desc 336 , metadataLicense = lic 337 , metadataCreatedBy = by 338 } 339 where 340 lookupTag t = go t tlvs 341 go _ [] = Nothing 342 go t ((tag, val):rest) 343 | tag == t = Just val 344 | otherwise = go t rest 345 lookupText tag = 346 case lookupTag tag of 347 Nothing -> Right Nothing 348 Just raw -> case decodeUtf8' raw of 349 Right txt -> Right (Just txt) 350 Left _ -> Left $ "metadata TLV has invalid UTF-8 for tag " ++ show tag 351 352 type TLVEntry = (Word16, ByteString) 353 354 -- --------------------------------------------------------------------------- 355 -- Data types 356 -- --------------------------------------------------------------------------- 357 358 data ClosureMode = ClosureComplete | ClosurePartial 359 deriving (Show, Eq, Ord, Generic) 360 361 data NodeHashSpec = NodeHashSpec 362 { nodeHashAlgorithm :: Text 363 , nodeHashDomain :: Text 364 } deriving (Show, Eq, Ord, Generic) 365 366 data TreeSpec = TreeSpec 367 { treeCalculus :: Text 368 , treeNodeHash :: NodeHashSpec 369 , treeNodePayload :: Text 370 } deriving (Show, Eq, Ord, Generic) 371 372 data RuntimeSpec = RuntimeSpec 373 { runtimeSemantics :: Text 374 , runtimeEvaluation :: Text 375 , runtimeAbi :: Text 376 , runtimeCapabilities :: [Text] 377 } deriving (Show, Eq, Ord, Generic) 378 379 data BundleRoot = BundleRoot 380 { rootIndex :: Word32 381 , rootRole :: Text 382 } deriving (Show, Eq, Ord, Generic) 383 384 data BundleExport = BundleExport 385 { exportName :: Text 386 , exportRoot :: Word32 387 , exportKind :: Text 388 , exportAbi :: Text 389 } deriving (Show, Eq, Ord, Generic) 390 391 data BundleMetadata = BundleMetadata 392 { metadataPackage :: Maybe Text 393 , metadataVersion :: Maybe Text 394 , metadataDescription :: Maybe Text 395 , metadataLicense :: Maybe Text 396 , metadataCreatedBy :: Maybe Text 397 } deriving (Show, Eq, Ord, Generic) 398 399 data BundleManifest = BundleManifest 400 { manifestSchema :: Text 401 , manifestBundleType :: Text 402 , manifestTree :: TreeSpec 403 , manifestRuntime :: RuntimeSpec 404 , manifestClosure :: ClosureMode 405 , manifestRoots :: [BundleRoot] 406 , manifestExports :: [BundleExport] 407 , manifestMetadata :: BundleMetadata 408 } deriving (Show, Eq, Generic) 409 410 data BundleNode 411 = BNLeaf 412 | BNStem !Word32 413 | BNFork !Word32 !Word32 414 deriving (Show, Eq) 415 416 data Bundle = Bundle 417 { bundleVersion :: Word16 418 , bundleRoots :: [Word32] 419 , bundleNodes :: Seq BundleNode 420 , bundleManifest :: BundleManifest 421 , bundleManifestBytes :: ByteString 422 } deriving (Show, Eq) 423 424 -- --------------------------------------------------------------------------- 425 -- Bundle construction 426 -- --------------------------------------------------------------------------- 427 428 data NodeKey = KeyLeaf | KeyStem !Word32 | KeyFork !Word32 !Word32 429 deriving (Eq, Ord, Show) 430 431 buildBundle :: [(Text, T)] -> Bundle 432 buildBundle namedTerms = 433 let go :: T -> (Seq BundleNode, Map NodeKey Word32) -> (Word32, (Seq BundleNode, Map NodeKey Word32)) 434 go Leaf (nodes, seen) = 435 case Map.lookup KeyLeaf seen of 436 Just idx -> (idx, (nodes, seen)) 437 Nothing -> 438 let idx = fromIntegral (Seq.length nodes) 439 in (idx, (nodes |> BNLeaf, Map.insert KeyLeaf idx seen)) 440 go (Stem child) (nodes, seen) = 441 let (childIdx, state1) = go child (nodes, seen) 442 (nodes1, seen1) = state1 443 in case Map.lookup (KeyStem childIdx) seen1 of 444 Just idx -> (idx, state1) 445 Nothing -> 446 let idx = fromIntegral (Seq.length nodes1) 447 in (idx, (nodes1 |> BNStem childIdx, Map.insert (KeyStem childIdx) idx seen1)) 448 go (Fork left right) (nodes, seen) = 449 let (leftIdx, state1) = go left (nodes, seen) 450 (rightIdx, state2) = go right state1 451 (nodes2, seen2) = state2 452 in case Map.lookup (KeyFork leftIdx rightIdx) seen2 of 453 Just idx -> (idx, state2) 454 Nothing -> 455 let idx = fromIntegral (Seq.length nodes2) 456 in (idx, (nodes2 |> BNFork leftIdx rightIdx, Map.insert (KeyFork leftIdx rightIdx) idx seen2)) 457 458 processExport state (_, t) = let (idx, newState) = go t state in (newState, idx) 459 ((finalNodes, _), rootIndices) = mapAccumL processExport (Seq.empty, Map.empty) namedTerms 460 461 in bundleFromIndexedRoots finalNodes (zip (map fst namedTerms) rootIndices) 462 463 -- Physical sharing is only an acceleration hint. Exact constructor/child-ID 464 -- interning still determines canonical identity and left-before-right order. 465 -- Stable-name hash collisions use equality, never the hash alone. Names are 466 -- taken after WHNF evaluation so a thunk and its value are not separate keys. 467 -- The memo is local to one encoding; no store paths, publication or policy here. 468 buildBundleShared :: [(Text, T)] -> IO Bundle 469 buildBundleShared namedTerms = do 470 memo <- newIORef (IntMap.empty :: IntMap.IntMap [(StableName T, Word32)]) 471 state <- newIORef (Seq.empty, Map.empty) 472 let intern key node = do 473 (nodes, seen) <- readIORef state 474 case Map.lookup key seen of 475 Just index -> pure index 476 Nothing -> do 477 when (toInteger (Seq.length nodes) > toInteger (maxBound :: Word32)) $ 478 fail "indexed tree exceeds 32-bit node index space" 479 let index = fromIntegral (Seq.length nodes) 480 modifyIORef' state (const (nodes |> node, Map.insert key index seen)) 481 pure index 482 visit input = do 483 tree <- evaluate input 484 stable <- makeStableName tree 485 cached <- IntMap.findWithDefault [] (hashStableName stable) <$> readIORef memo 486 case lookup stable cached of 487 Just index -> pure index 488 Nothing -> do 489 index <- case tree of 490 Leaf -> intern KeyLeaf BNLeaf 491 Stem child -> do 492 childIndex <- visit child 493 intern (KeyStem childIndex) (BNStem childIndex) 494 Fork left right -> do 495 leftIndex <- visit left 496 rightIndex <- visit right 497 intern (KeyFork leftIndex rightIndex) (BNFork leftIndex rightIndex) 498 modifyIORef' memo (IntMap.insertWith (++) (hashStableName stable) [(stable, index)]) 499 pure index 500 roots <- mapM (\(name, tree) -> do index <- visit tree; pure (name, index)) namedTerms 501 (nodes, _) <- readIORef state 502 pure (bundleFromIndexedRoots nodes roots) 503 504 -- Both construction paths share exactly the same manifest and node numbering. 505 bundleFromIndexedRoots :: Seq BundleNode -> [(Text, Word32)] -> Bundle 506 bundleFromIndexedRoots finalNodes namedRoots = 507 let rootIndices = map snd namedRoots 508 roots = zipWith mkRoot [0 :: Int ..] rootIndices 509 exports = map (\(name, idx) -> BundleExport name idx "term" "arboricx.abi.tree.v1") namedRoots 510 manifest = makeManifest roots exports 511 manifestBytes = encodeManifest manifest 512 in Bundle 513 { bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion 514 , bundleRoots = rootIndices 515 , bundleNodes = finalNodes 516 , bundleManifest = manifest 517 , bundleManifestBytes = manifestBytes 518 } 519 where 520 mkRoot 0 idx = BundleRoot idx "default" 521 mkRoot _ idx = BundleRoot idx "root" 522 523 -- Streaming canonical preorder -> postorder DAG. No expanded Runtime.T is 524 -- constructed. Global interning preserves buildBundle's left-before-right, 525 -- first-occurrence numbering, including sharing between separate exports. 526 -- Memory: unique DAG nodes + maximum tree depth + caller's current input chunk. 527 data TreeTermBundleBuilder = TreeTermBundleBuilder 528 !(Seq BundleNode) !(Map NodeKey Word32) ![(Text, Word32)] 529 data TreeTermFrame = TermStem | TermForkLeft | TermForkRight !Word32 530 data TreeTermBundleCursor = TreeTermBundleCursor 531 !TreeTermBundleBuilder ![TreeTermFrame] !(Maybe Word32) 532 533 emptyTreeTermBundle :: TreeTermBundleBuilder 534 emptyTreeTermBundle = TreeTermBundleBuilder Seq.empty Map.empty [] 535 536 startTreeTerm :: TreeTermBundleBuilder -> TreeTermBundleCursor 537 startTreeTerm builder = TreeTermBundleCursor builder [] Nothing 538 539 internTermNode :: NodeKey -> BundleNode -> TreeTermBundleBuilder 540 -> Either String (Word32, TreeTermBundleBuilder) 541 -- Every nonempty canonical tree first completes a leaf. The opaque builder 542 -- therefore always assigns Leaf index 0, across chunks and exports. Avoid a 543 -- balanced-map lookup for each repeated leaf (roughly half of a fork-heavy 544 -- flat payload); retain ordinary interning for the first leaf and all parents. 545 internTermNode KeyLeaf BNLeaf builder@(TreeTermBundleBuilder nodes _ _) 546 | not (Seq.null nodes) = Right (0, builder) 547 internTermNode key node builder@(TreeTermBundleBuilder nodes seen roots) = 548 case Map.lookup key seen of 549 Just idx -> Right (idx, builder) 550 Nothing 551 | toInteger (Seq.length nodes) >= toInteger (maxBound :: Word32) -> 552 Left "tree-term bundle node limit exceeded" 553 | otherwise -> 554 let !idx = fromIntegral (Seq.length nodes) 555 !updated = TreeTermBundleBuilder (nodes |> node) (Map.insert key idx seen) roots 556 in Right (idx, updated) 557 558 feedTreeTerm :: ByteString -> TreeTermBundleCursor -> Either String TreeTermBundleCursor 559 feedTreeTerm bytes = readNode 0 560 where 561 !size = BS.length bytes 562 readNode !offset cursor@(TreeTermBundleCursor builder frames root) 563 | offset == size = Right cursor 564 | Just _ <- root = Left "trailing bytes after tree term" 565 | otherwise = case BS.index bytes offset of 566 0 -> do 567 (idx, updated) <- internTermNode KeyLeaf BNLeaf builder 568 deliver idx (offset + 1) updated frames 569 1 -> readNode (offset + 1) (TreeTermBundleCursor builder (TermStem : frames) Nothing) 570 2 -> readNode (offset + 1) (TreeTermBundleCursor builder (TermForkLeft : frames) Nothing) 571 tag -> Left $ "unknown tree term tag: " ++ show tag 572 deliver !idx !offset !builder [] = 573 readNode offset (TreeTermBundleCursor builder [] (Just idx)) 574 deliver !idx !offset !builder (TermStem : frames) = do 575 (parent, updated) <- internTermNode (KeyStem idx) (BNStem idx) builder 576 deliver parent offset updated frames 577 deliver !idx !offset !builder (TermForkLeft : frames) = 578 readNode offset (TreeTermBundleCursor builder (TermForkRight idx : frames) Nothing) 579 deliver !right !offset !builder (TermForkRight left : frames) = do 580 (parent, updated) <- internTermNode (KeyFork left right) (BNFork left right) builder 581 deliver parent offset updated frames 582 583 endTreeTerm :: Text -> TreeTermBundleCursor -> Either String TreeTermBundleBuilder 584 endTreeTerm name (TreeTermBundleCursor (TreeTermBundleBuilder nodes seen roots) [] (Just root)) = 585 Right (TreeTermBundleBuilder nodes seen ((name, root) : roots)) 586 endTreeTerm _ _ = Left "unexpected end of tree term" 587 588 finishTreeTermBundle :: TreeTermBundleBuilder -> Bundle 589 finishTreeTermBundle (TreeTermBundleBuilder nodes _ roots) = 590 bundleFromIndexedRoots nodes (reverse roots) 591 592 makeManifest :: [BundleRoot] -> [BundleExport] -> BundleManifest 593 makeManifest roots exports = BundleManifest 594 { manifestSchema = "arboricx.bundle.manifest.v1" 595 , manifestBundleType = "tree-calculus-executable-object" 596 , manifestTree = TreeSpec 597 { treeCalculus = "tree-calculus.v1" 598 , treeNodeHash = NodeHashSpec 599 { nodeHashAlgorithm = "indexed" 600 , nodeHashDomain = "arboricx.indexed.node.v1" 601 } 602 , treeNodePayload = "arboricx.indexed.payload.v1" 603 } 604 , manifestRuntime = RuntimeSpec 605 { runtimeSemantics = "tree-calculus.v1" 606 , runtimeEvaluation = "normal-order" 607 , runtimeAbi = "arboricx.abi.tree.v1" 608 , runtimeCapabilities = [] 609 } 610 , manifestClosure = ClosureComplete 611 , manifestRoots = roots 612 , manifestExports = exports 613 , manifestMetadata = BundleMetadata 614 { metadataPackage = Nothing 615 , metadataVersion = Nothing 616 , metadataDescription = Nothing 617 , metadataLicense = Nothing 618 , metadataCreatedBy = Just "arboricx" 619 } 620 } 621 622 -- | Extract one canonical, name-neutral root using indexed edges only. The 623 -- memo table visits each reachable node once; never unfold the logical tree. 624 extractBundleRoot :: Bundle -> Word32 -> Either String Bundle 625 extractBundleRoot bundle root = do 626 verifyBundle bundle 627 when (fromIntegral root >= Seq.length (bundleNodes bundle)) $ 628 Left "extracted root index out of bounds" 629 let visit :: Word32 -> (Seq BundleNode, Map Word32 Word32) 630 -> (Word32, (Seq BundleNode, Map Word32 Word32)) 631 visit old state@(nodes, seen) = case Map.lookup old seen of 632 Just index -> (index, state) 633 Nothing -> 634 let (node, (children, memo)) = case Seq.index (bundleNodes bundle) (fromIntegral old) of 635 BNLeaf -> (BNLeaf, (nodes, seen)) 636 BNStem child -> 637 let (index, next) = visit child state 638 in (BNStem index, next) 639 BNFork left right -> 640 let (l, next) = visit left state 641 (r, final) = visit right next 642 in (BNFork l r, final) 643 index = fromIntegral (Seq.length children) 644 in (index, (children |> node, Map.insert old index memo)) 645 (index, (nodes, _)) = visit root (Seq.empty, Map.empty) 646 manifest = makeManifest [BundleRoot index "default"] 647 [BundleExport "root" index "term" "arboricx.abi.tree.v1"] 648 pure Bundle 649 { bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion 650 , bundleRoots = [index] 651 , bundleNodes = nodes 652 , bundleManifest = manifest 653 , bundleManifestBytes = encodeManifest manifest 654 } 655 656 -- --------------------------------------------------------------------------- 657 -- Bundle encoding / decoding 658 -- --------------------------------------------------------------------------- 659 660 encodeBundle :: Bundle -> ByteString 661 encodeBundle bundle = 662 let nodeSection = encodeNodeSection (bundleNodes bundle) 663 manifestBytes = bundleManifestBytes bundle 664 sectionCount = 2 665 dirOffset = fromIntegral headerLength 666 sectionDirLength = sectionCount * sectionEntryLength 667 manifestOffset = fromIntegral (headerLength + sectionDirLength) 668 nodesOffset = manifestOffset + fromIntegral (BS.length manifestBytes) 669 manifestEntry = encodeSectionEntry sectionManifest 1 flagCritical compressionNone 670 manifestOffset (fromIntegral $ BS.length manifestBytes) 671 nodesEntry = encodeSectionEntry sectionNodes 1 flagCritical compressionNone 672 nodesOffset (fromIntegral $ BS.length nodeSection) 673 header = encodeHeader bundleMajorVersion bundleMinorVersion 674 (fromIntegral sectionCount) 0 dirOffset 675 in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection 676 677 -- Canonical writer transport without a whole encoded ByteString. The indexed 678 -- table remains resident; each emission owns only its bounded pending buffer. 679 bundleEncodedLength :: Bundle -> Integer 680 bundleEncodedLength bundle = 104 + toInteger (BS.length (bundleManifestBytes bundle)) 681 + Foldable.foldl' (\n node -> n + recordLength node) 0 (bundleNodes bundle) 682 where 683 recordLength BNLeaf = 5 684 recordLength (BNStem _) = 9 685 recordLength (BNFork _ _) = 13 686 687 emitBundle :: Int -> Bundle -> (ByteString -> IO ()) -> IO () 688 emitBundle bound bundle sink = do 689 when (bound <= 0) (fail "invalid bundle transport chunk bound") 690 let total = bundleEncodedLength bundle 691 manifest = bundleManifestBytes bundle 692 manifestSize = toInteger (BS.length manifest) 693 nodeSize = total - 96 - manifestSize 694 when (total > toInteger (maxBound :: Word64)) (fail "bundle exceeds portable offset space") 695 pending <- newIORef (0, []) 696 let flush = do 697 (count, parts) <- readIORef pending 698 when (count > 0) $ do 699 -- Drop the accumulated parts before calling an arbitrary sink. No 700 -- emitted chunk history is retained across acknowledgements. 701 writeIORef pending (0, []) 702 sink (BS.concat (reverse parts)) 703 feed bytes = unless (BS.null bytes) $ do 704 (count, parts) <- readIORef pending 705 let (part, rest) = BS.splitAt (bound - count) bytes 706 count' = count + BS.length part 707 writeIORef pending (count', part : parts) 708 when (count' == bound) flush 709 feed rest 710 node value = do 711 let payload = serializeBundleNode value 712 feed (encode32 (fromIntegral (BS.length payload))) 713 feed payload 714 feed (encodeHeader bundleMajorVersion bundleMinorVersion 2 0 32) 715 feed (encodeSectionEntry sectionManifest 1 flagCritical compressionNone 96 (fromInteger manifestSize)) 716 feed (encodeSectionEntry sectionNodes 1 flagCritical compressionNone (fromInteger (96 + manifestSize)) (fromInteger nodeSize)) 717 feed manifest 718 feed (encode64 (fromIntegral (Seq.length (bundleNodes bundle)))) 719 traverse_ node (bundleNodes bundle) 720 flush 721 722 decodeBundle :: ByteString -> Either String Bundle 723 decodeBundle bs 724 | BS.take (BS.length bundleMagic) bs /= bundleMagic = Left "invalid magic" 725 | otherwise = do 726 (major, minor, sectionCount, _flags, dirOffset) <- decodePortableHeader bs 727 when (major /= bundleMajorVersion) $ 728 Left $ "unsupported bundle major version: " ++ show major 729 let dirStart = fromIntegral dirOffset 730 dirBytes = fromIntegral sectionCount * sectionEntryLength 731 when (BS.length bs < dirStart + dirBytes) $ 732 Left "bundle truncated in section directory" 733 let dirRaw = BS.take dirBytes $ BS.drop dirStart bs 734 entries <- decodeSectionEntries sectionCount dirRaw 735 traverse_ rejectUnknownCritical entries 736 manifestEntry <- requireSection sectionManifest entries 737 nodesEntry <- requireSection sectionNodes entries 738 manifestBytes <- readAndVerifySection bs manifestEntry 739 nodesBytes <- readAndVerifySection bs nodesEntry 740 manifest <- decodeManifest manifestBytes 741 when (treeNodePayload (manifestTree manifest) /= "arboricx.indexed.payload.v1") $ 742 Left "manifest does not use indexed payload" 743 nodes <- decodeNodeSection nodesBytes 744 let rootIndices = map rootIndex (manifestRoots manifest) 745 return Bundle 746 { bundleVersion = major * 1000 + minor 747 , bundleRoots = rootIndices 748 , bundleNodes = nodes 749 , bundleManifest = manifest 750 , bundleManifestBytes = manifestBytes 751 } 752 753 -- Bounded transport decoder for an already authenticated immutable snapshot. 754 -- Limits are explicit arguments, not limits on the historical whole-value API. 755 -- Retains the indexed node table (and bounded manifest/directory metadata), never 756 -- the complete encoded input. Offset arithmetic is Integer before any narrowing. 757 decodeBundleSnapshot :: Int -> Int -> Snapshot -> IO (Either String Bundle) 758 decodeBundleSnapshot sectionLimit manifestLimit snapshot = runExceptT $ do 759 cache <- liftIO (newIORef (0, BS.empty)) 760 let size = snapshotLength snapshot 761 checkedRange offset count = when (offset < 0 || count < 0 || offset + count > size) $ 762 throwE "section extends beyond bundle end" 763 small offset count = do 764 checkedRange offset (toInteger count) 765 (base, cached) <- liftIO (readIORef cache) 766 bytes <- if offset >= base && offset + toInteger count <= base + toInteger (BS.length cached) 767 then pure (BS.take count (BS.drop (fromInteger (offset - base)) cached)) 768 else do 769 fresh <- liftIO (readSnapshot snapshot offset 4096) 770 liftIO (writeIORef cache (offset, fresh)) 771 pure (BS.take count fresh) 772 when (BS.length bytes /= count) (throwE "snapshot truncated") 773 pure bytes 774 decoded = either throwE pure 775 -- Manifest bytes are bounded by manifestLimit; each transport read <=4096. 776 boundedBytes offset count = BS.concat <$> go offset count 777 where 778 go _ 0 = pure [] 779 go pos remaining = do 780 let n = min 4096 remaining 781 bytes <- small pos n 782 (bytes :) <$> go (pos + toInteger n) (remaining - n) 783 when (sectionLimit < 0 || manifestLimit < 0) (throwE "invalid snapshot metadata limits") 784 header <- small 0 headerLength 785 (major, minor, count, _flags, directory) <- decoded (decodePortableHeader header) 786 when (major /= bundleMajorVersion) (throwE "unsupported bundle major version") 787 when (toInteger count > toInteger sectionLimit) (throwE "section count exceeds limit") 788 checkedRange (toInteger directory) (toInteger count * toInteger sectionEntryLength) 789 entries <- mapM (\index -> do 790 bytes <- small (toInteger directory + index * toInteger sectionEntryLength) sectionEntryLength 791 parsed <- decoded (decodeSectionEntries 1 bytes) 792 case parsed of 793 [entry] -> pure entry 794 _ -> throwE "invalid section directory") [0 .. toInteger count - 1] 795 mapM_ (decoded . rejectUnknownCritical) entries 796 manifestEntry <- decoded (requireSection sectionManifest entries) 797 nodesEntry <- decoded (requireSection sectionNodes entries) 798 let check entry = do 799 when (seCompression entry /= compressionNone) (throwE "unsupported compression codec") 800 checkedRange (toInteger (seOffset entry)) (toInteger (seLength entry)) 801 check manifestEntry 802 check nodesEntry 803 when (toInteger (seLength manifestEntry) > toInteger manifestLimit) (throwE "manifest exceeds limit") 804 manifestBytes <- boundedBytes (toInteger (seOffset manifestEntry)) (fromIntegral (seLength manifestEntry)) 805 manifest <- decoded (decodeManifest manifestBytes) 806 when (treeNodePayload (manifestTree manifest) /= "arboricx.indexed.payload.v1") $ 807 throwE "manifest does not use indexed payload" 808 let start = toInteger (seOffset nodesEntry) 809 end = start + toInteger (seLength nodesEntry) 810 nodeBytes offset count = do 811 when (offset + toInteger count > end) (throwE "truncated node section") 812 small offset count 813 nodes remaining offset !acc 814 | remaining == (0 :: Word64) = do 815 when (offset /= end) (throwE "trailing bytes after node section") 816 pure acc 817 | otherwise = do 818 lengthBytes <- nodeBytes offset 4 819 (countBytes, _) <- decoded (decode32be "payload_len" lengthBytes) 820 -- Fixed-size payloads: reject huge lengths before allocating/reading. 821 when (countBytes `notElem` [1,5,9]) (throwE "invalid node payload length") 822 bytes <- nodeBytes (offset + 4) (fromIntegral countBytes) 823 -- Force child IDs now, not when verification traverses the finished 824 -- table: otherwise deferred payload decoding retains input blocks. 825 !node <- decoded (deserializeBundleNode bytes) 826 nodes (remaining - 1) (offset + 4 + toInteger countBytes) (acc |> node) 827 countBytes <- nodeBytes start 8 828 (nodeCount, _) <- decoded (decode64be "node_count" countBytes) 829 when (toInteger nodeCount > (end - start - 8) `div` 5 || 830 toInteger nodeCount > toInteger (maxBound :: Word32)) $ 831 throwE "node count exceeds section or index bounds" 832 table <- nodes nodeCount (start + 8) Seq.empty 833 pure Bundle 834 { bundleVersion = major * 1000 + minor 835 , bundleRoots = map rootIndex (manifestRoots manifest) 836 , bundleNodes = table 837 , bundleManifest = manifest 838 , bundleManifestBytes = manifestBytes 839 } 840 841 -- --------------------------------------------------------------------------- 842 -- Container encoding / decoding 843 -- --------------------------------------------------------------------------- 844 845 data SectionEntry = SectionEntry 846 { seType :: Word32 847 , seVersion :: Word16 848 , seFlags :: Word16 849 , seCompression :: Word16 850 , seOffset :: Word64 851 , seLength :: Word64 852 } deriving (Show, Eq) 853 854 encodeHeader :: Word16 -> Word16 -> Word32 -> Word64 -> Word64 -> ByteString 855 encodeHeader major minor sectionCount flags dirOffset = 856 bundleMagic 857 <> encode16 major 858 <> encode16 minor 859 <> encode32 sectionCount 860 <> encode64 flags 861 <> encode64 dirOffset 862 863 encodeSectionEntry :: Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> Word64 -> ByteString 864 encodeSectionEntry sectionType sectionVersion sectionFlags compression offset lengthBytes = 865 encode32 sectionType 866 <> encode16 sectionVersion 867 <> encode16 sectionFlags 868 <> encode16 compression 869 <> encode16 0 -- reserved 870 <> encode64 offset 871 <> encode64 lengthBytes 872 <> encode32 0 -- reserved padding 873 874 decodePortableHeader :: ByteString -> Either String (Word16, Word16, Word32, Word64, Word64) 875 decodePortableHeader bs 876 | BS.length bs < headerLength = Left "bundle too short for header" 877 | BS.take 8 bs /= bundleMagic = Left "invalid portable bundle magic" 878 | otherwise = do 879 (major, r1) <- decode16be "major_version" (BS.drop 8 bs) 880 (minor, r2) <- decode16be "minor_version" r1 881 (sectionCount, r3) <- decode32be "section_count" r2 882 (flags, r4) <- decode64be "flags" r3 883 (dirOffset, _) <- decode64be "directory_offset" r4 884 Right (major, minor, sectionCount, flags, dirOffset) 885 886 decodeSectionEntries :: Word32 -> ByteString -> Either String [SectionEntry] 887 decodeSectionEntries count bytes = reverse <$> go count bytes [] 888 where 889 go 0 _ acc = Right acc 890 go n bs acc = do 891 when (BS.length bs < sectionEntryLength) $ 892 Left "section directory truncated" 893 (sectionType, r1) <- decode32be "section_type" bs 894 (sectionVersion, r2) <- decode16be "section_version" r1 895 (sectionFlags, r3) <- decode16be "section_flags" r2 896 (compression, r4) <- decode16be "compression_codec" r3 897 (_reserved, r5) <- decode16be "reserved" r4 898 (offset, r6) <- decode64be "section_offset" r5 899 (len, r7) <- decode64be "section_length" r6 900 (_reserved2, rest) <- decode32be "reserved" r7 901 let entry = SectionEntry sectionType sectionVersion sectionFlags compression offset len 902 go (n - 1) rest (entry : acc) 903 904 rejectUnknownCritical :: SectionEntry -> Either String () 905 rejectUnknownCritical entry = 906 let known = seType entry `elem` [sectionManifest, sectionNodes] 907 critical = seFlags entry .&. flagCritical /= 0 908 in when (critical && not known) $ 909 Left $ "unknown critical section type: " ++ show (seType entry) 910 911 requireSection :: Word32 -> [SectionEntry] -> Either String SectionEntry 912 requireSection sectionType entries = 913 case filter ((== sectionType) . seType) entries of 914 [entry] -> Right entry 915 [] -> Left $ "missing required section type: " ++ show sectionType 916 _ -> Left $ "duplicate section type: " ++ show sectionType 917 918 readAndVerifySection :: ByteString -> SectionEntry -> Either String ByteString 919 readAndVerifySection bs entry = do 920 when (seCompression entry /= compressionNone) $ 921 Left $ "unsupported compression codec in section " ++ show (seType entry) 922 let offset = fromIntegral (seOffset entry) 923 len = fromIntegral (seLength entry) 924 when (offset < 0 || len < 0 || BS.length bs < offset + len) $ 925 Left $ "section extends beyond bundle end: " ++ show (seType entry) 926 Right $ BS.take len $ BS.drop offset bs 927 928 -- --------------------------------------------------------------------------- 929 -- Node section encoding / decoding 930 -- --------------------------------------------------------------------------- 931 932 serializeBundleNode :: BundleNode -> ByteString 933 serializeBundleNode BNLeaf = BS.pack [0x00] 934 serializeBundleNode (BNStem child) = BS.pack [0x01] <> encode32 child 935 serializeBundleNode (BNFork left right) = BS.pack [0x02] <> encode32 left <> encode32 right 936 937 encodeNodeSection :: Seq BundleNode -> ByteString 938 encodeNodeSection nodes = 939 encode64 (fromIntegral $ Seq.length nodes) 940 <> foldMap encodeNodeEntry nodes 941 where 942 encodeNodeEntry node = 943 let payload = serializeBundleNode node 944 in encode32 (fromIntegral $ BS.length payload) <> payload 945 946 decodeNodeSection :: ByteString -> Either String (Seq BundleNode) 947 decodeNodeSection bs = do 948 (nodeCount, rest) <- decode64be "node_count" bs 949 decodeNodeEntries nodeCount rest 950 951 decodeNodeEntries :: Word64 -> ByteString -> Either String (Seq BundleNode) 952 decodeNodeEntries count bs = go count bs Seq.empty 953 where 954 go 0 rest acc 955 | BS.null rest = Right acc 956 | otherwise = Left "trailing bytes after node section" 957 go n bytes acc 958 | BS.length bytes < 4 = 959 Left "not enough bytes for node entry length" 960 | otherwise = do 961 (plen, rest) <- decode32be "payload_len" bytes 962 let payloadLen = fromIntegral plen 963 if BS.length rest < payloadLen 964 then Left "payload extends beyond node section end" 965 else do 966 let (payload, after) = BS.splitAt payloadLen rest 967 node <- deserializeBundleNode payload 968 go (n - 1) after (acc |> node) 969 970 deserializeBundleNode :: ByteString -> Either String BundleNode 971 deserializeBundleNode payload = 972 case BS.uncons payload of 973 Just (0x00, rest) 974 | BS.null rest -> Right BNLeaf 975 | otherwise -> Left "invalid leaf payload length" 976 Just (0x01, rest) 977 | BS.length rest == 4 -> Right $ BNStem (decodeU32 rest) 978 | otherwise -> Left "invalid stem payload length" 979 Just (0x02, rest) 980 | BS.length rest == 8 -> 981 let (leftBytes, rightBytes) = BS.splitAt 4 rest 982 in Right $ BNFork (decodeU32 leftBytes) (decodeU32 rightBytes) 983 | otherwise -> Left "invalid fork payload length" 984 _ -> Left "invalid node payload" 985 986 decodeU32 :: ByteString -> Word32 987 decodeU32 bs = 988 let b0 = fromIntegral (BS.index bs 0) :: Word32 989 b1 = fromIntegral (BS.index bs 1) :: Word32 990 b2 = fromIntegral (BS.index bs 2) :: Word32 991 b3 = fromIntegral (BS.index bs 3) :: Word32 992 in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3 993 994 -- --------------------------------------------------------------------------- 995 -- Bundle verification 996 -- --------------------------------------------------------------------------- 997 998 verifyBundle :: Bundle -> Either String () 999 verifyBundle bundle 1000 | bundleVersion bundle < 1 = Left $ "unsupported bundle version: " ++ show (bundleVersion bundle) 1001 | Seq.null (bundleNodes bundle) = Left "bundle has no nodes" 1002 verifyBundle bundle = do 1003 verifyManifestConstraints (bundleManifest bundle) 1004 let nodeCount = fromIntegral $ Seq.length (bundleNodes bundle) 1005 traverse_ (\idx -> when (idx >= nodeCount) $ Left $ "root index out of bounds: " ++ show idx) 1006 (bundleRoots bundle) 1007 traverse_ (\exp -> when (exportRoot exp >= nodeCount) $ Left $ "export index out of bounds: " ++ show (exportRoot exp)) 1008 (manifestExports $ bundleManifest bundle) 1009 1010 let verifyNode i node = case node of 1011 BNLeaf -> Right () 1012 BNStem child -> do 1013 when (child >= i) $ Left $ "stem at index " ++ show i ++ " references child " ++ show child 1014 when (child >= nodeCount) $ Left $ "stem at index " ++ show i ++ " references child out of bounds" 1015 Right () 1016 BNFork left right -> do 1017 when (left >= i) $ Left $ "fork at index " ++ show i ++ " references left " ++ show left 1018 when (right >= i) $ Left $ "fork at index " ++ show i ++ " references right " ++ show right 1019 when (left >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references left out of bounds" 1020 when (right >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references right out of bounds" 1021 Right () 1022 1023 mapM_ (\i -> case Seq.lookup (fromIntegral i) (bundleNodes bundle) of 1024 Nothing -> Left $ "internal error: node " ++ show i ++ " not found" 1025 Just node -> verifyNode i node) [0 :: Word32 .. nodeCount - 1] 1026 1027 let dupCheck = foldM (\seen (i, node) -> case node of 1028 BNLeaf -> if Set.member (0 :: Word8, 0 :: Word32, 0 :: Word32) seen 1029 then Left $ "duplicate leaf at index " ++ show i 1030 else Right $ Set.insert (0, 0, 0) seen 1031 BNStem child -> if Set.member (1, child, 0) seen 1032 then Left $ "duplicate stem at index " ++ show i 1033 else Right $ Set.insert (1, child, 0) seen 1034 BNFork left right -> if Set.member (2, left, right) seen 1035 then Left $ "duplicate fork at index " ++ show i 1036 else Right $ Set.insert (2, left, right) seen) Set.empty (zip [0 :: Word32 ..] (Foldable.toList $ bundleNodes bundle)) 1037 _ <- dupCheck 1038 Right () 1039 1040 verifyManifestConstraints :: BundleManifest -> Either String () 1041 verifyManifestConstraints manifest = do 1042 when (manifestSchema manifest /= "arboricx.bundle.manifest.v1") $ 1043 Left $ "unsupported manifest schema: " ++ unpack (manifestSchema manifest) 1044 when (manifestBundleType manifest /= "tree-calculus-executable-object") $ 1045 Left $ "unsupported bundle type: " ++ unpack (manifestBundleType manifest) 1046 let treeSpec = manifestTree manifest 1047 hashSpec = treeNodeHash treeSpec 1048 runtimeSpec = manifestRuntime manifest 1049 when (treeCalculus treeSpec /= "tree-calculus.v1") $ 1050 Left $ "unsupported calculus: " ++ unpack (treeCalculus treeSpec) 1051 when (nodeHashAlgorithm hashSpec /= "indexed") $ 1052 Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec) 1053 when (nodeHashDomain hashSpec /= "arboricx.indexed.node.v1") $ 1054 Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec) 1055 when (treeNodePayload treeSpec /= "arboricx.indexed.payload.v1") $ 1056 Left $ "unsupported node payload: " ++ unpack (treeNodePayload treeSpec) 1057 when (runtimeSemantics runtimeSpec /= "tree-calculus.v1") $ 1058 Left $ "unsupported runtime semantics: " ++ unpack (runtimeSemantics runtimeSpec) 1059 when (runtimeEvaluation runtimeSpec /= "normal-order") $ 1060 Left $ "unsupported runtime evaluation: " ++ unpack (runtimeEvaluation runtimeSpec) 1061 when (runtimeAbi runtimeSpec /= "arboricx.abi.tree.v1") $ 1062 Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec) 1063 when (not (null (runtimeCapabilities runtimeSpec))) $ 1064 Left "unsupported runtime capabilities" 1065 when (manifestClosure manifest /= ClosureComplete) $ 1066 Left "bundle requires closure = complete" 1067 when (null $ manifestRoots manifest) $ 1068 Left "manifest has no roots" 1069 when (null $ manifestExports manifest) $ 1070 Left "manifest has no exports" 1071 traverse_ verifyExport (manifestExports manifest) 1072 let names = map exportName (manifestExports manifest) 1073 when (Set.size (Set.fromList names) /= length names) $ 1074 Left "duplicate export name" 1075 where 1076 verifyExport exported = do 1077 when (T.null $ exportName exported) $ 1078 Left "manifest export has empty name" 1079 when (exportKind exported /= "term") $ 1080 Left $ "unsupported export kind: " ++ unpack (exportKind exported) 1081 when (exportAbi exported /= "arboricx.abi.tree.v1") $ 1082 Left $ "unsupported export ABI: " ++ unpack (exportAbi exported) 1083 1084 -- --------------------------------------------------------------------------- 1085 -- Bundle reconstruction 1086 -- --------------------------------------------------------------------------- 1087 1088 reconstructBundleTerms :: Seq BundleNode -> Vector T 1089 reconstructBundleTerms nodes = V.create $ do 1090 let n = Seq.length nodes 1091 vec <- MV.new n 1092 forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do 1093 t <- case node of 1094 BNLeaf -> return Leaf 1095 BNStem child -> Stem <$> MV.read vec (fromIntegral child) 1096 BNFork left right -> do 1097 l <- MV.read vec (fromIntegral left) 1098 r <- MV.read vec (fromIntegral right) 1099 return $ Fork l r 1100 MV.write vec i t 1101 return vec 1102 1103 -- --------------------------------------------------------------------------- 1104 -- Primitive binary helpers 1105 -- --------------------------------------------------------------------------- 1106 1107 encode16 :: Word16 -> ByteString 1108 encode16 w = BS.pack 1109 [ fromIntegral (shiftR w 8) 1110 , fromIntegral w 1111 ] 1112 1113 encode32 :: Word32 -> ByteString 1114 encode32 w = BS.pack 1115 [ fromIntegral (shiftR w 24) 1116 , fromIntegral (shiftR w 16) 1117 , fromIntegral (shiftR w 8) 1118 , fromIntegral w 1119 ] 1120 1121 encode64 :: Word64 -> ByteString 1122 encode64 w = BS.pack 1123 [ fromIntegral (shiftR w 56) 1124 , fromIntegral (shiftR w 48) 1125 , fromIntegral (shiftR w 40) 1126 , fromIntegral (shiftR w 32) 1127 , fromIntegral (shiftR w 24) 1128 , fromIntegral (shiftR w 16) 1129 , fromIntegral (shiftR w 8) 1130 , fromIntegral w 1131 ] 1132 1133 decode16be :: String -> ByteString -> Either String (Word16, ByteString) 1134 decode16be label bs 1135 | BS.length bs < 2 = Left (label ++ ": not enough bytes for u16") 1136 | otherwise = 1137 let b0 = fromIntegral (BS.index bs 0) :: Word16 1138 b1 = fromIntegral (BS.index bs 1) :: Word16 1139 in Right ((b0 `shiftL` 8) .|. b1, BS.drop 2 bs) 1140 1141 decode32be :: String -> ByteString -> Either String (Word32, ByteString) 1142 decode32be label bs 1143 | BS.length bs < 4 = Left (label ++ ": not enough bytes for u32") 1144 | otherwise = 1145 let b0 = fromIntegral (BS.index bs 0) :: Word32 1146 b1 = fromIntegral (BS.index bs 1) :: Word32 1147 b2 = fromIntegral (BS.index bs 2) :: Word32 1148 b3 = fromIntegral (BS.index bs 3) :: Word32 1149 in Right ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3, BS.drop 4 bs) 1150 1151 decode64be :: String -> ByteString -> Either String (Word64, ByteString) 1152 decode64be label bs 1153 | BS.length bs < 8 = Left (label ++ ": not enough bytes for u64") 1154 | otherwise = 1155 let b0 = fromIntegral (BS.index bs 0) :: Word64 1156 b1 = fromIntegral (BS.index bs 1) :: Word64 1157 b2 = fromIntegral (BS.index bs 2) :: Word64 1158 b3 = fromIntegral (BS.index bs 3) :: Word64 1159 b4 = fromIntegral (BS.index bs 4) :: Word64 1160 b5 = fromIntegral (BS.index bs 5) :: Word64 1161 b6 = fromIntegral (BS.index bs 6) :: Word64 1162 b7 = fromIntegral (BS.index bs 7) :: Word64 1163 in Right ((b0 `shiftL` 56) .|. (b1 `shiftL` 48) .|. (b2 `shiftL` 40) .|. (b3 `shiftL` 32) 1164 .|. (b4 `shiftL` 24) .|. (b5 `shiftL` 16) .|. (b6 `shiftL` 8) .|. b7, BS.drop 8 bs) 1165 1166 -- --------------------------------------------------------------------------- 1167 -- Helpers 1168 -- --------------------------------------------------------------------------- 1169 1170 defaultExportNames :: Int -> [Text] 1171 defaultExportNames n = 1172 case n of 1173 0 -> [] 1174 1 -> ["root"] 1175 _ -> ["root" <> T.pack (show i) | i <- [0 :: Int .. n - 1]]