Full Merkle tree resolution

src/Research.hs

@@ -1,12 +1,17 @@
 module Research where
 
+import Data.ByteArray            (convert)
+import Data.Char                 (chr, ord)
 import Data.List                 (intercalate)
 import Data.Map                  (Map)
-import Data.Text                 (Text, replace)
+import Data.Text                 (Text, replace, unpack)
+import Data.Word                 (Word8)
 import System.Console.CmdArgs    (Data, Typeable)
 
+import qualified Data.ByteString as BS
 import qualified Data.Map        as Map
-import qualified Data.Text as T
+import qualified Data.Text       as T
+import Crypto.Hash               (hash, SHA256, Digest)
 
 -- Tree Calculus Types
 data T = Leaf | Stem T | Fork T T
@@ -54,6 +59,93 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
 -- Environment containing previously evaluated TC terms
 type Env = Map.Map String T
 
+-- Merkle DAG Node types
+-- Each Tree Calculus node becomes a content-addressed object.
+
+type MerkleHash = Text
+
+data Node
+  = NLeaf
+  | NStem MerkleHash
+  | NFork MerkleHash MerkleHash
+  deriving (Show, Eq, Ord)
+
+-- | Canonical serialization of a Node for hashing.
+--   Leaf:  0x00
+--   Stem:  0x01 || child_hash (32 bytes)
+--   Fork:  0x02 || left_hash (32 bytes) || right_hash (32 bytes)
+serializeNode :: Node -> BS.ByteString
+serializeNode NLeaf        = BS.pack [0x00]
+serializeNode (NStem h)    = BS.pack [0x01] <> hexToBytes h
+serializeNode (NFork l r)  = BS.pack [0x02] <> hexToBytes l <> hexToBytes r
+
+-- | Hash a node per the Merkle content-addressing spec.
+-- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload )
+nodeHash :: Node -> MerkleHash
+nodeHash node = bytesToHex (sha256WithPrefix (serializeNode node))
+  where sha256WithPrefix payload =
+          convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
+        utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1"
+
+-- | Convert a Hex Text hash into raw ByteString (2 hex chars per byte)
+hexToBytes :: Text -> BS.ByteString
+hexToBytes h = BS.pack $ map combinePair pairs
+  where
+    chars = unpack h
+    pairs = chunkPairs chars
+    chunkPairs :: String -> [(Char, Char)]
+    chunkPairs (c1:c2:rest) = (c1, c2) : chunkPairs rest
+    chunkPairs [] = []
+    chunkPairs _ = error "hexToBytes: odd number of hex digits"
+    combinePair :: (Char, Char) -> Word8
+    combinePair (c1, c2) = fromIntegral (hexDigitToInt c1 * 16 + hexDigitToInt c2)
+    hexDigitToInt :: Char -> Int
+    hexDigitToInt c
+      | '0' <= c && c <= '9'  = ord c - ord '0'
+      | 'a' <= c && c <= 'f'  = ord c - ord 'a' + 10
+      | 'A' <= c && c <= 'F'  = ord c - ord 'A' + 10
+      | otherwise              = error $ "Invalid hex digit: " ++ show c
+
+-- | Deserialize a Node from canonical bytes.
+deserializeNode :: BS.ByteString -> Node
+deserializeNode bs =
+  case BS.uncons bs of
+    Just (0x00, rest)
+      | BS.null rest -> NLeaf
+
+    Just (0x01, rest)
+      | BS.length rest == 32 ->
+          NStem $ bytesToHex rest
+
+    Just (0x02, rest)
+      | BS.length rest == 64 ->
+          let (l, r) = BS.splitAt 32 rest
+          in NFork (bytesToHex l) (bytesToHex r)
+
+    _ -> error "invalid merkle node payload"
+
+
+-- | Convert 32-byte ByteString back to hex Text
+bytesToHex :: BS.ByteString -> Text
+bytesToHex bs = T.pack $ concatMap byteToHexChars $ BS.unpack bs
+  where
+    byteToHexChars :: Word8 -> String
+    byteToHexChars w = [hexDigit (fromIntegral w `div` 16), hexDigit (fromIntegral w `mod` 16)]
+    hexDigit :: Int -> Char
+    hexDigit n
+      | n < 10    = chr (ord '0' + n)
+      | otherwise = chr (ord 'a' + n - 10)
+
+-- | Build a Merkle DAG from a Tree Calculus term.
+buildMerkle :: T -> Node
+buildMerkle Leaf = NLeaf
+buildMerkle (Stem t) = NStem (nodeHash child)
+  where child = buildMerkle t
+buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
+  where
+    left  = buildMerkle l
+    right = buildMerkle r
+
 -- Tree Calculus Reduction Rules
 {-
   The t operator is left associative.