Implementation of a Bitcoin Merkle Tree

merkle.ml

type 'a tree =
  | Leaf
  | Node of 'a * 'a tree * 'a tree
  
let node_of_tx tx = if String.length tx > 0 then Node (tx, Leaf, Leaf) else Leaf

let tree_of_txs txs =
  let nodes = List.map node_of_tx txs in
  match nodes with
  | [] -> Leaf
  | [x] -> x
  | x::xs ->
  let empty = Leaf
  and levels =
    match nodes with
    | [] -> 0
    | [x] -> 1
    | x::xs -> (
      if List.length nodes mod 2 = 0 then List.length nodes
      else List.length nodes + 1 ) / 2 in
      
  (** The meat of the function *)
  let rec aux ?(tries=levels) ?(next=[]) tree' nodes' =
    match nodes' with
    (** This case should never be reached. *)
    | [] -> Leaf
    (** Either a Merkle Root or just another level about to end. *)
    | [x] ->
      (** Merkle root is reached. *)
      if levels = 0 then x else
        (** Widow node reached. *)
        let Node (x_data, _, _) = x in
        let parent_data = x_data ^ x_data in
        let parent = Node (parent_data, x, x) in 
        aux ~tries:(levels-1) tree' (next @ [parent])
    (** start of a level *)
    | a :: b :: rest -> (
      match a, b with
      | Leaf, Leaf -> empty
      | Node (a_data, _, _), Leaf ->
        let parent_data = a_data ^ a_data in
        let parent = Node (parent_data, a, a) in
        
        if List.length rest = 0 
        then aux ~tries:(levels-1) tree' (next @ [parent])
        else aux ~next:(next @ [parent]) tree' rest

      | Leaf, Node (b_data, _, _) ->
        let parent_data = b_data ^ b_data in
        let parent = Node (parent_data, b, b) in

        if List.length rest = 0
        then aux ~tries:(levels-1) tree' (next @ [parent])
        else aux ~next:(next @ [parent]) tree' rest

      | Node (a_data, _, _), Node (b_data, _, _) ->
        let parent_data = a_data ^ b_data in
        let parent = Node (parent_data, a, b) in

        if List.length rest = 0
        then aux ~tries:(levels-1) tree' (next @ [parent])
        else aux ~next:(next @ [parent]) tree' rest
      )
  in aux Leaf nodes