Source file contract_services.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
open Alpha_context
let custom_root =
(RPC_path.(open_root / "context" / "contracts")
: RPC_context.t RPC_path.context)
let big_map_root =
(RPC_path.(open_root / "context" / "big_maps")
: RPC_context.t RPC_path.context)
type info = {
balance : Tez.t;
delegate : public_key_hash option;
counter : Manager_counter.t option;
script : Script.t option;
}
let info_encoding =
let open Data_encoding in
conv
(fun {balance; delegate; script; counter} ->
(balance, delegate, script, counter))
(fun (balance, delegate, script, counter) ->
{balance; delegate; script; counter})
@@ obj4
(req "balance" Tez.encoding)
(opt "delegate" Signature.Public_key_hash.encoding)
(opt "script" Script.encoding)
(opt "counter" Manager_counter.encoding_for_RPCs)
let legacy = Script_ir_translator_config.make ~legacy:true ()
module S = struct
open Data_encoding
let balance =
RPC_service.get_service
~description:
"Access the spendable balance of a contract, excluding frozen bonds."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "balance")
let frozen_bonds =
RPC_service.get_service
~description:"Access the frozen bonds of a contract."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "frozen_bonds")
let balance_and_frozen_bonds =
RPC_service.get_service
~description:
"Access the sum of the spendable balance and frozen bonds of a \
contract. This sum is part of the contract's stake, and it is exactly \
the contract's stake if the contract is not a delegate."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "balance_and_frozen_bonds")
let manager_key =
RPC_service.get_service
~description:"Access the manager of an implicit contract."
~query:RPC_query.empty
~output:(option Signature.Public_key.encoding)
RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")
let delegate =
RPC_service.get_service
~description:"Access the delegate of a contract, if any."
~query:RPC_query.empty
~output:Signature.Public_key_hash.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "delegate")
let counter =
RPC_service.get_service
~description:"Access the counter of a contract, if any."
~query:RPC_query.empty
~output:Manager_counter.encoding_for_RPCs
RPC_path.(custom_root /: Contract.rpc_arg / "counter")
let script =
RPC_service.get_service
~description:"Access the code and data of the contract."
~query:RPC_query.empty
~output:Script.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "script")
let storage =
RPC_service.get_service
~description:"Access the data of the contract."
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(custom_root /: Contract.rpc_arg / "storage")
type normalize_types_query = {normalize_types : bool}
let normalize_types_query : normalize_types_query RPC_query.t =
let open RPC_query in
query (fun normalize_types -> {normalize_types})
|+ flag
~descr:
"Whether types should be normalized (annotations removed, combs \
flattened) or kept as they appeared in the original script."
"normalize_types"
(fun t -> t.normalize_types)
|> seal
let entrypoint_type =
RPC_service.get_service
~description:"Return the type of the given entrypoint of the contract"
~query:normalize_types_query
~output:Script.expr_encoding
RPC_path.(
custom_root /: Contract.rpc_arg / "entrypoints" /: Entrypoint.rpc_arg)
let list_entrypoints =
RPC_service.get_service
~description:"Return the list of entrypoints of the contract"
~query:normalize_types_query
~output:
(obj2
(dft
"unreachable"
(Data_encoding.list
(obj1
(req
"path"
(Data_encoding.list
Michelson_v1_primitives.prim_encoding))))
[])
(req "entrypoints" (assoc Script.expr_encoding)))
RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints")
let contract_big_map_get_opt =
RPC_service.post_service
~description:
"Access the value associated with a key in a big map of the contract \
(deprecated)."
~query:RPC_query.empty
~input:
(obj2
(req "key" Script.expr_encoding)
(req "type" Script.expr_encoding))
~output:(option Script.expr_encoding)
RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")
let big_map_get =
RPC_service.get_service
~description:"Access the value associated with a key in a big map."
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(big_map_root /: Big_map.Id.rpc_arg /: Script_expr_hash.rpc_arg)
type big_map_get_all_query = {offset : int option; length : int option}
let rpc_arg_uint : int RPC_arg.t =
let int_of_string s =
int_of_string_opt s
|> Option.to_result
~none:(Format.sprintf "Cannot parse integer value %s" s)
>>? fun i ->
if Compare.Int.(i < 0) then
Error (Format.sprintf "Negative integer: %d" i)
else Ok i
in
RPC_arg.make
~name:"uint"
~descr:"A non-negative integer (greater than or equal to 0)."
~destruct:int_of_string
~construct:string_of_int
()
let big_map_get_all_query : big_map_get_all_query RPC_query.t =
let open RPC_query in
query (fun offset length -> {offset; length})
|+ opt_field
~descr:
"Skip the first [offset] values. Useful in combination with \
[length] for pagination."
"offset"
rpc_arg_uint
(fun t -> t.offset)
|+ opt_field
~descr:
"Only retrieve [length] values. Useful in combination with [offset] \
for pagination."
"length"
rpc_arg_uint
(fun t -> t.length)
|> seal
let big_map_get_all =
RPC_service.get_service
~description:
"Get the (optionally paginated) list of values in a big map. Order of \
values is unspecified, but is guaranteed to be consistent."
~query:big_map_get_all_query
~output:(list Script.expr_encoding)
RPC_path.(big_map_root /: Big_map.Id.rpc_arg)
let info =
RPC_service.get_service
~description:"Access the complete status of a contract."
~query:normalize_types_query
~output:info_encoding
RPC_path.(custom_root /: Contract.rpc_arg)
let list =
RPC_service.get_service
~description:
"All existing contracts (excluding empty implicit contracts)."
~query:RPC_query.empty
~output:(list Contract.encoding)
custom_root
module Sapling = struct
let single_sapling_get_id ctxt contract_id =
Contract.get_script ctxt contract_id >>=? fun (ctxt, script) ->
match script with
| None -> return (None, ctxt)
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
Script_ir_translator.parse_script
ctxt
~elab_conf:legacy
~allow_forged_in_storage:true
script
>|= fun tzresult ->
tzresult >>? fun (Ex_script (Script script), ctxt) ->
Script_ir_translator.get_single_sapling_state
ctxt
script.storage_type
script.storage
let make_service
Sapling_services.S.Args.{name; description; query; output; f} =
let name = "single_sapling_" ^ name in
let path = RPC_path.(custom_root /: Contract.rpc_arg / name) in
let service = RPC_service.get_service ~description ~query ~output path in
( service,
fun ctxt contract_id q () ->
match (contract_id : Contract.t) with
| Implicit _ -> return_none
| Originated contract_id ->
single_sapling_get_id ctxt contract_id
>>=? fun (sapling_id, ctxt) ->
Option.map_es (fun sapling_id -> f ctxt sapling_id q) sapling_id
)
let get_diff = make_service Sapling_services.S.Args.get_diff
let register () =
let reg chunked (service, f) =
Services_registration.opt_register1 ~chunked service f
in
reg false get_diff
let mk_call1 (service, _f) ctxt block id q =
RPC_context.make_call1 service ctxt block id q ()
end
end
let register () =
let open Services_registration in
register0 ~chunked:true S.list (fun ctxt () () -> Contract.list ctxt >|= ok) ;
let register_field_gen ~filter_contract ~wrap_result ~chunked s f =
opt_register1 ~chunked s (fun ctxt contract () () ->
filter_contract contract @@ fun filtered_contract ->
Contract.exists ctxt contract >>= function
| true -> f ctxt filtered_contract |> wrap_result
| false -> return_none)
in
let register_field_with_query_gen ~filter_contract ~wrap_result ~chunked s f =
opt_register1 ~chunked s (fun ctxt contract query () ->
filter_contract contract @@ fun filtered_contract ->
Contract.exists ctxt contract >>= function
| true -> f ctxt filtered_contract query |> wrap_result
| false -> return_none)
in
let register_field s =
register_field_gen
~filter_contract:(fun c k -> k c)
~wrap_result:(fun res -> res >|=? Option.some)
s
in
let register_field_with_query s =
register_field_with_query_gen
~filter_contract:(fun c k -> k c)
~wrap_result:(fun res -> res >|=? Option.some)
s
in
let register_opt_field s =
register_field_gen
~filter_contract:(fun c k -> k c)
~wrap_result:(fun res -> res)
s
in
let register_originated_opt_field s =
register_field_gen
~filter_contract:(fun c k ->
match (c : Contract.t) with
| Implicit _ -> return_none
| Originated c -> k c)
~wrap_result:(fun res -> res)
s
in
let do_big_map_get ctxt id key =
let open Script_ir_translator in
let ctxt = Gas.set_unlimited ctxt in
Big_map.exists ctxt id >>=? fun (ctxt, types) ->
match types with
| None -> return_none
| Some (_, value_type) -> (
parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type)
>>?= fun (Ex_ty value_type, ctxt) ->
Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) ->
match value with
| None -> return_none
| Some value ->
parse_data
ctxt
~elab_conf:legacy
~allow_forged:true
value_type
(Micheline.root value)
>>=? fun (value, ctxt) ->
unparse_data ctxt Readable value_type value
>|=? fun (value, _ctxt) -> Some value)
in
let do_big_map_get_all ?offset ?length ctxt id =
let open Script_ir_translator in
let ctxt = Gas.set_unlimited ctxt in
Big_map.exists ctxt id >>=? fun (ctxt, types) ->
match types with
| None -> raise Not_found
| Some (_, value_type) ->
parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type)
>>?= fun (Ex_ty value_type, ctxt) ->
Big_map.list_key_values ?offset ?length ctxt id
>>=? fun (ctxt, key_values) ->
List.fold_left_s
(fun acc (_key_hash, value) ->
acc >>?= fun (ctxt, rev_values) ->
parse_data
ctxt
~elab_conf:legacy
~allow_forged:true
value_type
(Micheline.root value)
>>=? fun (value, ctxt) ->
unparse_data ctxt Readable value_type value
>|=? fun (value, ctxt) -> (ctxt, value :: rev_values))
(Ok (ctxt, []))
key_values
>|=? fun (_ctxt, rev_values) -> List.rev rev_values
in
register_field ~chunked:false S.balance Contract.get_balance ;
register_field ~chunked:false S.frozen_bonds Contract.get_frozen_bonds ;
register_field
~chunked:false
S.balance_and_frozen_bonds
Contract.get_balance_and_frozen_bonds ;
opt_register1 ~chunked:false S.manager_key (fun ctxt contract () () ->
match contract with
| Originated _ -> return_none
| Implicit mgr -> (
Contract.is_manager_key_revealed ctxt mgr >>=? function
| false -> return_some None
| true ->
Contract.get_manager_key ctxt mgr >|=? fun key -> Some (Some key))) ;
register_opt_field ~chunked:false S.delegate Contract.Delegate.find ;
opt_register1 ~chunked:false S.counter (fun ctxt contract () () ->
match contract with
| Originated _ -> return_none
| Implicit mgr ->
Contract.get_counter ctxt mgr >|=? fun counter -> Some counter) ;
register_originated_opt_field ~chunked:true S.script (fun c v ->
Contract.get_script c v >|=? fun (_, v) -> v) ;
register_originated_opt_field ~chunked:true S.storage (fun ctxt contract ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
match script with
| None -> return_none
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script
ctxt
~elab_conf:legacy
~allow_forged_in_storage:true
script
>>=? fun (Ex_script (Script {storage; storage_type; _}), ctxt) ->
unparse_data ctxt Readable storage_type storage
>|=? fun (storage, _ctxt) -> Some storage) ;
opt_register2
~chunked:true
S.entrypoint_type
(fun ctxt v entrypoint {normalize_types} () ->
match (v : Contract.t) with
| Implicit _ -> return_none
| Originated v -> (
Contract.get_script_code ctxt v >>=? fun (_, expr) ->
match expr with
| None -> return_none
| Some expr ->
let ctxt = Gas.set_unlimited ctxt in
let legacy = true in
let open Script_ir_translator in
Script.force_decode_in_context
~consume_deserialization_gas:When_needed
ctxt
expr
>>?= fun (expr, _) ->
parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) ->
Lwt.return
( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type
>>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints},
_ ) ->
Gas_monad.run ctxt
@@ Script_ir_translator.find_entrypoint
~error_details:(Informative ())
arg_type
entrypoints
entrypoint
>>? fun (r, ctxt) ->
r |> function
| Ok (Ex_ty_cstr {ty; original_type_expr; _}) ->
if normalize_types then
Script_ir_unparser.unparse_ty ~loc:() ctxt ty
>|? fun (ty_node, _ctxt) ->
Some (Micheline.strip_locations ty_node)
else
ok (Some (Micheline.strip_locations original_type_expr))
| Error _ -> Result.return_none ))) ;
opt_register1
~chunked:true
S.list_entrypoints
(fun ctxt v {normalize_types} () ->
match (v : Contract.t) with
| Implicit _ -> return_none
| Originated v -> (
Contract.get_script_code ctxt v >>=? fun (_, expr) ->
match expr with
| None -> return_none
| Some expr ->
let ctxt = Gas.set_unlimited ctxt in
let legacy = true in
let open Script_ir_translator in
Script.force_decode_in_context
~consume_deserialization_gas:When_needed
ctxt
expr
>>?= fun (expr, _) ->
parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) ->
Lwt.return
( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type
>>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints},
_ ) ->
let unreachable_entrypoint, map =
Script_ir_translator.list_entrypoints_uncarbonated
arg_type
entrypoints
in
Entrypoint.Map.fold_e
(fun entry
(Script_typed_ir.Ex_ty ty, original_type_expr)
(acc, ctxt) ->
(if normalize_types then
Script_ir_unparser.unparse_ty ~loc:() ctxt ty
>|? fun (ty_node, ctxt) ->
(Micheline.strip_locations ty_node, ctxt)
else
ok (Micheline.strip_locations original_type_expr, ctxt))
>|? fun (ty_expr, ctxt) ->
((Entrypoint.to_string entry, ty_expr) :: acc, ctxt))
map
([], ctxt)
>|? fun (entrypoint_types, _ctxt) ->
Some (unreachable_entrypoint, entrypoint_types) ))) ;
opt_register1
~chunked:true
S.contract_big_map_get_opt
(fun ctxt contract () (key, key_type) ->
match (contract : Contract.t) with
| Implicit _ -> return_none
| Originated contract -> (
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
let key_type_node = Micheline.root key_type in
Script_ir_translator.parse_comparable_ty ctxt key_type_node
>>?= fun (Ex_comparable_ty key_type, ctxt) ->
Script_ir_translator.parse_comparable_data
ctxt
key_type
(Micheline.root key)
>>=? fun (key, ctxt) ->
Script_ir_translator.hash_comparable_data ctxt key_type key
>>=? fun (key, ctxt) ->
match script with
| None -> return_none
| Some script -> (
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script
ctxt
~elab_conf:legacy
~allow_forged_in_storage:true
script
>>=? fun (Ex_script (Script script), ctxt) ->
Script_ir_translator.collect_lazy_storage
ctxt
script.storage_type
script.storage
>>?= fun (ids, _ctxt) ->
match Script_ir_translator.list_of_big_map_ids ids with
| [] | _ :: _ :: _ -> return_some None
| [id] -> do_big_map_get ctxt id key >|=? Option.some))) ;
opt_register2 ~chunked:true S.big_map_get (fun ctxt id key () () ->
do_big_map_get ctxt id key) ;
register1 ~chunked:true S.big_map_get_all (fun ctxt id {offset; length} () ->
do_big_map_get_all ?offset ?length ctxt id) ;
register_field_with_query
~chunked:false
S.info
(fun ctxt contract {normalize_types} ->
Contract.get_balance ctxt contract >>=? fun balance ->
Contract.Delegate.find ctxt contract >>=? fun delegate ->
match contract with
| Implicit manager ->
Contract.get_counter ctxt manager >|=? fun counter ->
{balance; delegate; script = None; counter = Some counter}
| Originated contract -> (
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
match script with
| None -> return {balance; delegate; script = None; counter = None}
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
Script_ir_translator.parse_and_unparse_script_unaccounted
ctxt
~legacy:true
~allow_forged_in_storage:true
Readable
~normalize_types
script
>|=? fun (script, _ctxt) ->
{balance; delegate; script = Some script; counter = None})) ;
S.Sapling.register ()
let list ctxt block = RPC_context.make_call0 S.list ctxt block () ()
let info ctxt block contract ~normalize_types =
RPC_context.make_call1 S.info ctxt block contract {normalize_types} ()
let balance ctxt block contract =
RPC_context.make_call1 S.balance ctxt block contract () ()
let frozen_bonds ctxt block contract =
RPC_context.make_call1 S.frozen_bonds ctxt block contract () ()
let balance_and_frozen_bonds ctxt block contract =
RPC_context.make_call1 S.balance_and_frozen_bonds ctxt block contract () ()
let manager_key ctxt block mgr =
RPC_context.make_call1 S.manager_key ctxt block (Contract.Implicit mgr) () ()
let delegate ctxt block contract =
RPC_context.make_call1 S.delegate ctxt block contract () ()
let delegate_opt ctxt block contract =
RPC_context.make_opt_call1 S.delegate ctxt block contract () ()
let counter ctxt block mgr =
RPC_context.make_call1 S.counter ctxt block (Contract.Implicit mgr) () ()
let script ctxt block contract =
let contract = Contract.Originated contract in
RPC_context.make_call1 S.script ctxt block contract () ()
let script_opt ctxt block contract =
let contract = Contract.Originated contract in
RPC_context.make_opt_call1 S.script ctxt block contract () ()
let storage ctxt block contract =
let contract = Contract.Originated contract in
RPC_context.make_call1 S.storage ctxt block contract () ()
let entrypoint_type ctxt block contract entrypoint ~normalize_types =
RPC_context.make_call2
S.entrypoint_type
ctxt
block
(Contract.Originated contract)
entrypoint
{normalize_types}
()
let list_entrypoints ctxt block contract ~normalize_types =
RPC_context.make_call1
S.list_entrypoints
ctxt
block
(Contract.Originated contract)
{normalize_types}
()
let storage_opt ctxt block contract =
let contract = Contract.Originated contract in
RPC_context.make_opt_call1 S.storage ctxt block contract () ()
let big_map_get ctxt block id key =
RPC_context.make_call2 S.big_map_get ctxt block id key () ()
let contract_big_map_get_opt ctxt block contract key =
let contract = Contract.Originated contract in
RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key
let single_sapling_get_diff ctxt block id ?offset_commitment ?offset_nullifier
() =
S.Sapling.(mk_call1 get_diff)
ctxt
block
(Contract.Originated id)
Sapling_services.{offset_commitment; offset_nullifier}