Source file tx_rollup_l2_apply.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
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
open Alpha_context
open Tx_rollup_l2_context_sig
open Tx_rollup_l2_batch
type error +=
| Counter_mismatch of {
account : Tx_rollup_l2_address.t;
expected : int64;
provided : int64;
}
| Incorrect_aggregated_signature
| Unallocated_metadata of int32
| Multiple_operations_for_signer of Bls.Public_key.t
| Invalid_transaction_encoding
| Invalid_batch_encoding
| Unexpectedly_indexed_ticket
| Missing_ticket of Ticket_hash.t
| Unknown_address of Tx_rollup_l2_address.t
| Invalid_self_transfer
| Invalid_zero_transfer
| Maximum_withdraws_per_message_exceeded of {current : int; maximum : int}
let () =
let open Data_encoding in
register_error_kind
`Branch
~id:"tx_rollup_operation_counter_mismatch"
~title:"Operation counter mismatch"
~description:
"A transaction rollup operation has been submitted with an incorrect \
counter"
(obj3
(req "account" Tx_rollup_l2_address.encoding)
(req "expected" int64)
(req "provided" int64))
(function
| Counter_mismatch {account; expected; provided} ->
Some (account, expected, provided)
| _ -> None)
(fun (account, expected, provided) ->
Counter_mismatch {account; expected; provided}) ;
register_error_kind
`Permanent
~id:"tx_rollup_incorrect_aggregated_signature"
~title:"Incorrect aggregated signature"
~description:"The aggregated signature is incorrect"
empty
(function Incorrect_aggregated_signature -> Some () | _ -> None)
(function () -> Incorrect_aggregated_signature) ;
register_error_kind
`Branch
~id:"tx_rollup_unknown_metadata"
~title:"Unknown metadata"
~description:
"A public key index was provided but the account information for this \
index is not present in the context."
(obj1 (req "idx" int32))
(function Unallocated_metadata i -> Some i | _ -> None)
(function i -> Unallocated_metadata i) ;
register_error_kind
`Permanent
~id:"tx_rollup_invalid_transaction"
~title:"Invalid transaction"
~description:
"The signer signed multiple operations in the same transaction. He must \
gather all the contents in a single operation"
(obj1 (req "pk" Bls.Public_key.encoding))
(function Multiple_operations_for_signer idx -> Some idx | _ -> None)
(function idx -> Multiple_operations_for_signer idx) ;
register_error_kind
`Permanent
~id:"tx_rollup_invalid_transaction_encoding"
~title:"Invalid transaction encoding"
~description:"The transaction could not be decoded from bytes"
empty
(function Invalid_transaction_encoding -> Some () | _ -> None)
(function () -> Invalid_transaction_encoding) ;
register_error_kind
`Permanent
~id:"tx_rollup_invalid_batch_encoding"
~title:"Invalid batch encoding"
~description:"The batch could not be decoded from bytes"
empty
(function Invalid_batch_encoding -> Some () | _ -> None)
(function () -> Invalid_batch_encoding) ;
register_error_kind
`Permanent
~id:"tx_rollup_unexpectedly_indexed_ticket"
~title:"Unexpected indexed ticket in deposit or transfer"
~description:
"Tickets in layer2-to-layer1 transfers must be referenced by value."
empty
(function Unexpectedly_indexed_ticket -> Some () | _ -> None)
(function () -> Unexpectedly_indexed_ticket) ;
register_error_kind
`Temporary
~id:"tx_rollup_missing_ticket"
~title:"Attempted to withdraw from a ticket missing in the rollup"
~description:
"A withdrawal must reference a ticket that already exists in the rollup."
(obj1 (req "ticket_hash" Ticket_hash.encoding))
(function Missing_ticket ticket_hash -> Some ticket_hash | _ -> None)
(function ticket_hash -> Missing_ticket ticket_hash) ;
register_error_kind
`Temporary
~id:"tx_rollup_unknown_address"
~title:"Attempted to sign a transfer with an unknown address"
~description:
"The address must exist in the context when signing a transfer with it."
(obj1 (req "address" Tx_rollup_l2_address.encoding))
(function Unknown_address addr -> Some addr | _ -> None)
(function addr -> Unknown_address addr) ;
register_error_kind
`Temporary
~id:"tx_rollup_invalid_self_transfer"
~title:"Attempted to transfer ticket to self"
~description:"The index for the destination is the same as the sender"
empty
(function Invalid_self_transfer -> Some () | _ -> None)
(function () -> Invalid_self_transfer) ;
register_error_kind
`Permanent
~id:"tx_rollup_invalid_zero_transfer"
~title:"Attempted to transfer zero ticket"
~description:"A transfer's amount must be greater than zero."
empty
(function Invalid_zero_transfer -> Some () | _ -> None)
(function () -> Invalid_zero_transfer) ;
register_error_kind
`Permanent
~id:"tx_rollup_maximum_withdraws_per_message_exceeded"
~title:"Maximum tx-rollup withdraws per message exceeded"
~description:
"The maximum number of withdraws allowed per tx-rollup message exceeded"
(obj2 (req "current" int31) (req "limit" int31))
(function
| Maximum_withdraws_per_message_exceeded {current; maximum} ->
Some (current, maximum)
| _ -> None)
(fun (current, maximum) ->
Maximum_withdraws_per_message_exceeded {current; maximum})
type indexes = {
address_indexes :
(Tx_rollup_l2_address.t * Tx_rollup_l2_address.Indexable.index) list;
ticket_indexes : (Ticket_hash.t * Ticket_indexable.index) list;
}
let encoding_indexes : indexes Data_encoding.t =
let open Data_encoding in
conv
(fun {address_indexes; ticket_indexes} -> (address_indexes, ticket_indexes))
(fun (address_indexes, ticket_indexes) -> {address_indexes; ticket_indexes})
@@ obj2
(req
"address_indexes"
(list
(tup2
Tx_rollup_l2_address.encoding
Tx_rollup_l2_address.Indexable.index_encoding)))
(req
"ticket_indexes"
(list (tup2 Ticket_hash.encoding Ticket_indexable.index_encoding)))
module Message_result = struct
type transaction_result =
| Transaction_success
| Transaction_failure of {index : int; reason : error}
type deposit_result = Deposit_success of indexes | Deposit_failure of error
let encoding_transaction_result =
let open Data_encoding in
union
[
(let kind = "transaction_success" in
case
~title:kind
(Tag 0)
(constant kind)
(function Transaction_success -> Some () | _ -> None)
(fun () -> Transaction_success));
(let kind = "transaction_failure" in
case
~title:kind
(Tag 1)
(obj1
(req
kind
(obj2
(req "transaction_index" Data_encoding.int31)
(req "reason" Error_monad.error_encoding))))
(function
| Transaction_failure {index; reason} -> Some (index, reason)
| _ -> None)
(fun (index, reason) -> Transaction_failure {index; reason}));
]
let encoding_deposit_result =
let open Data_encoding in
union
[
(let kind = "deposit_success" in
case
~title:kind
(Tag 0)
(obj1 (req kind encoding_indexes))
(function Deposit_success indexes -> Some indexes | _ -> None)
(fun indexes -> Deposit_success indexes));
(let kind = "deposit_failure" in
case
~title:kind
(Tag 1)
(obj1 (req kind (obj1 (req "reason" Error_monad.error_encoding))))
(function Deposit_failure reason -> Some reason | _ -> None)
(fun reason -> Deposit_failure reason));
]
module Batch_V1 = struct
type t =
| Batch_result of {
results :
((Indexable.index_only, Indexable.unknown) V1.transaction
* transaction_result)
list;
indexes : indexes;
}
let encoding =
let open Data_encoding in
conv
(fun (Batch_result {results; indexes}) -> (results, indexes))
(fun (results, indexes) -> Batch_result {results; indexes})
(obj2
(req "results"
@@ list
(Data_encoding.tup2
(Compact.make
~tag_size:`Uint8
V1.compact_transaction_signer_index)
encoding_transaction_result))
(req "allocated_indexes" encoding_indexes))
end
type message_result =
| Deposit_result of deposit_result
| Batch_V1_result of Batch_V1.t
let message_result_encoding =
let open Data_encoding in
union
[
(let kind = "deposit_result" in
case
~title:kind
(Tag 0)
(obj1 (req kind encoding_deposit_result))
(function Deposit_result result -> Some result | _ -> None)
(fun result -> Deposit_result result));
(let kind = "batch_v1_result" in
case
~title:kind
(Tag 1)
(obj1 (req kind Batch_V1.encoding))
(function Batch_V1_result result -> Some result | _ -> None)
(fun result -> Batch_V1_result result));
]
type t = message_result * Tx_rollup_withdraw.t list
let encoding =
Data_encoding.(
tup2 message_result_encoding (list Tx_rollup_withdraw.encoding))
end
type parameters = {
tx_rollup_max_withdrawals_per_batch : int;
}
module Make (Context : CONTEXT) = struct
open Context
open Syntax
open Message_result
type ctxt = Context.t
(** {3. Indexes. } *)
(** The application of a message can (and is supposed to) use and
create several indexes during the application of a {Tx_rollup_message.t}.
*)
let index get_or_associate_index add_index ctxt indexes indexable =
let open Indexable in
match destruct indexable with
| Right v -> (
let+ ctxt, created, idx = get_or_associate_index ctxt v in
match created with
| `Existed -> (ctxt, indexes, idx)
| `Created -> (ctxt, add_index indexes (v, idx), idx))
| Left i -> return (ctxt, indexes, i)
let address_index ctxt indexes indexable =
let get_or_associate_index = Address_index.get_or_associate_index in
let add_index indexes x =
{indexes with address_indexes = x :: indexes.address_indexes}
in
index get_or_associate_index add_index ctxt indexes indexable
let ticket_index ctxt indexes indexable =
let get_or_associate_index = Ticket_index.get_or_associate_index in
let add_index indexes x =
{indexes with ticket_indexes = x :: indexes.ticket_indexes}
in
index get_or_associate_index add_index ctxt indexes indexable
let address_of_signer_index :
Signer_indexable.index -> Tx_rollup_l2_address.Indexable.index =
fun idx -> Indexable.(index_exn (to_int32 idx))
let signer_of_address_index :
Tx_rollup_l2_address.Indexable.index -> Signer_indexable.index =
fun idx -> Indexable.(index_exn (to_int32 idx))
let empty_indexes = {address_indexes = []; ticket_indexes = []}
let assert_non_zero_quantity qty =
fail_when Tx_rollup_l2_qty.(qty = zero) Invalid_zero_transfer
(** {2. Counter } *)
(** [get_metadata ctxt idx] returns the metadata associated to [idx] in
[ctxt]. It must have an associated metadata in the context, otherwise,
something went wrong in {!check_signature}. *)
let get_metadata : ctxt -> address_index -> metadata m =
fun ctxt idx ->
let open Address_metadata in
let* metadata = get ctxt idx in
match metadata with
| None -> fail (Unallocated_metadata (Indexable.to_int32 idx))
| Some metadata -> return metadata
(** [get_metadata_signer] gets the metadata for a signer using {!get_metadata}.
It transforms a signer index to an address one. *)
let get_metadata_signer : ctxt -> Signer_indexable.index -> metadata m =
fun ctxt signer_idx -> get_metadata ctxt (address_of_signer_index signer_idx)
(** [transfers ctxt source_idx destination_idx tidx amount] transfers [amount]
from [source_idx] to [destination_idx] of [tidx]. *)
let transfer ctxt source_idx destination_idx tidx amount =
let* () =
fail_unless
Compare.Int.(Indexable.compare_indexes source_idx destination_idx <> 0)
Invalid_self_transfer
in
let* () = assert_non_zero_quantity amount in
let* ctxt = Ticket_ledger.spend ctxt tidx source_idx amount in
Ticket_ledger.credit ctxt tidx destination_idx amount
(** [deposit ctxt aidx tidx amount] credits [amount] of [tidx] to [aidx].
They are deposited from the layer1 and created in the layer2 context, but,
we only handle the creation part (i.e. in the layer2) in this module. *)
let deposit ctxt aidx tidx amount = Ticket_ledger.credit ctxt tidx aidx amount
module Batch_V1 = struct
open Tx_rollup_l2_batch.V1
(** [operation_with_signer_index ctxt indexes op] takes an operation
and performs multiple get/sets on the context to return an operation
where the signer is replaced by its index.
It performs on the [ctxt]:
{ul {li If the signer is an index, we read the public key from the
[ctxt].}
{li If the signer is a public key, we associate a new index to
it in the [ctxt]. The public key is also added to the metadata
if not already present.}}
{b Note:} If the context already contains all the required information,
we only read from it. *)
let operation_with_signer_index :
ctxt ->
indexes ->
('signer, 'content) operation ->
(ctxt
* indexes
* (Indexable.index_only, 'content) operation
* Bls.Public_key.t)
m =
fun ctxt indexes op ->
let* ctxt, indexes, pk, idx =
match Indexable.destruct op.signer with
| Left signer_index ->
let address_index = address_of_signer_index signer_index in
let* metadata = get_metadata ctxt address_index in
let pk = metadata.public_key in
return (ctxt, indexes, pk, address_index)
| Right (Bls_pk signer_pk) -> (
let addr = Bls.Public_key.hash signer_pk in
let* ctxt, created, idx =
Address_index.get_or_associate_index ctxt addr
in
match created with
| `Existed ->
let* ctxt =
let* metadata = Address_metadata.get ctxt idx in
match metadata with
| Some _ ->
return ctxt
| None ->
Address_metadata.init_with_public_key ctxt idx signer_pk
in
return (ctxt, indexes, signer_pk, idx)
| `Created ->
let indexes =
{
indexes with
address_indexes = (addr, idx) :: indexes.address_indexes;
}
in
let* ctxt =
Address_metadata.init_with_public_key ctxt idx signer_pk
in
return (ctxt, indexes, signer_pk, idx))
| Right (L2_addr signer_addr) -> (
let* idx = Address_index.get ctxt signer_addr in
match idx with
| None -> fail (Unknown_address signer_addr)
| Some idx ->
let* metadata = get_metadata ctxt idx in
return (ctxt, indexes, metadata.public_key, idx))
in
let op : (Indexable.index_only, 'content) operation =
{op with signer = signer_of_address_index idx}
in
return (ctxt, indexes, op, pk)
(** [check_transaction ctxt indexes transmitted transaction] performs an
*active* check of an operation.
We consider this as an *active* check because the function is likely to
write in the [ctxt], since it replaces the signer's public key
(if provided) by its index in {!operation_with_signer_index}.
Outside of the active preprocessing, we check that a signer signs
at most one operation in the [transaction].
It also associates the signer to the bytes representation of a
transaction in [transmitted], which is used to check the aggregated
signature.
*)
let check_transaction ctxt indexes transmitted transaction =
let* buf =
match
Data_encoding.Binary.to_bytes_opt
(Data_encoding.Compact.make ~tag_size:`Uint8 compact_transaction)
transaction
with
| Some buf -> return buf
| None -> fail Invalid_transaction_encoding
in
let* ctxt, indexes, transmitted, _, rev_ops =
list_fold_left_m
(fun (ctxt, indexes, transmitted, signers, ops) op ->
let* ctxt, indexes, op, pk =
operation_with_signer_index ctxt indexes op
in
if List.mem ~equal:Bls.Public_key.equal pk signers then
fail (Multiple_operations_for_signer pk)
else
return
( ctxt,
indexes,
(pk, buf) :: transmitted,
pk :: signers,
op :: ops ))
(ctxt, indexes, transmitted, [], [])
transaction
in
return (ctxt, indexes, transmitted, List.rev rev_ops)
let check_signature :
ctxt ->
('signer, 'content) t ->
(ctxt * indexes * (Indexable.index_only, 'content) t) m =
fun ctxt ({contents = transactions; aggregated_signature} as batch) ->
let* ctxt, indexes, transmitted, rev_new_transactions =
list_fold_left_m
(fun (ctxt, indexes, transmitted, new_transactions) transaction ->
let* ctxt, indexes, transmitted, transaction =
check_transaction ctxt indexes transmitted transaction
in
return (ctxt, indexes, transmitted, transaction :: new_transactions))
(ctxt, empty_indexes, [], [])
transactions
in
let* b = bls_verify transmitted aggregated_signature in
let* () = fail_unless b Incorrect_aggregated_signature in
let batch = {batch with contents = List.rev rev_new_transactions} in
return (ctxt, indexes, batch)
(** {2. Apply } *)
(** [apply_operation_content ctxt source content] performs the transfer
on the [ctxt]. The validity of the transfer is checked in
the context itself, e.g. for an invalid balance.
It returns the potential created indexes:
{ul {li The destination address index.}
{li The ticket exchanged index.}}
*)
let apply_operation_content :
ctxt ->
indexes ->
Signer_indexable.index ->
'content operation_content ->
(ctxt * indexes * Tx_rollup_withdraw.t option) m =
fun ctxt indexes source_idx op_content ->
match op_content with
| Withdraw {destination = claimer; ticket_hash; qty = amount} ->
let* tidx_opt = Ticket_index.get ctxt ticket_hash in
let*? tidx =
Option.value_e ~error:(Missing_ticket ticket_hash) tidx_opt
in
let source_idx = address_of_signer_index source_idx in
let* () = assert_non_zero_quantity amount in
let* ctxt = Ticket_ledger.spend ctxt tidx source_idx amount in
let withdrawal = Tx_rollup_withdraw.{claimer; ticket_hash; amount} in
return (ctxt, indexes, Some withdrawal)
| Transfer {destination; ticket_hash; qty} ->
let* ctxt, indexes, dest_idx =
address_index ctxt indexes destination
in
let* ctxt, indexes, tidx = ticket_index ctxt indexes ticket_hash in
let source_idx = address_of_signer_index source_idx in
let* ctxt = transfer ctxt source_idx dest_idx tidx qty in
return (ctxt, indexes, None)
(** [check_counter ctxt signer counter] asserts that the provided [counter] is the
successor of the one associated to the [signer] in the [ctxt]. *)
let check_counter :
ctxt -> Indexable.index_only Signer_indexable.t -> int64 -> unit m =
fun ctxt signer counter ->
let* metadata = get_metadata_signer ctxt signer in
fail_unless
Compare.Int64.(counter = Int64.succ metadata.counter)
(Counter_mismatch
{
account = Bls.Public_key.hash metadata.public_key;
expected = Int64.succ metadata.counter;
provided = counter;
})
(** [apply_operation ctxt indexes op] checks the counter validity for the [op.signer] with
{!check_counter}, and then calls {!apply_operation_content} for each content in [op]. *)
let apply_operation :
ctxt ->
indexes ->
(Indexable.index_only, Indexable.unknown) operation ->
(ctxt * indexes * Tx_rollup_withdraw.t list) m =
fun ctxt indexes {signer; counter; contents} ->
let* () = check_counter ctxt signer counter in
let* ctxt, indexes, rev_withdrawals =
list_fold_left_m
(fun (ctxt, indexes, withdrawals) content ->
let* ctxt, indexes, withdrawal_opt =
apply_operation_content ctxt indexes signer content
in
return (ctxt, indexes, Option.to_list withdrawal_opt @ withdrawals))
(ctxt, indexes, [])
contents
in
return (ctxt, indexes, rev_withdrawals |> List.rev)
(** [apply_transaction ctxt indexes transaction] applies each operation in
the [transaction]. It returns a {!transaction_result}, i.e. either
every operation in the [transaction] succedeed and the [ctxt] is
modified, or the [transaction] is a failure and the context
is left untouched.
*)
let apply_transaction :
ctxt ->
indexes ->
(Indexable.index_only, Indexable.unknown) transaction ->
(ctxt * indexes * transaction_result * Tx_rollup_withdraw.t list) m =
fun initial_ctxt initial_indexes transaction ->
let rec fold (ctxt, prev_indexes, withdrawals) index ops =
match ops with
| [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals)
| op :: rst ->
let* ctxt, indexes, status, withdrawals =
catch
(apply_operation ctxt prev_indexes op)
(fun (ctxt, indexes, op_withdrawals) ->
fold
(ctxt, indexes, withdrawals @ op_withdrawals)
(index + 1)
rst)
(fun reason ->
return
( initial_ctxt,
initial_indexes,
Transaction_failure {index; reason},
[] ))
in
return (ctxt, indexes, status, withdrawals)
in
fold (initial_ctxt, initial_indexes, []) 0 transaction
(** [update_counters ctxt status transaction] updates the counters for
the signers of operations in [transaction]. If the [transaction]
failed because of a [Counter_mismatch] the counters are left
untouched.
*)
let update_counters ctxt status transaction =
match status with
| Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt
| Transaction_failure _ | Transaction_success ->
list_fold_left_m
(fun ctxt (op : (Indexable.index_only, _) operation) ->
Address_metadata.incr_counter ctxt
@@ address_of_signer_index op.signer)
ctxt
transaction
let apply_batch :
ctxt ->
parameters ->
(Indexable.unknown, Indexable.unknown) t ->
(ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m =
fun ctxt parameters batch ->
let* ctxt, indexes, batch = check_signature ctxt batch in
let {contents; _} = batch in
let* ctxt, indexes, rev_results, withdrawals =
list_fold_left_m
(fun (prev_ctxt, prev_indexes, results, withdrawals) transaction ->
let* new_ctxt, new_indexes, status, transaction_withdrawals =
apply_transaction prev_ctxt prev_indexes transaction
in
let* new_ctxt = update_counters new_ctxt status transaction in
return
( new_ctxt,
new_indexes,
(transaction, status) :: results,
withdrawals @ transaction_withdrawals ))
(ctxt, indexes, [], [])
contents
in
let limit = parameters.tx_rollup_max_withdrawals_per_batch in
if Compare.List_length_with.(withdrawals > limit) then
fail
(Maximum_withdraws_per_message_exceeded
{current = List.length withdrawals; maximum = limit})
else
let results = List.rev rev_results in
return
( ctxt,
Message_result.Batch_V1.Batch_result {results; indexes},
withdrawals )
end
let apply_deposit :
ctxt ->
Tx_rollup_message.deposit ->
(ctxt * deposit_result * Tx_rollup_withdraw.t option) m =
fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} ->
let apply_deposit () =
let* ctxt, indexes, aidx =
address_index initial_ctxt empty_indexes destination
in
let* ctxt, indexes, tidx =
ticket_index ctxt indexes Indexable.(value ticket_hash)
in
let* ctxt = deposit ctxt aidx tidx amount in
return (ctxt, indexes)
in
catch
(apply_deposit ())
(fun (ctxt, indexes) -> return (ctxt, Deposit_success indexes, None))
(fun reason ->
let withdrawal =
Tx_rollup_withdraw.{claimer = sender; ticket_hash; amount}
in
return (initial_ctxt, Deposit_failure reason, Some withdrawal))
let apply_message :
ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m =
fun ctxt parameters msg ->
let open Tx_rollup_message in
match msg with
| Deposit deposit ->
let* ctxt, result, withdrawl_opt = apply_deposit ctxt deposit in
return (ctxt, (Deposit_result result, Option.to_list withdrawl_opt))
| Batch str -> (
let batch =
Data_encoding.Binary.of_string_opt Tx_rollup_l2_batch.encoding str
in
match batch with
| Some (V1 batch) ->
let* ctxt, result, withdrawals =
Batch_V1.apply_batch ctxt parameters batch
in
return (ctxt, (Batch_V1_result result, withdrawals))
| None -> fail Invalid_batch_encoding)
end