• Home
  • Features
  • Pricing
  • Docs
  • Announcements
  • Sign In

MinaProtocol / mina / 507

19 Aug 2025 11:53PM UTC coverage: 33.38% (-28.0%) from 61.334%
507

push

buildkite

web-flow
Merge pull request #17640 from MinaProtocol/georgeee/compatible-to-develop-2025-08-19

Merge `compatible` to `develop` (19 August 2025, pt. 2)

24170 of 72408 relevant lines covered (33.38%)

24770.87 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

4.76
/src/lib/transition_frontier/persistent_root/persistent_root.ml
1
open Core
49✔
2
open Mina_base
3
module Ledger = Mina_ledger.Ledger
4
open Frontier_base
5
module Ledger_transfer = Mina_ledger.Ledger_transfer.Make (Ledger) (Ledger.Db)
6
module Ledger_transfer_stable =
7
  Mina_ledger.Ledger_transfer.Make (Ledger.Db) (Ledger.Db)
8

9
let transfer_snarked_root =
10
  Ledger.Root.transfer_accounts_with
11
    ~stable:Ledger_transfer_stable.transfer_accounts
12

13
let genesis_root_identifier ~genesis_state_hash =
14
  let open Root_identifier.Stable.Latest in
×
15
  { state_hash = genesis_state_hash }
16

17
let with_file ?size filename access_level ~f =
18
  let open Unix in
×
19
  let shared, mode =
20
    match access_level with
21
    | `Read ->
×
22
        (false, [ O_RDONLY ])
23
    | `Write ->
×
24
        (true, [ O_RDWR; O_TRUNC; O_CREAT ])
25
  in
26
  let fd = Unix.openfile filename ~mode in
27
  let buf_size =
×
28
    match size with
29
    | None ->
×
30
        Int64.to_int_exn Unix.(fstat fd).st_size
×
31
    | Some sz ->
×
32
        sz
33
  in
34
  (* Bigstring.map_file has been removed. We copy its old implementation. *)
35
  let buf =
36
    Bigarray.(
37
      array1_of_genarray
×
38
        (Core.Unix.map_file fd char c_layout ~shared [| buf_size |]))
×
39
  in
40
  let x = f buf in
41
  Bigstring.unsafe_destroy buf ;
×
42
  Unix.close fd ;
×
43
  x
×
44

45
(* TODO: create a reusable singleton factory abstraction *)
46
module rec Instance_type : sig
47
  type t =
48
    { snarked_ledger : Ledger.Root.t
49
    ; potential_snarked_ledgers : string Queue.t
50
    ; factory : Factory_type.t
51
    }
52
end =
53
  Instance_type
54

55
and Factory_type : sig
56
  type t =
57
    { directory : string
58
    ; logger : Logger.t
59
    ; mutable instance : Instance_type.t option
60
    ; ledger_depth : int
61
    }
62
end =
63
  Factory_type
64

65
open Instance_type
66
open Factory_type
67

68
module Instance = struct
69
  type t = Instance_type.t
70

71
  module Locations = struct
72
    (** Helper to create a filesystem location (for a file or directory) inside
73
        the [Factory_type.t] directory. *)
74
    let make_instance_location filename t = Filename.concat t.directory filename
×
75

76
    (** The directory name for the actual snarked ledger that is initialized and
77
        used by the daemon *)
78
    let snarked_ledger = make_instance_location "snarked_ledger"
49✔
79

80
    (** The directory name for a temporary snarked ledger, used while recovering
81
        a vaild potential snarked ledger during startup *)
82
    let tmp_snarked_ledger = make_instance_location "tmp_snarked_ledger"
49✔
83

84
    (** The name of a json file that lists the directory names of the potential
85
        snarked ledgers in the [potential_snarked_ledgers] queue *)
86
    let potential_snarked_ledgers =
87
      make_instance_location "potential_snarked_ledgers.json"
49✔
88

89
    (** A method that generates fresh potential snarked ledger directory
90
        names *)
91
    let make_potential_snarked_ledger t =
92
      let uuid = Uuid_unix.create () in
×
93
      make_instance_location ("snarked_ledger" ^ Uuid.to_string_hum uuid) t
×
94

95
    (** The name of the file recording the [Root_identifier.t] of the snarked
96
        root *)
97
    let root_identifier = make_instance_location "root"
49✔
98
  end
99

100
  let potential_snarked_ledgers_to_yojson queue =
101
    `List (List.map (Queue.to_list queue) ~f:(fun filename -> `String filename))
×
102

103
  let potential_snarked_ledgers_of_yojson json =
104
    Yojson.Safe.Util.to_list json |> List.map ~f:Yojson.Safe.Util.to_string
×
105

106
  let load_potential_snarked_ledgers_from_disk factory =
107
    let location = Locations.potential_snarked_ledgers factory in
×
108
    if phys_equal (Sys.file_exists location) `Yes then
×
109
      Yojson.Safe.from_file location |> potential_snarked_ledgers_of_yojson
×
110
    else []
×
111

112
  let write_potential_snarked_ledgers_to_disk t =
113
    Yojson.Safe.to_file
×
114
      (Locations.potential_snarked_ledgers t.factory)
×
115
      (potential_snarked_ledgers_to_yojson t.potential_snarked_ledgers)
×
116

117
  let enqueue_snarked_ledger ~location t =
118
    Queue.enqueue t.potential_snarked_ledgers location ;
×
119
    write_potential_snarked_ledgers_to_disk t
×
120

121
  let dequeue_snarked_ledger t =
122
    let location = Queue.dequeue_exn t.potential_snarked_ledgers in
×
123
    Mina_stdlib_unix.File_system.rmrf location ;
×
124
    write_potential_snarked_ledgers_to_disk t
×
125

126
  let destroy t =
127
    List.iter
×
128
      (Queue.to_list t.potential_snarked_ledgers)
×
129
      ~f:Mina_stdlib_unix.File_system.rmrf ;
130
    Mina_stdlib_unix.File_system.rmrf
×
131
      (Locations.potential_snarked_ledgers t.factory) ;
×
132
    Ledger.Root.close t.snarked_ledger ;
×
133
    t.factory.instance <- None
×
134

135
  let close t =
136
    Ledger.Root.close t.snarked_ledger ;
×
137
    t.factory.instance <- None
×
138

139
  let create factory =
140
    let snarked_ledger =
×
141
      Ledger.Root.create_single ~depth:factory.ledger_depth
142
        ~directory_name:(Locations.snarked_ledger factory)
×
143
        ()
144
    in
145
    { snarked_ledger; potential_snarked_ledgers = Queue.create (); factory }
×
146

147
  (** When we load from disk,
148
      1. Check the potential_snarked_ledgers to see if any one of these
149
         matches the snarked_ledger_hash in persistent_frontier;
150
      2. if none of those works, we load the old snarked_ledger and check if
151
         the old snarked_ledger matches with persistent_frontier;
152
      3. if not, we just reset all the persisted data and start from genesis
153
   *)
154
  let load_from_disk factory ~snarked_ledger_hash ~logger =
155
    let potential_snarked_ledgers =
×
156
      load_potential_snarked_ledgers_from_disk factory
157
    in
158
    let snarked_ledger =
×
159
      List.fold_until potential_snarked_ledgers ~init:None
160
        ~f:(fun _ location ->
161
          let potential_snarked_ledger =
×
162
            Ledger.Root.create_single ~depth:factory.ledger_depth
163
              ~directory_name:location ()
164
          in
165
          let potential_snarked_ledger_hash =
×
166
            Frozen_ledger_hash.of_ledger_hash
167
            @@ Ledger.Root.merkle_root potential_snarked_ledger
×
168
          in
169
          [%log debug]
×
170
            ~metadata:
171
              [ ( "potential_snarked_ledger_hash"
172
                , Frozen_ledger_hash.to_yojson potential_snarked_ledger_hash )
×
173
              ]
174
            "loaded potential_snarked_ledger from disk" ;
175
          if
×
176
            Frozen_ledger_hash.equal potential_snarked_ledger_hash
177
              snarked_ledger_hash
178
          then (
×
179
            let snarked_ledger =
180
              Ledger.Root.create_single ~depth:factory.ledger_depth
181
                ~directory_name:(Locations.tmp_snarked_ledger factory)
×
182
                ()
183
            in
184
            match
×
185
              transfer_snarked_root ~src:potential_snarked_ledger
186
                ~dest:snarked_ledger
187
            with
188
            | Ok _ ->
×
189
                Ledger.Root.close potential_snarked_ledger ;
190
                Mina_stdlib_unix.File_system.rmrf
×
191
                @@ Locations.snarked_ledger factory ;
×
192
                Sys.rename
×
193
                  (Locations.tmp_snarked_ledger factory)
×
194
                  (Locations.snarked_ledger factory) ;
×
195
                List.iter potential_snarked_ledgers
×
196
                  ~f:Mina_stdlib_unix.File_system.rmrf ;
197
                Mina_stdlib_unix.File_system.rmrf
×
198
                  (Locations.potential_snarked_ledgers factory) ;
×
199
                Stop (Some snarked_ledger)
×
200
            | Error e ->
×
201
                Ledger.Root.close potential_snarked_ledger ;
202
                List.iter potential_snarked_ledgers
×
203
                  ~f:Mina_stdlib_unix.File_system.rmrf ;
204
                Mina_stdlib_unix.File_system.rmrf
×
205
                  (Locations.potential_snarked_ledgers factory) ;
×
206
                [%log' error factory.logger]
×
207
                  ~metadata:[ ("error", `String (Error.to_string_hum e)) ]
×
208
                  "Ledger_transfer failed" ;
209
                Stop None )
×
210
          else (
×
211
            Ledger.Root.close potential_snarked_ledger ;
212
            Continue None ) )
×
213
        ~finish:(fun _ ->
214
          List.iter potential_snarked_ledgers
×
215
            ~f:Mina_stdlib_unix.File_system.rmrf ;
216
          Mina_stdlib_unix.File_system.rmrf
×
217
            (Locations.potential_snarked_ledgers factory) ;
×
218
          None )
×
219
    in
220
    match snarked_ledger with
×
221
    | None ->
×
222
        let snarked_ledger =
223
          Ledger.Root.create_single ~depth:factory.ledger_depth
224
            ~directory_name:(Locations.snarked_ledger factory)
×
225
            ()
226
        in
227
        let potential_snarked_ledger_hash =
×
228
          Frozen_ledger_hash.of_ledger_hash
229
          @@ Ledger.Root.merkle_root snarked_ledger
×
230
        in
231
        if
×
232
          Frozen_ledger_hash.equal potential_snarked_ledger_hash
233
            snarked_ledger_hash
234
        then
235
          Ok
×
236
            { snarked_ledger
237
            ; potential_snarked_ledgers = Queue.create ()
×
238
            ; factory
239
            }
240
        else (
×
241
          Ledger.Root.close snarked_ledger ;
242
          Error `Snarked_ledger_mismatch )
×
243
    | Some snarked_ledger ->
×
244
        Ok
245
          { snarked_ledger
246
          ; potential_snarked_ledgers = Queue.create ()
×
247
          ; factory
248
          }
249

250
  let snarked_ledger { snarked_ledger; _ } = snarked_ledger
×
251

252
  let set_root_identifier t new_root_identifier =
253
    [%log' trace t.factory.logger]
×
254
      ~metadata:
255
        [ ("root_identifier", Root_identifier.to_yojson new_root_identifier) ]
×
256
      "Setting persistent root identifier" ;
257
    let size = Root_identifier.Stable.Latest.bin_size_t new_root_identifier in
×
258
    with_file (Locations.root_identifier t.factory) `Write ~size ~f:(fun buf ->
×
259
        ignore
×
260
          ( Root_identifier.Stable.Latest.bin_write_t buf ~pos:0
×
261
              new_root_identifier
262
            : int ) )
263

264
  (* defaults to genesis *)
265
  let load_root_identifier t =
266
    let file = Locations.root_identifier t.factory in
×
267
    match Unix.access file [ `Exists; `Read ] with
×
268
    | Error _ ->
×
269
        None
270
    | Ok () ->
×
271
        with_file file `Read ~f:(fun buf ->
272
            let root_identifier =
×
273
              Root_identifier.Stable.Latest.bin_read_t buf ~pos_ref:(ref 0)
274
            in
275
            [%log' trace t.factory.logger]
×
276
              ~metadata:
277
                [ ("root_identifier", Root_identifier.to_yojson root_identifier)
×
278
                ]
279
              "Loaded persistent root identifier" ;
280
            Some root_identifier )
×
281

282
  let set_root_state_hash t state_hash = set_root_identifier t { state_hash }
×
283
end
284

285
type t = Factory_type.t
286

287
let create ~logger ~directory ~ledger_depth =
288
  { directory; logger; instance = None; ledger_depth }
×
289

290
let create_instance_exn t =
291
  assert (Option.is_none t.instance) ;
×
292
  let instance = Instance.create t in
293
  t.instance <- Some instance ;
×
294
  instance
295

296
let load_from_disk_exn t ~snarked_ledger_hash ~logger =
297
  let open Result.Let_syntax in
×
298
  assert (Option.is_none t.instance) ;
×
299
  let%map instance = Instance.load_from_disk t ~snarked_ledger_hash ~logger in
×
300
  t.instance <- Some instance ;
×
301
  instance
302

303
let with_instance_exn t ~f =
304
  let instance = create_instance_exn t in
×
305
  let x = f instance in
×
306
  Instance.close instance ; x
×
307

308
let reset_to_genesis_exn t ~precomputed_values =
309
  assert (Option.is_none t.instance) ;
×
310
  Mina_stdlib_unix.File_system.rmrf t.directory ;
311
  with_instance_exn t ~f:(fun instance ->
×
312
      ignore
×
313
        ( Precomputed_values.populate_root precomputed_values
×
314
            (Instance.snarked_ledger instance)
×
315
          |> Or_error.map ~f:Ledger.Root.as_unmasked
×
316
          : Ledger.Any_ledger.witness Or_error.t ) ;
317
      Instance.set_root_identifier instance
318
        (genesis_root_identifier
319
           ~genesis_state_hash:
320
             (Precomputed_values.genesis_state_hashes precomputed_values)
×
321
               .state_hash ) )
98✔
STATUS · Troubleshooting · Open an Issue · Sales · Support · CAREERS · ENTERPRISE · START FREE · SCHEDULE DEMO
ANNOUNCEMENTS · TWITTER · TOS & SLA · Supported CI Services · What's a CI service? · Automated Testing

© 2026 Coveralls, Inc