Different merkle trees for files

interpreter/main/main.ml

@@ -67,7 +67,6 @@ let argspec = Arg.align
   "-debug-error", Arg.Set Flags.debug_error, " try to find out why the interpreter failed";
   "-m", Arg.Set Flags.merkle, " merkle proof mode";
   "-micro", Arg.Set Flags.microstep, " merkle proof mode (microsteps)";
-  "-merkletest", Arg.Int (fun n -> Mbinary.test n; exit 0), " just run a merkle root computation test with a number of leafs";
   "-init", Arg.Set Flags.init, " output initial state hash of a test case";
   "-init-vm", Arg.Set Flags.init_vm, " output initial vm of a test case";
   "-result", Arg.Set Flags.result, " output final state hash of a test case and the number of steps";
@@ -166,7 +165,7 @@ let () =
         let oc = open_out_bin "decoded.bin" in
         for i = 0 to Array.length vm.code - 1 do
           let inst = vm.code.(i) in
-          output_bytes oc (Mbinary.microp_word (get_code inst))
+          output_bytes oc (Bytes.of_string (Mbinary.microp_word (get_code inst)))
         done;
         close_out oc
       | _ -> () )

interpreter/merkle/addglobals.ml

@@ -76,7 +76,7 @@ let int_binary i =
   Bytes.set res 1 (Char.chr ((i lsr 8) land 0xff));
   Bytes.set res 2 (Char.chr ((i lsr 16) land 0xff));
   Bytes.set res 3 (Char.chr ((i lsr 24) land 0xff));
-  res
+  Bytes.to_string res
 
 let generate_data (addr, i) : string segment =
   elem {

interpreter/merkle/byteutil.ml

@@ -5,8 +5,8 @@ let trace name = if !Flags.trace then print_endline ("-- " ^ name)
 
 let w256_to_string bs =
   let res = ref "" in
-  for i = 0 to Bytes.length bs - 1 do
-    let code = Char.code bs.[i] in
+  for i = 0 to String.length bs - 1 do
+    let code = Char.code (String.get bs i) in
     res := !res ^ (if code < 16 then "0" else "") ^ Printf.sprintf "%x" code
   done;
   !res
@@ -32,7 +32,7 @@ let eos s = (pos s = len s)
 let check n s = if pos s + n > len s then raise EOS
 let skip n s = check n s; s.pos := !(s.pos) + n
 
-let read s = if !(s.pos) < len s then Char.code (s.bytes.[!(s.pos)]) else 0
+let read s = if !(s.pos) < len s then Char.code (String.get s.bytes (!(s.pos))) else 0
 let peek s = if eos s then None else Some (read s)
 
 (* let get s = check 1 s; let b = read s in skip 1 s; b *)
@@ -60,7 +60,7 @@ let u64 s =
   Int64.(add lo (shift_left hi 32))
 
 let mini_memory bytes =
-  let s = stream (Memory.to_bytes bytes) in
+  let s = stream (Bytes.to_string (Memory.to_bytes bytes)) in
 (*  trace ("Get memory: " ^ w256_to_string (Memory.to_bytes bytes)); *)
   let a = u64 s and b = u64 s in
 (*  trace ("A: " ^ Int64.to_string a); *)
@@ -78,7 +78,7 @@ let word bytes =
   !res
 
 let bytes_to_array bytes =
-  let s = stream bytes in
+  let s = stream (Bytes.to_string bytes) in
   let res = Array.make (Bytes.length bytes) 0L in
   for i = 0 to Bytes.length bytes / 8 do
     res.(i) <- u64 s
@@ -107,8 +107,6 @@ let to_bytes s =
   Buffer.clear s.buf;
   bs
 
-
-
 let s = stream ()
 
     let u8 i = put s (Char.chr (i land 0xff))
@@ -146,7 +144,7 @@ let extend bs n =
     Bytes.set nbs (n-1-i) (Bytes.get bs i)
   done;
 (*  Bytes.blit bs 0 nbs (n-len) len; *)
-  nbs
+  Bytes.to_string nbs
 
 let value = function
   | I32 i -> u32 i

interpreter/merkle/mbinary.ml

@@ -236,6 +236,7 @@ let out_code_byte = function
  | SetTable -> 0x13
  | SetTableTypes -> 0x14
  | SetMemory -> 0x15
+ | CustomFileWrite -> 0x16
 
 let stack_ch_byte = function
  | StackRegSub -> 0x00
@@ -278,12 +279,13 @@ let microp_word op =
   value op.immed;
   extend (to_bytes s) 32
 
-type w256 = bytes
+type w256 = string
 
 open Cryptokit
 
 (* keccak two words, clear control byte *)
 
+(*
 let ccb w =
   let res = Bytes.copy w in
   Bytes.set res 31 (Char.chr 0);
@@ -298,6 +300,7 @@ let ccb2 w =
   let res = Bytes.copy w in
   Bytes.set res 31 (Char.chr 1);
   res
+*)
 
 let keccak w1 w2 =
   let hash = Hash.keccak 256 in
@@ -382,7 +385,7 @@ let rec mapMerkle f arr idx level =
 
 let rec depth x = if x <= 1 then 0 else 1 + depth (x/2)
 
-let get_hash arr =
+let get_hash (arr: w256 array) =
   makeMerkle arr 0 (depth (Array.length arr*2-1))
 
 let map_hash f arr = mapMerkle f arr 0 (depth (Array.length arr*2-1))
@@ -416,24 +419,34 @@ let hash_stack arr =
 
 let string_to_array str =
   (* need one extra for nil terminated strings*)
-  let res = Array.make (String.length str) (u256 0) in
-  for i = 0 to String.length str - 1 do
-    res.(i) <- u256 (Char.code str.[i])
+  let res = Array.make (Bytes.length str) (u256 0) in
+  for i = 0 to Bytes.length str - 1 do
+    res.(i) <- u256 (Char.code (Bytes.get str i))
   done;
   res
 
 let string_to_root str = get_hash (string_to_array str)
 
-let zeros = String.make 64 (Char.chr 0)
+let zeros = Bytes.make 64 (Char.chr 0)
 
-let get_bytes32 str n = String.sub str n 32
+let get_bytes32 str n = Bytes.sub str n 32
+let get_bytes16 str n = Bytes.sub str n 16
+
+let bytes_to_array32 str =
+  let cells = max ((Bytes.length str + 31) / 32) 2 in
+  let res = Array.make cells (u256 0) in
+  let str_e = Bytes.cat str zeros in
+  for i = 0 to cells - 1 do
+    res.(i) <- Bytes.to_string (get_bytes32 str_e (i*32))
+  done;
+  res
 
 let bytes_to_array str =
-  let cells = max ((String.length str + 31) / 32) 2 in
+  let cells = max ((Bytes.length str + 15) / 16) 2 in
   let res = Array.make cells (u256 0) in
-  let str_e = str ^ zeros in
+  let str_e = Bytes.cat str zeros in
   for i = 0 to cells - 1 do
-    res.(i) <- get_bytes32 str_e (i*32)
+    res.(i) <- Bytes.to_string (get_bytes16 str_e (i*16))
   done;
   res
 
@@ -450,7 +463,7 @@ let location_proof2 arr loc1 loc2 =
 let location_proof_data arr loc1 loc2 =
   (* first make the first level proof *)
   let proof1 = map_location_proof bytes_to_root arr loc1 in
-  let proof2 = location_proof (bytes_to_array arr.(loc1)) (loc2/32) in
+  let proof2 = location_proof (bytes_to_array arr.(loc1)) (loc2/16) in
   (proof1, proof2)
 
 (*
@@ -520,7 +533,7 @@ let hash_io vm =
 
 let string_from_bytes bs =
   let rec aux n = 
-    if String.length bs = n || Char.code bs.[n] = 0 then "" else String.make 1 bs.[n] ^ aux (n+1) in
+    if Bytes.length bs = n || Char.code (Bytes.get bs n) = 0 then "" else String.make 1 (Bytes.get bs n) ^ aux (n+1) in
   aux 0
 
 let code_hash arr = get_hash (Array.map (fun v -> microp_word (get_code v)) arr)
@@ -662,11 +675,13 @@ let test2 () =
 let _ = test2()
 *)
 
+(*
 let test n =
   let w = Bytes.create 32 in
   let arr = Array.make n w in
   let lst = make_levels_aux arr in
   prerr_endline (string_of_int (List.length lst))
+*)
 
 let w256_to_int w =
   let res = ref 0 in

interpreter/merkle/merkle.ml

@@ -6,6 +6,9 @@ open Source
 open Types
 open Values
 
+(* call name to custom judge number *)
+let custom_calls = Hashtbl.create 7
+
 let trace = Byteutil.trace
 
 (* perhaps we need to link the modules first *)
@@ -70,6 +73,7 @@ type inst =
  | SETTABLE of int
  | SETGLOBALS of int
  | SETMEMORY of int
+ | CUSTOM of int
 
 type control = {
   target : int;
@@ -483,6 +487,7 @@ let compile_test m func vs init inst =
      if mname = "env" && fname = "_debugInt" then [STUB (mname ^ " . " ^ fname); RETURN] else
      if mname = "env" && fname = "_getSystem" then [LOADGLOBAL (find_global_index (elem m) inst (Utf8.decode "_system_ptr")); RETURN] else
      if mname = "env" && fname = "_setSystem" then [STOREGLOBAL (find_global_index (elem m) inst (Utf8.decode "_system_ptr")); RETURN] else
+     if mname = "env" && Hashtbl.mem custom_calls fname then [CUSTOM (Hashtbl.find custom_calls fname); RETURN] else
      generic_stub m inst mname fname ) f_imports in
   let module_codes = List.map (fun f ->
      if f = func then trace "*************** CURRENT ";

interpreter/merkle/mproof.ml

@@ -25,6 +25,7 @@ type location_proof =
  | SimpleProof
  | LocationProof of (int * w256 list)
  | LocationProof2 of (int * int * (w256 list * w256 list)) (* loc1, loc2, proof1, proof2 *)
+ | CustomProof of (int * w256 * (int * w256 list))
 
 (*
 type pointer =
@@ -74,6 +75,7 @@ let write_position vm regs = function
  | InputCreateOut -> value_to_int regs.reg1
  | CallTableOut -> value_to_int regs.ireg
  | CallTypeOut -> value_to_int regs.ireg
+ | CustomFileWrite -> value_to_int regs.reg1
  | _ -> 0
 
 let loc_proof loc f arr = (loc, map_location_proof f arr loc)
@@ -107,7 +109,7 @@ let get_read_location m loc =
  | InputDataIn ->
    LocationProof2 (loc_proof_data (value_to_int m.m_regs.reg2) (value_to_int m.m_regs.reg1) vm.input.file_data)
 
-let find_file vm name =
+let find_file vm (name:string) =
   let res = ref SimpleProof in
   for i = 0 to Array.length vm.input.file_data - 1 do
     if string_from_bytes vm.input.file_name.(i) = name then res := LocationProof (loc_proof i bytes_to_root vm.input.file_data)
@@ -117,7 +119,7 @@ let find_file vm name =
 let find_files vm =
   let res = ref [] in
   for i = 0 to Array.length vm.input.file_data - 1 do
-    if String.length vm.input.file_name.(i) > 0 && vm.input.file_name.(i).[0] <> '\000' then begin
+    if Bytes.length vm.input.file_name.(i) > 0 && (Bytes.get vm.input.file_name.(i) 0) <> '\000' then begin
       res := (map_location_proof bytes_to_root vm.input.file_data i, map_location_proof string_to_root vm.input.file_name i, i, Mbinary.string_from_bytes vm.input.file_name.(i) ^ ".out") :: !res
     end
   done;
@@ -150,6 +152,9 @@ let get_write_location m loc =
    LocationProof2 (loc_proof2 (value_to_int m.m_regs.reg1) (value_to_int m.m_regs.reg2) vm.input.file_name)
  | InputDataOut ->
    LocationProof2 (loc_proof_data (value_to_int m.m_regs.reg1) (value_to_int m.m_regs.reg2) vm.input.file_data)
+ | CustomFileWrite ->
+   let dta, sz = process_custom vm (value_to_int m.m_regs.reg1) (value_to_int m.m_regs.ireg) in
+   CustomProof (sz, string_to_root dta, loc_proof pos string_to_root vm.input.file_data)
 
 let make_register_proof1 m =
   (machine_to_bin m, vm_to_bin m.m_vm, get_read_location m m.m_microp.read_reg1)
@@ -259,6 +264,8 @@ let micro_step_proofs_with_error vm =
 
 (* Doing checks *)
 
+(* Custom checking is not implemented *)
+
 let check_fetch state1 state2 (vm_bin, op, proof) =
   let microp = get_leaf vm_bin.bin_pc proof in
   trace ("OP: " ^ to_hex (microp_word op));
@@ -284,12 +291,10 @@ let check_init_registers state1 state2 m =
   state2 = hash_machine_bin {m with bin_regs=regs}
 
 let value_from_proof = function
- | SimpleProof ->
-    raise EmptyArray
- | LocationProof (loc, lst) ->
-    get_leaf loc lst
- | LocationProof2 (_, loc2, (_, lst2)) ->
-    get_leaf loc2 lst2
+ | SimpleProof -> raise EmptyArray
+ | LocationProof (loc, lst) -> get_leaf loc lst
+ | CustomProof (_, _, (loc, lst)) -> get_leaf loc lst
+ | LocationProof2 (_, loc2, (_, lst2)) -> get_leaf loc2 lst2
 
 let read_from_proof regs vm proof = function
  | NoIn -> get_value (i 0)
@@ -301,7 +306,7 @@ let read_from_proof regs vm proof = function
    ( match proof with
    | LocationProof2 (_, loc2, (_, lst2)) ->
      let leaf = get_leaf (loc2/32) lst2 in
-     let byte = Bytes.get leaf (loc2 mod 32) in
+     let byte = String.get leaf (loc2 mod 32) in
      get_value (i (Char.code byte))
    | _ -> raise EmptyArray )
  | _ -> value_from_proof proof
@@ -392,7 +397,7 @@ let check_read_proof regs vm proof = function
        value_to_int regs.reg2 = loc1 &&
        value_to_int regs.reg1 = loc2 &&
        vm.bin_input_data = get_root loc1 lst1 &&
-       get_leaf loc1 lst1 = get_root (loc2/32) lst2
+       get_leaf loc1 lst1 = get_root (loc2/16) lst2
     | _ -> false )
  | a ->
     ( match proof with
@@ -417,7 +422,7 @@ let check_write_proof regs vm proof = function
        value_to_int regs.reg2 = loc1 &&
        value_to_int regs.reg1 = loc2 &&
        vm.bin_input_data = get_root loc1 lst1 &&
-       get_leaf loc1 lst1 = get_root (loc2/32) lst2
+       get_leaf loc1 lst1 = get_root (loc2/16) lst2
     | _ -> false )
  | a ->
     ( match proof with
@@ -477,7 +482,7 @@ let check_update_call_ptr state1 state2 (m,vm) =
   m.bin_vm = hash_vm_bin vm &&
   state2 = hash_machine_bin m2
 
-let check_update_memsize (state1:bytes) (state2:bytes) (m,vm) =
+let check_update_memsize (state1:w256) (state2:w256) (m,vm) =
   let vm2 = {vm with bin_memsize=(if m.bin_microp.mem_ch then value_to_int m.bin_regs.reg1 else 0) + vm.bin_memsize} in
   state1 = hash_machine_bin m &&
   m.bin_vm = hash_vm_bin vm &&
@@ -524,6 +529,8 @@ let list_to_string lst = "[" ^ String.concat ", " (List.map to_hex lst) ^ "]"
 let loc_to_string = function
  | SimpleProof -> "{ \"location\": 0, \"list\": [] }"
  | LocationProof (loc,lst) -> "{ \"location\": " ^ string_of_int loc ^ ", \"list\": " ^ list_to_string lst ^ " }"
+ | CustomProof (result_size, result_state, (loc,lst)) ->
+    "{ \"location\": " ^ string_of_int loc ^ ", \"list\": " ^ list_to_string lst ^ ", \"result_size\": " ^ string_of_int result_size ^ ", \"result_state\": " ^ to_hex result_state ^ " }"
  | LocationProof2 (loc1, loc2, (lst1, lst2)) ->
     "{ \"location1\": " ^ string_of_int loc1 ^ ", \"list1\": " ^ list_to_string lst1 ^ ", " ^
     " \"location2\": " ^ string_of_int loc2 ^ ", \"list2\": " ^ list_to_string lst2 ^ " }"
@@ -537,9 +544,9 @@ let build_root v = make_zero (Int64.to_int (Decode.word v))
 
 let modify_data i nv str =
   let nv = Int64.to_int (Decode.word nv) in
-  let res = Bytes.copy str in
+  let res = Bytes.of_string str in
   Bytes.set res i (Char.chr nv);
-  res
+  Bytes.to_string res
 
 let write_register_bin proof vm regs v = function
  | NoOut -> vm
@@ -559,6 +566,8 @@ let write_register_bin proof vm regs v = function
  | CallTableOut -> {vm with bin_calltable=merkle_change v proof}
  | CallTypeOut -> {vm with bin_calltable_types=merkle_change v proof}
  | InputCreateOut -> {vm with bin_input_data=merkle_change (make_root (Int64.to_int (Decode.word v)) (u256 0)) proof}
+ | CustomFileWrite ->
+   {vm with bin_input_data=merkle_change v proof}
  | MemoryOut1 (_,sz) -> {vm with bin_memory=merkle_change_memory1 regs v sz proof}
  | MemoryOut2 (_,sz) -> {vm with bin_memory=merkle_change_memory2 regs v sz proof}
  | InputNameOut ->
@@ -579,7 +588,7 @@ let write_register_bin proof vm regs v = function
                value_to_int regs.reg2 = loc2 &&
                vm.bin_input_data = get_root loc1 lst1 &&
                get_leaf loc1 lst1 = get_root loc2 lst2);
-       let lst2 = do_set_leaf (loc2/32) (modify_data (loc2 mod 32) v) lst2 in
+       let lst2 = do_set_leaf (loc2/16) (modify_data (loc2 mod 16) v) lst2 in
        let lst1 = set_leaf loc1 (get_root (loc2/32) lst2) lst1 in
        {vm with bin_input_data=get_root loc1 lst1}
    | _ -> assert false )