Merkle.hs (5518B)
1 -- Native Merkle codecs and DAG export, independent of source compilation. 2 module Runtime.Merkle where 3 4 import Runtime.Tree 5 import Runtime.Value 6 import Crypto.Hash (hash, SHA256, Digest) 7 import Data.ByteArray (convert) 8 import Data.ByteString.Base16 (decode, encode) 9 import Data.Text (Text) 10 import Data.Text.Encoding (decodeUtf8, encodeUtf8) 11 import qualified Data.ByteString as BS 12 import qualified Data.Map as Map 13 import qualified Data.Set as Set 14 15 -- Merkle DAG Node types 16 -- Each Tree Calculus node becomes a content-addressed object. 17 type MerkleHash = Text 18 19 data Node 20 = NLeaf 21 | NStem MerkleHash 22 | NFork MerkleHash MerkleHash 23 deriving (Show, Eq, Ord) 24 25 -- | Canonical serialization of a Node for hashing. 26 -- Leaf: 0x00 27 -- Stem: 0x01 || child_hash (32 bytes) 28 -- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes) 29 serializeNode :: Node -> BS.ByteString 30 serializeNode NLeaf = BS.pack [0x00] 31 serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h)) 32 where go (Left _) = error "Runtime.serializeNode: invalid hex hash" 33 go (Right bs) = bs 34 serializeNode (NFork l r) = BS.pack [0x02] <> go (decode (encodeUtf8 l)) <> go (decode (encodeUtf8 r)) 35 where go (Left _) = error "Runtime.serializeNode: invalid hex hash" 36 go (Right bs) = bs 37 38 -- | Hash a node per the Merkle content-addressing spec. 39 -- hash = SHA256( "arboricx.merkle.node.v1" <> 0x00 <> node_payload ) 40 nodeHash :: Node -> MerkleHash 41 nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node))) 42 where sha256WithPrefix payload = 43 convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload 44 utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "arboricx.merkle.node.v1" 45 46 -- | Deserialize a Node from canonical bytes. 47 deserializeNode :: BS.ByteString -> Node 48 deserializeNode bs = 49 case BS.uncons bs of 50 Just (0x00, rest) 51 | BS.null rest -> NLeaf 52 53 Just (0x01, rest) 54 | BS.length rest == 32 -> 55 NStem $ decodeUtf8 (encode rest) 56 57 Just (0x02, rest) 58 | BS.length rest == 64 -> 59 let (l, r) = BS.splitAt 32 rest 60 in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r)) 61 62 _ -> errorWithoutStackTrace "invalid merkle node payload" 63 64 -- | Convert a canonical Arboricx node payload (ByteString) to a Tree 65 -- representation (a list of Byte trees). 66 nodePayloadToTreeBytes :: BS.ByteString -> T 67 nodePayloadToTreeBytes = ofBytes 68 69 -- | Convert a Tree representation of a node payload back to ByteString. 70 treeBytesToNodePayload :: T -> Either String BS.ByteString 71 treeBytesToNodePayload = toBytes 72 73 -- | Convert a MerkleHash (hex-encoded) to a Tree of its 32 raw bytes. 74 hashToTreeBytes :: MerkleHash -> Either String T 75 hashToTreeBytes h = case decode (encodeUtf8 h) of 76 Left _ -> Left "Invalid hex MerkleHash" 77 Right raw 78 | BS.length raw == 32 -> Right (ofBytes raw) 79 | otherwise -> Left "Hash raw bytes must be 32 bytes" 80 81 -- | Convert a Tree of 32 Byte trees back to a MerkleHash (hex string). 82 treeBytesToHash :: T -> Either String MerkleHash 83 treeBytesToHash t = case toList t of 84 Left err -> Left err 85 Right bytes 86 | length bytes == 32 -> do 87 raw <- BS.pack <$> mapM toByte bytes 88 Right $ decodeUtf8 (encode raw) 89 | otherwise -> Left "Expected exactly 32 byte elements for hash" 90 91 -- | Build a Merkle DAG from a Tree Calculus term. 92 buildMerkle :: T -> Node 93 buildMerkle Leaf = NLeaf 94 buildMerkle (Stem t) = NStem (nodeHash child) 95 where child = buildMerkle t 96 buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right) 97 where 98 left = buildMerkle l 99 right = buildMerkle r 100 101 -- --------------------------------------------------------------------------- 102 -- DAG node-table export (for host-language kernel embedding) 103 -- --------------------------------------------------------------------------- 104 105 -- | Export a term's Merkle DAG as a topologically-sorted node table. 106 -- Children appear before parents so all index references are forward. 107 -- Returns (root index, list of (tag, [child_indices])). 108 exportDag :: T -> (Int, [(String, [Int])]) 109 exportDag term = 110 let (root, acc, _) = collectDag term [] Set.empty 111 -- acc is in reverse post-order (children first, root last) 112 ordered = reverse acc 113 idxMap = Map.fromList [(h, i) | (i, (h, _)) <- zip [0..] ordered] 114 rootIdx = idxMap Map.! root 115 lines_ = map (formatNode idxMap . snd) ordered 116 in (rootIdx, lines_) 117 where 118 collectDag :: T -> [(MerkleHash, Node)] -> Set.Set MerkleHash -> (MerkleHash, [(MerkleHash, Node)], Set.Set MerkleHash) 119 collectDag Leaf acc seen = 120 let h = nodeHash NLeaf 121 in if Set.member h seen then (h, acc, seen) else (h, (h, NLeaf) : acc, Set.insert h seen) 122 collectDag (Stem t) acc seen = 123 let (ch, acc', seen') = collectDag t acc seen 124 node = NStem ch 125 h = nodeHash node 126 in if Set.member h seen' then (h, acc', seen') else (h, (h, node) : acc', Set.insert h seen') 127 collectDag (Fork l r) acc seen = 128 let (lh, acc', seen') = collectDag l acc seen 129 (rh, acc'', seen'') = collectDag r acc' seen' 130 node = NFork lh rh 131 h = nodeHash node 132 in if Set.member h seen'' then (h, acc'', seen'') else (h, (h, node) : acc'', Set.insert h seen'') 133 134 formatNode :: Map.Map MerkleHash Int -> Node -> (String, [Int]) 135 formatNode _ NLeaf = ("leaf", []) 136 formatNode idxMap (NStem ch) = ("stem", [idxMap Map.! ch]) 137 formatNode idxMap (NFork l r) = ("fork", [idxMap Map.! l, idxMap Map.! r])