tricu

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

Arboricx.hs (2956B)

      1 module ContentStore.Arboricx
      2   ( merkleNodeDomain
      3   , putNode
      4   , getNode
      5   , treeTermDomain
      6   , encodeTreeTerm
      7   , decodeTreeTerm
      8   , putTreeTerm
      9   , getTreeTerm
     10   , putTree
     11   , getTree
     12   ) where
     13 
     14 import ContentStore.Filesystem
     15 import ContentStore.Object
     16 import Research
     17 
     18 import qualified Data.ByteString as BS
     19 
     20 merkleNodeDomain :: Domain
     21 merkleNodeDomain = Domain "arboricx.merkle.node.v1"
     22 
     23 treeTermDomain :: Domain
     24 treeTermDomain = Domain "arboricx.tree-term.v1"
     25 
     26 putNode :: StorePath -> Node -> IO ObjectHash
     27 putNode store node = putObject store merkleNodeDomain (serializeNode node)
     28 
     29 getNode :: StorePath -> ObjectHash -> IO (Maybe Node)
     30 getNode store h = fmap deserializeNode <$> getObject store h
     31 
     32 -- | Store a complete normal tree as one content object. Merkle nodes remain
     33 -- available for DAG use cases, but module executable exports use this object
     34 -- kind to avoid filesystem writes for every subtree of large normal forms.
     35 encodeTreeTerm :: T -> BS.ByteString
     36 encodeTreeTerm Leaf = BS.pack [0x00]
     37 encodeTreeTerm (Stem t) = BS.cons 0x01 (encodeTreeTerm t)
     38 encodeTreeTerm (Fork l r) = BS.cons 0x02 (encodeTreeTerm l <> encodeTreeTerm r)
     39 
     40 decodeTreeTerm :: BS.ByteString -> Either String T
     41 decodeTreeTerm payload = do
     42   (term, rest) <- getTerm payload
     43   if BS.null rest
     44     then Right term
     45     else Left "trailing bytes after tree term"
     46   where
     47     getTerm bs = case BS.uncons bs of
     48       Nothing -> Left "unexpected end of tree term"
     49       Just (0x00, rest) -> Right (Leaf, rest)
     50       Just (0x01, rest) -> do
     51         (child, afterChild) <- getTerm rest
     52         Right (Stem child, afterChild)
     53       Just (0x02, rest) -> do
     54         (left, afterLeft) <- getTerm rest
     55         (right, afterRight) <- getTerm afterLeft
     56         Right (Fork left right, afterRight)
     57       Just (tag, _) -> Left $ "unknown tree term tag: " ++ show tag
     58 
     59 putTreeTerm :: StorePath -> T -> IO ObjectHash
     60 putTreeTerm store = putObject store treeTermDomain . encodeTreeTerm
     61 
     62 getTreeTerm :: StorePath -> ObjectHash -> IO (Maybe T)
     63 getTreeTerm store h = do
     64   mPayload <- getObject store h
     65   case mPayload of
     66     Nothing -> pure Nothing
     67     Just payload -> case decodeTreeTerm payload of
     68       Left err -> fail $ "invalid tree term " ++ show h ++ ": " ++ err
     69       Right term -> pure (Just term)
     70 
     71 putTree :: StorePath -> T -> IO ObjectHash
     72 putTree store = go
     73   where
     74     go Leaf = putNode store NLeaf
     75     go (Stem t) = do
     76       child <- go t
     77       putNode store (NStem child)
     78     go (Fork l r) = do
     79       left <- go l
     80       right <- go r
     81       putNode store (NFork left right)
     82 
     83 getTree :: StorePath -> ObjectHash -> IO (Maybe T)
     84 getTree store root = do
     85   mNode <- getNode store root
     86   case mNode of
     87     Nothing -> return Nothing
     88     Just node -> case node of
     89       NLeaf -> return (Just Leaf)
     90       NStem child -> fmap Stem <$> getTree store child
     91       NFork left right -> do
     92         ml <- getTree store left
     93         mr <- getTree store right
     94         return $ Fork <$> ml <*> mr