tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

Bundle.hs (6420B)

      1 {-# LANGUAGE BangPatterns #-}
      2 
      3 module ContentStore.Bundle
      4   ( packExecutableBundleFromStore
      5   , loadExecutableObject
      6   , packBundleFromStore
      7   , unpackBundleToStoreWithLimit
      8   , checkFlatImportSize
      9   , defaultFlatImportLimit
     10   , unpackBundleToStore
     11   , indexedTreeDomain
     12   , decodeIndexedTree
     13   , encodeIndexedTree
     14   , unpackIndexedBundleToStore
     15   ) where
     16 
     17 import ContentStore.Executable (loadExecutableObject)
     18 import ContentStore.Indexed
     19 import ContentStore.Arboricx
     20 import ContentStore.Alias (ObjectRef(..))
     21 import ContentStore.Object
     22 import ContentStore.Filesystem (putObject, objectPath)
     23 import Runtime (T)
     24 import Wire
     25 
     26 import Control.Monad (foldM, forM, forM_, unless)
     27 import Crypto.Hash (Context, SHA256, hashInit, hashUpdate, hashFinalize)
     28 import Data.ByteString (ByteString)
     29 import Data.Text (Text)
     30 import Data.Text.Encoding (encodeUtf8)
     31 import System.Directory (doesFileExist)
     32 import System.IO (IOMode(ReadMode), withBinaryFile)
     33 import qualified Data.ByteString as BS
     34 import qualified Data.Vector as V
     35 import qualified Data.Vector.Mutable as MV
     36 import qualified Data.Foldable as Foldable
     37 
     38 -- | Import without reconstructing/flattening T. Extraction works on graph
     39 -- indices, strips unrelated roots/metadata, and makes identity alias-neutral.
     40 unpackIndexedBundleToStore :: StorePath -> ByteString -> IO [(Text, ObjectHash)]
     41 unpackIndexedBundleToStore store payload = do
     42   bundle <- either fail pure (decodeBundle payload)
     43   either fail pure (verifyBundle bundle)
     44   forM (manifestExports $ bundleManifest bundle) $ \exported -> do
     45     unless (exportKind exported == "term" && exportAbi exported == "arboricx.abi.tree.v1") $
     46       fail "indexed import requires term exports with the tree ABI"
     47     root <- either fail pure (extractBundleRoot bundle $ exportRoot exported)
     48     digest <- putObject store indexedTreeDomain (encodeBundle root)
     49     pure (exportName exported, digest)
     50 
     51 -- Preserve the streaming flat path for retained compiler/rollback stores.
     52 -- Current indexed objects decode into shared terms; the shared writer visits
     53 -- physical nodes rather than unfolding logical branches across exported roots.
     54 packExecutableBundleFromStore :: StorePath -> [(Text, ObjectRef)] -> IO Bundle
     55 packExecutableBundleFromStore store exports
     56   | all ((== unDomain treeTermDomain) . objectRefKind . snd) exports =
     57       packBundleFromStore store [(name, objectRefHash ref) | (name, ref) <- exports]
     58   | otherwise = do
     59       trees <- forM exports $ \(name, ref) -> do
     60         tree <- loadExecutableObject store ref
     61         pure (name, tree)
     62       buildBundleShared trees
     63 
     64 -- | Pack verified canonical CAS bytes directly into the indexed DAG. Read one
     65 -- export at a time in bounded chunks; never retain all payloads or construct
     66 -- expanded Haskell trees. Sharing is global across exports. Memory still scales
     67 -- with unique DAG size and maximum input depth, not a fixed constant.
     68 packBundleFromStore :: StorePath -> [(Text, ObjectHash)] -> IO Bundle
     69 packBundleFromStore store exports =
     70   finishTreeTermBundle <$> foldM packOne emptyTreeTermBundle exports
     71   where
     72     packOne !builder (name, root) = do
     73       either fail (const (pure ())) (textToHashBytes root)
     74       let path = objectPath store root
     75       exists <- doesFileExist path
     76       unless exists $ fail $ "CAS tree term not found: " ++ show root
     77       withBinaryFile path ReadMode $ \handle -> do
     78         let initialHash = hashUpdate (hashInit :: Context SHA256)
     79               (encodeUtf8 (unDomain treeTermDomain) <> BS.singleton 0)
     80             readChunks !context !cursor = do
     81               chunk <- BS.hGetSome handle 65536
     82               if BS.null chunk
     83                 then do
     84                   unless (hashToText (hashFinalize context) == root) $
     85                     fail $ "Executable tree digest mismatch: " ++ show root
     86                   either (fail . (("invalid tree term " ++ show root ++ ": ") ++)) pure
     87                     (endTreeTerm name cursor)
     88                 else do
     89                   updated <- either (fail . (("invalid tree term " ++ show root ++ ": ") ++)) pure
     90                     (feedTreeTerm chunk cursor)
     91                   readChunks (hashUpdate context chunk) updated
     92         readChunks initialHash (startTreeTerm builder)
     93 
     94 -- | Unpack an indexed Arboricx transport bundle into CAS tree terms.
     95 -- Returns each manifest export name paired with its stored CAS tree-term hash.
     96 unpackBundleToStore :: StorePath -> ByteString -> IO [(Text, ObjectHash)]
     97 unpackBundleToStore = unpackBundleToStoreWithLimit defaultFlatImportLimit
     98 
     99 -- Aggregate canonical bytes across all exports (including repeated roots).
    100 -- Saturation bounds integer size even for exponentially shared DAGs. Verification
    101 -- precedes indexing; count only, never construct or traverse expanded trees.
    102 defaultFlatImportLimit :: Integer
    103 defaultFlatImportLimit = 64 * 1024 * 1024
    104 
    105 checkFlatImportSize :: Integer -> Bundle -> Either String ()
    106 checkFlatImportSize limit bundle = do
    107   unless (limit > 0) $ Left "flat import byte limit must be positive"
    108   verifyBundle bundle
    109   let nodes = V.fromList (Foldable.toList (bundleNodes bundle))
    110       cap = limit + 1
    111       sizes = V.create $ do
    112         values <- MV.new (V.length nodes)
    113         forM_ [0 .. V.length nodes - 1] $ \index -> do
    114           size <- case nodes V.! index of
    115             BNLeaf -> pure 1
    116             BNStem c -> (1 +) <$> MV.read values (fromIntegral c)
    117             BNFork l r -> do
    118               left <- MV.read values (fromIntegral l)
    119               right <- MV.read values (fromIntegral r)
    120               pure (1 + left + right)
    121           let !bounded = min cap size
    122           MV.write values index bounded
    123         pure values
    124       total = Foldable.foldl' (\acc ex -> min cap (acc + sizes V.! fromIntegral (exportRoot ex)))
    125         0 (manifestExports (bundleManifest bundle))
    126   unless (total <= limit) $
    127     Left "flat import byte limit exceeded; use indexed import or explicitly raise --max-flat-bytes"
    128 
    129 unpackBundleToStoreWithLimit :: Integer -> StorePath -> ByteString -> IO [(Text, ObjectHash)]
    130 unpackBundleToStoreWithLimit limit store bs = do
    131   bundle <- either fail pure (decodeBundle bs)
    132   either fail pure (checkFlatImportSize limit bundle)
    133   let terms = reconstructBundleTerms (bundleNodes bundle)
    134   forM (manifestExports $ bundleManifest bundle) $ \exported -> do
    135     let term = terms V.! fromIntegral (exportRoot exported)
    136     root <- putTreeTerm store term
    137     return (exportName exported, root)