tricu

Arboricx.hs (5575B)

---

 {-# LANGUAGE BangPatterns #-}
 
 module ContentStore.Arboricx
   ( merkleNodeDomain
   , putNode
   , getNode
   , treeTermDomain
   , encodeTreeTerm
   , decodeTreeTerm
   , decodeTreeTermShared
   , putTreeTerm
   , getTreeTerm
   , putTree
   , getTree
   ) where
 
 import ContentStore.Filesystem
 import ContentStore.Object
 import Runtime
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import Data.ByteString.Builder (word8, toLazyByteString)
 import qualified NodeTable as Nodes
 
 merkleNodeDomain :: Domain
 merkleNodeDomain = Domain "arboricx.merkle.node.v1"
 
 treeTermDomain :: Domain
 treeTermDomain = Domain "arboricx.tree-term.v1"
 
 putNode :: StorePath -> Node -> IO ObjectHash
 putNode store node = putObject store merkleNodeDomain (serializeNode node)
 
 getNode :: StorePath -> ObjectHash -> IO (Maybe Node)
 getNode store h = fmap deserializeNode <$> getVerifiedObject store merkleNodeDomain h
 
 -- | Store a complete normal tree as one content object. Merkle nodes remain
 -- available for DAG use cases, but module executable exports use this object
 -- kind to avoid filesystem writes for every subtree of large normal forms.
 encodeTreeTerm :: T -> BS.ByteString
 encodeTreeTerm tree = BL.toStrict (toLazyByteString (go [tree]))
   where
     -- Canonical preorder over logical occurrences, without repeatedly copying
     -- encoded subtrees. The explicit work stack does not intern or apply trees.
     go [] = mempty
     go (Leaf : rest) = word8 0 <> go rest
     go (Stem child : rest) = word8 1 <> go (child : rest)
     go (Fork left right : rest) = word8 2 <> go (left : right : rest)
 
 decodeTreeTerm :: BS.ByteString -> Either String T
 decodeTreeTerm payload = do
   (term, rest) <- getTerm payload
   if BS.null rest
     then Right term
     else Left "trailing bytes after tree term"
   where
     getTerm bs = case BS.uncons bs of
       Nothing -> Left "unexpected end of tree term"
       Just (0x00, rest) -> Right (Leaf, rest)
       Just (0x01, rest) -> do
         (child, afterChild) <- getTerm rest
         Right (Stem child, afterChild)
       Just (0x02, rest) -> do
         (left, afterLeft) <- getTerm rest
         (right, afterRight) <- getTerm afterLeft
         Right (Fork left right, afterRight)
       Just (tag, _) -> Left $ "unknown tree term tag: " ++ show tag
 
 -- ReadTreeTerm transports executable libraries. Raw canonical bytes repeat
 -- logical subtrees; allocating each occurrence loses the sharing that keeps
 -- large stable compiler libraries practical. Intern only within this decode,
 -- using exact constructor/child IDs (never tree equality, hashes or evaluation).
 -- Other raw data readers keep the ordinary decoder: a mostly unique data tree
 -- can cost more with an intern table. Space is O(unique nodes + input + depth),
 -- time O(logical bytes * min(word bits, unique nodes)); the table is not globally retained.
 data SharedDecodeFrame
   = SharedStem
   | SharedForkLeft
   | SharedForkRight !(Int, T)
 
 decodeTreeTermShared :: BS.ByteString -> Either String T
 decodeTreeTermShared payload = readNode 0 [] Nodes.empty 1
   where
     !lengthBytes = BS.length payload
     readNode !offset frames !table !next
       | offset >= lengthBytes = Left "unexpected end of tree term"
       | otherwise = case BS.index payload offset of
           0 -> deliver (0, Leaf) (offset + 1) frames table next
           1 -> readNode (offset + 1) (SharedStem : frames) table next
           2 -> readNode (offset + 1) (SharedForkLeft : frames) table next
           tag -> Left $ "unknown tree term tag: " ++ show tag
     deliver (_, tree) !offset [] _ _
       | offset == lengthBytes = Right tree
       | otherwise = Left "trailing bytes after tree term"
     deliver (childId, child) !offset (SharedStem : frames) table next =
       intern (Nodes.StemKey childId) (Stem child) offset frames table next
     deliver left !offset (SharedForkLeft : frames) table next =
       readNode offset (SharedForkRight left : frames) table next
     deliver (rightId, right) !offset (SharedForkRight (leftId, left) : frames) table next =
       intern (Nodes.ForkKey leftId rightId) (Fork left right) offset frames table next
     intern key tree offset frames table next = case Nodes.lookup key table of
       Just node -> deliver node offset frames table next
       Nothing ->
         let !node = (next, tree)
             !updated = Nodes.insert key node table
         in deliver node offset frames updated (next + 1)
 
 putTreeTerm :: StorePath -> T -> IO ObjectHash
 putTreeTerm store = putObject store treeTermDomain . encodeTreeTerm
 
 getTreeTerm :: StorePath -> ObjectHash -> IO (Maybe T)
 getTreeTerm store h = do
   mPayload <- getVerifiedObject store treeTermDomain h
   case mPayload of
     Nothing -> pure Nothing
     Just payload -> case decodeTreeTerm payload of
       Left err -> fail $ "invalid tree term " ++ show h ++ ": " ++ err
       Right term -> pure (Just term)
 
 putTree :: StorePath -> T -> IO ObjectHash
 putTree store = go
   where
     go Leaf = putNode store NLeaf
     go (Stem t) = do
       child <- go t
       putNode store (NStem child)
     go (Fork l r) = do
       left <- go l
       right <- go r
       putNode store (NFork left right)
 
 getTree :: StorePath -> ObjectHash -> IO (Maybe T)
 getTree store root = do
   mNode <- getNode store root
   case mNode of
     Nothing -> return Nothing
     Just node -> case node of
       NLeaf -> return (Just Leaf)
       NStem child -> fmap Stem <$> getTree store child
       NFork left right -> do
         ml <- getTree store left
         mr <- getTree store right
         return $ Fork <$> ml <*> mr