|
| 1 | +open Core_kernel |
| 2 | + |
| 3 | +module IO = struct |
| 4 | + type +'a t = 'a |
| 5 | + |
| 6 | + let bind t f = f t |
| 7 | + |
| 8 | + let return t = t |
| 9 | + |
| 10 | + module Stream = struct |
| 11 | + type 'a t = 'a Seq.t |
| 12 | + |
| 13 | + let map t f = Seq.map f t |
| 14 | + |
| 15 | + let iter t f = Seq.iter f t |
| 16 | + |
| 17 | + let close _t = () |
| 18 | + end |
| 19 | +end |
| 20 | + |
| 21 | +module Field_error = struct |
| 22 | + type t = string |
| 23 | + |
| 24 | + let message_of_field_error t = t |
| 25 | + |
| 26 | + let extensions_of_field_error _t = None |
| 27 | +end |
| 28 | + |
| 29 | +module Schema = Graphql_schema.Make (IO) (Field_error) |
| 30 | +module Field = Snark_params.Tick.Field |
| 31 | +module Public_key = Signature_lib.Public_key.Compressed |
| 32 | +module Derivers = Fields_derivers_zkapps.Make (Schema) |
| 33 | +include Derivers |
| 34 | + |
| 35 | +module Or_ignore_test = struct |
| 36 | + type 'a t = Check of 'a | Ignore [@@deriving compare, sexp, equal] |
| 37 | + |
| 38 | + let of_option = function None -> Ignore | Some x -> Check x |
| 39 | + |
| 40 | + let to_option = function Ignore -> None | Check x -> Some x |
| 41 | + |
| 42 | + let to_yojson a x = [%to_yojson: 'a option] a (to_option x) |
| 43 | + |
| 44 | + let of_yojson a x = Result.map ~f:of_option ([%of_yojson: 'a option] a x) |
| 45 | + |
| 46 | + let derived inner init = |
| 47 | + Derivers.iso ~map:of_option ~contramap:to_option |
| 48 | + (( Derivers.option ~js_type:Fields_derivers_zkapps.Js_layout.Flagged_option |
| 49 | + @@ inner @@ Derivers.o () ) |
| 50 | + (Derivers.o ()) ) |
| 51 | + init |
| 52 | +end |
| 53 | + |
| 54 | +module V = struct |
| 55 | + type t = |
| 56 | + { foo : int |
| 57 | + ; foo1 : Unsigned_extended.UInt64.t |
| 58 | + ; bar : Unsigned_extended.UInt64.t Or_ignore_test.t |
| 59 | + ; baz : Unsigned_extended.UInt32.t list |
| 60 | + } |
| 61 | + [@@deriving annot, compare, sexp, equal, fields, yojson] |
| 62 | + |
| 63 | + let v = |
| 64 | + { foo = 1 |
| 65 | + ; foo1 = Unsigned.UInt64.of_int 10 |
| 66 | + ; bar = Or_ignore_test.Check (Unsigned.UInt64.of_int 10) |
| 67 | + ; baz = Unsigned.UInt32.[ of_int 11; of_int 12 ] |
| 68 | + } |
| 69 | + |
| 70 | + let ( !. ) = ( !. ) ~t_fields_annots |
| 71 | + |
| 72 | + let derivers obj = |
| 73 | + Fields.make_creator obj ~foo:!.int ~foo1:!.uint64 |
| 74 | + ~bar:!.(Or_ignore_test.derived uint64) |
| 75 | + ~baz:!.(list @@ uint32 @@ o ()) |
| 76 | + |> finish "V" ~t_toplevel_annots |
| 77 | +end |
| 78 | + |
| 79 | +module V2 = struct |
| 80 | + type t = { field : Field.t; nothing : unit [@skip] } |
| 81 | + [@@deriving annot, compare, sexp, equal, fields] |
| 82 | + |
| 83 | + let v = { field = Field.of_int 10; nothing = () } |
| 84 | + |
| 85 | + let derivers obj = |
| 86 | + let open Derivers in |
| 87 | + let ( !. ) ?skip_data = ( !. ) ?skip_data ~t_fields_annots in |
| 88 | + Fields.make_creator obj ~field:!.field ~nothing:(( !. ) ~skip_data:() skip) |
| 89 | + |> finish "V2" ~t_toplevel_annots |
| 90 | +end |
| 91 | + |
| 92 | +module V3 = struct |
| 93 | + type t = { public_key : Public_key.t } |
| 94 | + [@@deriving annot, compare, sexp, equal, fields] |
| 95 | + |
| 96 | + let v = |
| 97 | + { public_key = |
| 98 | + Public_key.of_base58_check_exn |
| 99 | + "B62qoTqMG41DFgkyQmY2Pos1x671Gfzs9k8NKqUdSg7wQasEV6qnXQP" |
| 100 | + } |
| 101 | + |
| 102 | + let derivers obj = |
| 103 | + let open Derivers in |
| 104 | + let ( !. ) = ( !. ) ~t_fields_annots in |
| 105 | + Fields.make_creator obj ~public_key:!.public_key |
| 106 | + |> finish "V3" ~t_toplevel_annots |
| 107 | +end |
| 108 | + |
| 109 | +(* Test functions *) |
| 110 | +let test_verification_key_with_hash () = |
| 111 | + let open Pickles.Side_loaded.Verification_key in |
| 112 | + (* we do this because the dummy doesn't have a wrap_vk on it *) |
| 113 | + let data = dummy |> to_base58_check |> of_base58_check_exn in |
| 114 | + let v = { With_hash.data; hash = Field.one } in |
| 115 | + let o = |
| 116 | + Fields_derivers_zkapps.verification_key_with_hash |
| 117 | + @@ Fields_derivers_zkapps.o () |
| 118 | + in |
| 119 | + let roundtrip = |
| 120 | + Fields_derivers_zkapps.of_json o (Fields_derivers_zkapps.to_json o v) |
| 121 | + in |
| 122 | + Alcotest.(check bool) |
| 123 | + "verification key with hash roundtrip" true |
| 124 | + (With_hash.equal equal Field.equal v roundtrip) |
| 125 | + |
| 126 | +let test_full_roundtrips () = |
| 127 | + let v1 = V.derivers @@ Derivers.o () in |
| 128 | + Derivers.Test.Loop.run v1 V.v ; |
| 129 | + Alcotest.(check pass) "full roundtrips" () () |
| 130 | + |
| 131 | +let test_v2_to_json () = |
| 132 | + let v2 = V2.derivers @@ Derivers.o () in |
| 133 | + let expected = {|{"field":"10"}|} in |
| 134 | + let actual = Yojson.Safe.to_string (Derivers.to_json v2 V2.v) in |
| 135 | + Alcotest.(check string) "to_json'" expected actual |
| 136 | + |
| 137 | +let test_v2_roundtrip_json () = |
| 138 | + let v2 = V2.derivers @@ Derivers.o () in |
| 139 | + let roundtrip = Derivers.of_json v2 (Derivers.to_json v2 V2.v) in |
| 140 | + Alcotest.(check bool) "roundtrip json" true (V2.equal roundtrip V2.v) |
| 141 | + |
| 142 | +let test_v3_to_json () = |
| 143 | + let v3 = V3.derivers @@ Derivers.o () in |
| 144 | + let expected = |
| 145 | + {|{"publicKey":"B62qoTqMG41DFgkyQmY2Pos1x671Gfzs9k8NKqUdSg7wQasEV6qnXQP"}|} |
| 146 | + in |
| 147 | + let actual = Yojson.Safe.to_string (Derivers.to_json v3 V3.v) in |
| 148 | + Alcotest.(check string) "v3 to_json" expected actual |
| 149 | + |
| 150 | +let test_v3_roundtrip_json () = |
| 151 | + let v3 = V3.derivers @@ Derivers.o () in |
| 152 | + let roundtrip = Derivers.of_json v3 (Derivers.to_json v3 V3.v) in |
| 153 | + Alcotest.(check bool) "v3 roundtrip json" true (V3.equal roundtrip V3.v) |
| 154 | + |
| 155 | +let () = |
| 156 | + Alcotest.run "Fields_derivers_zkapps" |
| 157 | + [ ( "verification_key_with_hash" |
| 158 | + , [ Alcotest.test_case "roundtrip json" `Quick |
| 159 | + test_verification_key_with_hash |
| 160 | + ] ) |
| 161 | + ; ( "test_module" |
| 162 | + , [ Alcotest.test_case "full roundtrips" `Quick test_full_roundtrips |
| 163 | + ; Alcotest.test_case "v2 to_json" `Quick test_v2_to_json |
| 164 | + ; Alcotest.test_case "v2 roundtrip json" `Quick test_v2_roundtrip_json |
| 165 | + ; Alcotest.test_case "v3 to_json" `Quick test_v3_to_json |
| 166 | + ; Alcotest.test_case "v3 roundtrip json" `Quick test_v3_roundtrip_json |
| 167 | + ] ) |
| 168 | + ] |
0 commit comments