package irmin-pack

  1. Overview
  2. Docs
package irmin-pack
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file file_manager.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
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
(*
 * Copyright (c) 2022-2022 Tarides <contact@tarides.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Import
module Payload = Control_file.Payload.Upper.Latest
include File_manager_intf

let legacy_io_header_size = 16

module Make
    (Io : Io.S)
    (Index : Pack_index.S with module Io = Io)
    (Errs : Io_errors.S with module Io = Io) =
struct
  module Io = Errs.Io
  module Index = Index
  module Errs = Io_errors.Make (Io)
  module Ao = Append_only_file.Make (Io) (Errs)
  module Control = Control_file.Upper (Io)
  module Dict = Dict.Make (Io)
  module Suffix = Chunked_suffix.Make (Io) (Errs)
  module Sparse = Sparse_file.Make (Io)
  module Lower = Lower.Make (Io) (Errs)

  type after_reload_consumer = { after_reload : unit -> (unit, Errs.t) result }
  type after_flush_consumer = { after_flush : unit -> unit }

  type t = {
    dict : Dict.t;
    control : Control.t;
    mutable suffix : Suffix.t;
    mutable prefix : Sparse.t option;
    lower : Lower.t option;
    index : Index.t;
    mutable prefix_consumers : after_reload_consumer list;
    mutable suffix_consumers : after_flush_consumer list;
    indexing_strategy : Irmin_pack.Indexing_strategy.t;
    use_fsync : bool;
    root : string;
  }

  let control t = t.control
  let dict t = t.dict
  let suffix t = t.suffix
  let index t = t.index
  let prefix t = t.prefix
  let lower t = t.lower

  let close t =
    let open Result_syntax in
    let* () = Dict.close t.dict in
    let* () = Control.close t.control in
    let* () = Suffix.close t.suffix in
    let* () = Option.might Sparse.close t.prefix in
    let+ () = Index.close t.index in
    ()

  let register_prefix_consumer t ~after_reload =
    t.prefix_consumers <- { after_reload } :: t.prefix_consumers

  let register_suffix_consumer t ~after_flush =
    t.suffix_consumers <- { after_flush } :: t.suffix_consumers

  let get_gced = function Payload.Gced x -> Some x | _ -> None

  let generation payload =
    match get_gced payload with Some x -> x.generation | None -> 0

  let mapping_size payload =
    match get_gced payload with Some x -> x.mapping_end_poff | None -> None

  let notify_reload_consumers consumers =
    List.fold_left
      (fun acc { after_reload } -> Result.bind acc after_reload)
      (Ok ()) consumers
    |> Result.map_error (fun err -> (err : Errs.t :> [> Errs.t ]))

  (** Flush stages *************************************************************

      The irmin-pack files are only mutated during calls to one of the 3
      following functions. Exceptions:

      - During [create] and [open_rw].
      - During a GC.
      - When the branch store is modified. *)

  (** Flush stage 1 *)
  let flush_dict t =
    let open Result_syntax in
    let* () =
      if Dict.empty_buffer t.dict then Ok ()
      else (
        Stats.incr_fm_field Dict_flushes;
        Dict.flush t.dict)
    in
    if t.use_fsync then Dict.fsync t.dict else Ok ()

  let flush_suffix t =
    let open Result_syntax in
    let* () =
      if Suffix.empty_buffer t.suffix then Ok ()
      else (
        Stats.incr_fm_field Suffix_flushes;
        Suffix.flush t.suffix)
    in
    if t.use_fsync then Suffix.fsync t.suffix else Ok ()

  let flush_control t =
    let pl : Payload.t = Control.payload t.control in
    let status =
      match pl.status with
      | From_v1_v2_post_upgrade _ -> pl.status
      | Gced _ -> pl.status
      | No_gc_yet ->
          if Irmin_pack.Indexing_strategy.is_minimal t.indexing_strategy then
            pl.status
          else (
            [%log.warn
              "Updating the control file to \
               [Used_non_minimal_indexing_strategy]. It won't be possible to \
               GC this irmin-pack store anymore."];
            Payload.Used_non_minimal_indexing_strategy)
      | Used_non_minimal_indexing_strategy -> pl.status
      | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14
      | T15 ->
          assert false
    in
    let new_pl =
      {
        pl with
        appendable_chunk_poff = Suffix.appendable_chunk_poff t.suffix;
        dict_end_poff = Dict.end_poff t.dict;
        status;
      }
    in
    if new_pl = pl then Ok ()
    else
      let open Result_syntax in
      let* () = Control.set_payload t.control new_pl in
      if t.use_fsync then Control.fsync t.control else Ok ()

  (** Flush stage 2 *)
  let flush_suffix_and_its_deps ?hook t =
    let open Result_syntax in
    let* () = flush_dict t in
    (match hook with Some h -> h `After_dict | None -> ());
    let* () = flush_suffix t in
    let+ () = flush_control t in
    List.iter (fun { after_flush } -> after_flush ()) t.suffix_consumers

  (** Flush stage 3 *)
  let flush_index_and_its_deps ?hook t =
    let open Result_syntax in
    let* () = flush_suffix_and_its_deps ?hook t in
    (match hook with Some h -> h `After_suffix | None -> ());
    let+ () =
      Stats.incr_fm_field Index_flushes;
      Index.flush ~with_fsync:t.use_fsync t.index
    in
    ()

  (* Auto flushes *********************************************************** *)

  (** Is expected to be called by the index when its append buffer is full so
      that the dependendies of index are flushes. When the function returns,
      index will flush itself. *)
  let index_is_about_to_auto_flush_exn t =
    Stats.incr_fm_field Auto_index;
    flush_suffix_and_its_deps t |> Errs.raise_if_error

  (* Explicit flush ********************************************************* *)

  let flush ?hook t =
    Stats.incr_fm_field Flush;
    flush_index_and_its_deps ?hook t

  (* Explicit fsync ********************************************************* *)

  let fsync t =
    let open Result_syntax in
    let* () = Dict.fsync t.dict in
    let* () = Suffix.fsync t.suffix in
    let* () = Control.fsync t.control in
    Index.flush ~with_fsync:true t.index

  (* Constructors *********************************************************** *)

  module Layout = Irmin_pack.Layout.V5

  let open_prefix ~root ~generation ~mapping_size =
    let open Result_syntax in
    if generation = 0 then Ok None
    else
      let mapping = Layout.mapping ~generation ~root in
      let data = Layout.prefix ~root ~generation in
      let* mapping_size =
        match mapping_size with
        | Some size -> Ok size
        | None -> Io.size_of_path mapping
      in
      let mapping_size = Int63.to_int mapping_size in
      let+ prefix = Sparse.open_ro ~mapping_size ~mapping ~data in
      Some prefix

  let reopen_prefix t ~generation ~mapping_size =
    let open Result_syntax in
    let* some_prefix = open_prefix ~root:t.root ~generation ~mapping_size in
    match some_prefix with
    | None -> Ok ()
    | Some _ ->
        let prev_prefix = t.prefix in
        t.prefix <- some_prefix;
        let* () = notify_reload_consumers t.prefix_consumers in
        Option.might Sparse.close prev_prefix

  let reopen_suffix t ~chunk_start_idx ~chunk_num ~appendable_chunk_poff =
    let open Result_syntax in
    (* Invariant: reopen suffix is only called on V3 (and above) suffix files,
       for which dead_header_size is 0. *)
    let dead_header_size = 0 in
    [%log.debug
      "reopen_suffix chunk_start_idx:%d chunk_num:%d appendable_chunk_poff:%d"
        chunk_start_idx chunk_num
        (Int63.to_int appendable_chunk_poff)];
    let readonly = Suffix.readonly t.suffix in
    let* suffix1 =
      let root = t.root in
      let start_idx = chunk_start_idx in
      [%log.debug "reload: generation changed, opening suffix"];
      if readonly then
        Suffix.open_ro ~root ~appendable_chunk_poff ~dead_header_size ~start_idx
          ~chunk_num
      else
        Suffix.open_rw ~root ~appendable_chunk_poff ~dead_header_size ~start_idx
          ~chunk_num
    in
    let suffix0 = t.suffix in
    t.suffix <- suffix1;
    Suffix.close suffix0

  let reload_lower t ~volume_num =
    match t.lower with
    | Some lower -> Lower.reload ~volume_num lower
    | None -> Ok ()

  let cleanup ~root ~generation ~chunk_start_idx ~chunk_num ~lower =
    let () =
      Sys.readdir root
      |> Array.to_list
      |> List.filter (fun filename ->
             match Irmin_pack.Layout.Classification.Upper.v filename with
             | `Unknown | `Branch | `Control | `Dict | `V1_or_v2_pack -> false
             | `Prefix g | `Mapping g -> g <> generation
             | `Suffix idx ->
                 idx < chunk_start_idx || idx > chunk_start_idx + chunk_num
             | `Reachable _ | `Sorted _ | `Gc_result _ | `Control_tmp -> true)
      |> List.iter (fun residual ->
             let filename = Filename.concat root residual in
             [%log.debug "Remove residual file %s" filename];
             match Io.unlink filename with
             | Ok () -> ()
             | Error (`Sys_error error) ->
                 [%log.warn
                   "Could not remove residual file %s: %s" filename error])
    in
    Option.might (Lower.cleanup ~generation) lower

  let add_volume_and_update_control lower control =
    let open Result_syntax in
    (* Step 1. Add volume *)
    let* _ = Lower.add_volume lower in
    (* Step 2. Update control file *)
    let pl = Control.payload control in
    let pl = { pl with volume_num = Lower.volume_num lower } in
    [%log.debug "add_volume: update control_file volume_num:%d" pl.volume_num];
    Control.set_payload control pl

  let finish_constructing_rw config control ~make_dict ~make_suffix ~make_index
      ~make_lower =
    let open Result_syntax in
    let root = Irmin_pack.Conf.root config in
    let use_fsync = Irmin_pack.Conf.use_fsync config in
    let indexing_strategy = Conf.indexing_strategy config in
    let pl : Payload.t = Control.payload control in
    let generation, mapping_size =
      match pl.status with
      | From_v1_v2_post_upgrade _ | No_gc_yet
      | Used_non_minimal_indexing_strategy ->
          (0, None)
      | Gced x -> (x.generation, x.mapping_end_poff)
      | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14
      | T15 ->
          assert false
    in
    let chunk_start_idx = pl.chunk_start_idx in
    let chunk_num = pl.chunk_num in
    (* 1. Create a ref for dependency injections for auto flushes *)
    let instance = ref None in
    let get_instance () =
      match !instance with
      | None ->
          [%log.warn
            "%s: instance was accessed whilst None; this is unexpected during \
             normal node operation"
            __FILE__];
          [%log.warn
            "%s: the stack trace is %s" __FILE__
              Printexc.(get_callstack 20 |> raw_backtrace_to_string)];
          (* get_instance is used by the callback functions below; if we reach this point, a
             callback was invoked whilst instance was None; it should be the case that we
             can ignore the callback *)
          assert false
      | Some x -> x
    in
    (* 2. Open the other files *)
    let* suffix = make_suffix () in
    let* prefix = open_prefix ~root ~generation ~mapping_size in
    let* dict =
      let path = Layout.dict ~root in
      make_dict ~path
    in
    let* index =
      let log_size = Conf.index_log_size config in
      let throttle = Conf.merge_throttle config in
      let cb () =
        (* when creating the index, the index may call flush_callback, see
           https://github.com/mirage/irmin/issues/1963; so we can't assume that instance
           is set to Some _ in get_instance(); instead, we check instance, and just ignore
           the callback if the instance is None *)
        match !instance with
        | None -> ()
        | Some _ -> index_is_about_to_auto_flush_exn (get_instance ())
      in
      (* [cb] will not be called during calls to [index.flush] because we will
         use [~no_callback:()] *)
      make_index ~flush_callback:cb ~readonly:false ~throttle ~log_size root
    in
    (* 3. Open lower layer *)
    let* lower = make_lower () in
    (* 4. Perform any GC-related cleanups *)
    let* () = cleanup ~root ~generation ~chunk_start_idx ~chunk_num ~lower in
    let t =
      {
        dict;
        control;
        suffix;
        prefix;
        lower;
        use_fsync;
        index;
        prefix_consumers = [];
        suffix_consumers = [];
        indexing_strategy;
        root;
      }
    in
    instance := Some t;
    Ok t

  let create_control_file ~overwrite config pl =
    let root = Irmin_pack.Conf.root config in
    let path = Layout.control ~root in
    let tmp_path = Layout.control_tmp ~root in
    Control.create_rw ~path ~tmp_path:(Some tmp_path) ~overwrite pl

  (* Reload ***************************************************************** *)

  let reload ?hook t =
    let open Result_syntax in
    (* Step 1. Reread index *)
    let* () = Index.reload t.index in
    (match hook with Some h -> h `After_index | None -> ());
    let pl0 = Control.payload t.control in
    (* Step 2. Reread control file *)
    let* () = Control.reload t.control in
    (match hook with Some h -> h `After_control | None -> ());
    let pl1 : Payload.t = Control.payload t.control in
    if pl0 = pl1 then Ok ()
    else
      (* Step 3. Reopen files if generation or chunk_num changed. *)
      let* () =
        let gen0 = generation pl0.status in
        let gen1 = generation pl1.status in
        let chunk_num0 = pl0.chunk_num in
        let chunk_num1 = pl1.chunk_num in
        let chunk_start_idx0 = pl0.chunk_start_idx in
        let chunk_start_idx1 = pl1.chunk_start_idx in
        (* Step 3.1. Potentially reload suffix *)
        let* () =
          if chunk_num0 <> chunk_num1 || chunk_start_idx0 <> chunk_start_idx1
          then
            let appendable_chunk_poff = pl1.appendable_chunk_poff in
            reopen_suffix t ~chunk_start_idx:chunk_start_idx1
              ~appendable_chunk_poff ~chunk_num:chunk_num1
          else Ok ()
        in
        (* Step 3.2. Potentially reload prefix *)
        let* () =
          if gen0 = gen1 then Ok ()
          else
            reopen_prefix t ~generation:gen1
              ~mapping_size:(mapping_size pl1.status)
        in
        (* Step 3.3. Potentially reload lower *)
        if gen0 = gen1 && pl0.volume_num = pl1.volume_num then Ok ()
        else reload_lower t ~volume_num:pl1.volume_num
      in
      (* Step 4. Update end offsets *)
      let* () =
        Suffix.refresh_appendable_chunk_poff t.suffix pl1.appendable_chunk_poff
      in
      (match hook with Some h -> h `After_suffix | None -> ());
      let* () = Dict.refresh_end_poff t.dict pl1.dict_end_poff in
      Ok ()

  (* File creation ********************************************************** *)

  let create_lower_if_needed ~lower_root ~overwrite =
    match lower_root with
    | None -> Ok ()
    | Some path -> (
        match (Io.classify_path path, overwrite) with
        | `Directory, false -> Ok ()
        | `Directory, true ->
            (* TODO: implement recursive delete for lower root *)
            failwith
              (Fmt.str
                 "Lower root already exists but fresh = true in configuration. \
                  Please manually remove %s."
                 path)
        | `No_such_file_or_directory, _ -> Io.mkdir path
        | (`File | `Other), _ -> Errs.raise_error (`Not_a_directory path))

  let create_rw ~overwrite config =
    let open Result_syntax in
    let root = Irmin_pack.Conf.root config in
    let lower_root = Irmin_pack.Conf.lower_root config in
    let* () =
      match (overwrite, Io.classify_path root) with
      | _, (`File | `Other) -> Error (`Not_a_directory root)
      | false, `Directory -> Error (`File_exists root)
      | true, `Directory -> Ok ()
      | _, `No_such_file_or_directory -> Io.mkdir root
    in
    let* () = create_lower_if_needed ~lower_root ~overwrite in
    let* control =
      let open Payload in
      let status = No_gc_yet in
      let pl =
        let z = Int63.zero in
        {
          dict_end_poff = z;
          appendable_chunk_poff = z;
          checksum = z;
          status;
          upgraded_from = None;
          chunk_start_idx = 0;
          chunk_num = 1;
          volume_num = 0;
        }
      in
      create_control_file ~overwrite config pl
    in
    let make_dict = Dict.create_rw ~overwrite in
    let make_suffix () = Suffix.create_rw ~root ~overwrite ~start_idx:0 in
    let make_index ~flush_callback ~readonly ~throttle ~log_size root =
      (* [overwrite] is ignored for index *)
      Index.v ~fresh:true ~flush_callback ~readonly ~throttle ~log_size root
    in
    let make_lower () =
      match lower_root with
      | None -> Ok None
      | Some path ->
          let* l = Lower.v ~readonly:false ~volume_num:0 path in
          let+ _ = add_volume_and_update_control l control in
          Some l
    in
    finish_constructing_rw config control ~make_dict ~make_suffix ~make_index
      ~make_lower

  (* Open rw **************************************************************** *)

  let dead_header_size_of_status = function
    | Payload.From_v1_v2_post_upgrade _ -> legacy_io_header_size
    | No_gc_yet | Gced _ | Used_non_minimal_indexing_strategy -> 0
    | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14
    | T15 ->
        failwith "invalid status: T1..T15"

  let can_migrate_to_lower (payload : Payload.t) =
    match payload.status with
    | No_gc_yet | Used_non_minimal_indexing_strategy | From_v1_v2_post_upgrade _
      ->
        payload.chunk_num = 1 && payload.volume_num = 0
    | Gced _ -> false
    | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14
    | T15 ->
        failwith "invalid status: T1..T15"

  let migrate_to_lower ~root ~lower_root ~control (payload : Payload.t) =
    let open Result_syntax in
    (* Step 1. Create a lower by moving the suffix file. *)
    let suffix_file =
      Layout.suffix_chunk ~root ~chunk_idx:payload.chunk_start_idx
    in
    let dead_header_size = dead_header_size_of_status payload.status in
    let end_offset = payload.appendable_chunk_poff in
    let* () =
      Lower.create_from ~src:suffix_file ~dead_header_size ~size:end_offset
        lower_root
    in
    (* Step 2. Create a new empty suffix for the upper. *)
    let chunk_start_idx = payload.chunk_start_idx + 1 in
    let* () =
      Suffix.create_rw ~root ~overwrite:false ~start_idx:chunk_start_idx
      >>= Suffix.close
    in
    (* Step 3. Create a new empty prefix for the upper. *)
    let generation = 1 in
    let* () =
      let mapping = Layout.mapping ~generation ~root in
      let data = Layout.prefix ~root ~generation in
      Sparse.Ao.create ~mapping ~data >>= Sparse.Ao.close
    in
    (* Step 4. Remove dead header from dict (if needed) *)
    let* dict_end_poff, after_payload_write =
      if dead_header_size > 0 then (
        let dict_path = Layout.dict ~root in
        let tmp_dict_path = Filename.temp_file ~temp_dir:root "store" "dict" in
        let* dict_file = Io.open_ ~path:dict_path ~readonly:false in
        let* len = Io.read_size dict_file in
        let* tmp_dict_file = Io.open_ ~path:tmp_dict_path ~readonly:false in
        let contents_len = Int63.to_int len - dead_header_size in
        let* contents =
          Io.read_to_string dict_file
            ~off:(Int63.of_int dead_header_size)
            ~len:contents_len
        in
        Io.write_exn tmp_dict_file ~off:Int63.zero ~len:contents_len contents;
        let* _ = Io.close dict_file in
        let* _ = Io.close tmp_dict_file in
        (* Delay moving the temp file until after the payload is written so
           that we do not try to remove the dead header twice after a failure. *)
        Ok
          ( Int63.of_int contents_len,
            fun () -> Io.move_file ~src:tmp_dict_path ~dst:dict_path ))
      else Ok (payload.dict_end_poff, Fun.const (Ok ()))
    in
    (* Step 5. Update the upper control file. *)
    let payload =
      {
        payload with
        dict_end_poff;
        chunk_start_idx;
        appendable_chunk_poff = Int63.zero;
        volume_num = 1;
        status =
          Gced
            {
              suffix_start_offset = end_offset;
              generation;
              latest_gc_target_offset = Int63.zero;
              suffix_dead_bytes = Int63.zero;
              mapping_end_poff = Some Int63.zero;
            };
      }
    in
    let* () = Control.set_payload control payload in
    let* () = after_payload_write () in
    Ok payload

  let load_payload ~config ~root ~lower_root ~control =
    let payload = Control.payload control in
    match lower_root with
    | Some lower_root when payload.volume_num = 0 ->
        if Irmin_pack.Conf.no_migrate config then Error `Migration_needed
        else if not (can_migrate_to_lower payload) then
          Error `Migration_to_lower_not_allowed
        else migrate_to_lower ~root ~lower_root ~control payload
    | _ -> Ok payload

  let open_rw_with_control_file config =
    let open Result_syntax in
    let root = Irmin_pack.Conf.root config in
    let lower_root = Irmin_pack.Conf.lower_root config in
    let* () = create_lower_if_needed ~lower_root ~overwrite:false in
    let* control =
      let path = Layout.control ~root in
      let tmp_path = Layout.control_tmp ~root in
      Control.open_ ~readonly:false ~path ~tmp_path:(Some tmp_path)
    in
    let* Payload.
           {
             status;
             appendable_chunk_poff;
             chunk_start_idx = start_idx;
             chunk_num;
             dict_end_poff;
             volume_num;
             _;
           } =
      load_payload ~config ~root ~lower_root ~control
    in
    let* dead_header_size =
      match status with
      | From_v1_v2_post_upgrade _ -> Ok legacy_io_header_size
      | Gced _ ->
          let indexing_strategy = Conf.indexing_strategy config in
          if Irmin_pack.Indexing_strategy.is_minimal indexing_strategy then Ok 0
          else Error `Only_minimal_indexing_strategy_allowed
      | No_gc_yet | Used_non_minimal_indexing_strategy -> Ok 0
      | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14
      | T15 ->
          Error `V3_store_from_the_future
    in
    let make_dict ~path =
      Dict.open_rw ~size:dict_end_poff ~dead_header_size path
    in
    let make_suffix () =
      Suffix.open_rw ~root ~appendable_chunk_poff ~start_idx ~chunk_num
        ~dead_header_size
    in
    let make_index ~flush_callback ~readonly ~throttle ~log_size root =
      Index.v ~fresh:false ~flush_callback ~readonly ~throttle ~log_size root
    in
    let make_lower () =
      match lower_root with
      | None -> Ok None
      | Some lower_root ->
          assert (volume_num > 0);
          let+ l = Lower.v ~readonly:false ~volume_num lower_root in
          Some l
    in
    finish_constructing_rw config control ~make_dict ~make_suffix ~make_index
      ~make_lower

  let read_offset_from_legacy_file path =
    let open Result_syntax in
    (* Bytes 0-7 contains the offset. Bytes 8-15 contain the version. *)
    let* io = Io.open_ ~path ~readonly:true in
    Errors.finalise (fun _ ->
        Io.close io |> Errs.log_if_error "FM: read_offset_from_legacy_file")
    @@ fun () ->
    let* s = Io.read_to_string io ~off:Int63.zero ~len:8 in
    let x = Int63.decode ~off:0 s in
    Ok x

  let read_version_from_legacy_file path =
    let open Result_syntax in
    (* Bytes 0-7 contains the offset. Bytes 8-15 contain the version. *)
    let* io = Io.open_ ~path ~readonly:true in
    Errors.finalise (fun _ ->
        Io.close io |> Errs.log_if_error "FM: read_version_from_legacy_file")
    @@ fun () ->
    let off = Int63.of_int 8 in
    let* s = Io.read_to_string io ~off ~len:8 in
    match Version.of_bin s with
    | Some x -> Ok x
    | None -> Error `Corrupted_legacy_file

  let open_rw_migrate_from_v1_v2 config =
    let open Result_syntax in
    let root = Irmin_pack.Conf.root config in
    let src = Irmin_pack.Layout.V1_and_v2.pack ~root in
    let chunk_start_idx = 0 in
    let dst = Layout.suffix_chunk ~root ~chunk_idx:chunk_start_idx in
    let* suffix_end_poff = read_offset_from_legacy_file src in
    let* dict_end_poff =
      let path = Layout.dict ~root in
      read_offset_from_legacy_file path
    in
    let* () = Io.move_file ~src ~dst in
    let* control =
      let open Payload in
      let status =
        From_v1_v2_post_upgrade
          { entry_offset_at_upgrade_to_v3 = suffix_end_poff }
      in
      let pl =
        {
          dict_end_poff;
          appendable_chunk_poff = suffix_end_poff;
          checksum = Int63.zero;
          status;
          upgraded_from = None;
          chunk_start_idx;
          chunk_num = 1;
          volume_num = 0;
        }
      in
      create_control_file ~overwrite:false config pl
    in
    let* () = Control.close control in
    open_rw_with_control_file config

  let open_rw_no_control_file config =
    let root = Irmin_pack.Conf.root config in
    let suffix_path = Irmin_pack.Layout.V1_and_v2.pack ~root in
    match Io.classify_path suffix_path with
    | `Directory | `No_such_file_or_directory | `Other -> Error `Invalid_layout
    | `File -> open_rw_migrate_from_v1_v2 config

  let open_rw config =
    let root = Irmin_pack.Conf.root config in
    let no_migrate = Irmin_pack.Conf.no_migrate config in
    match Io.classify_path root with
    | `File | `Other -> Error (`Not_a_directory root)
    | `No_such_file_or_directory -> Error (`No_such_file_or_directory root)
    | `Directory -> (
        let path = Layout.control ~root in
        match Io.classify_path path with
        | `File -> open_rw_with_control_file config
        | `No_such_file_or_directory ->
            if no_migrate then Error `Migration_needed
            else open_rw_no_control_file config
        | `Directory | `Other -> Error `Invalid_layout)

  (* Open ro **************************************************************** *)

  let open_ro config =
    let open Result_syntax in
    let indexing_strategy = Conf.indexing_strategy config in
    let root = Irmin_pack.Conf.root config in
    let lower_root = Irmin_pack.Conf.lower_root config in
    let use_fsync = Irmin_pack.Conf.use_fsync config in
    (* 1. Open the control file *)
    let* control =
      let path = Layout.control ~root in
      Control.open_ ~readonly:true ~path ~tmp_path:None
      (* If no control file, then check whether the store is in v1 or v2. *)
      |> Result.map_error (function
           | `No_such_file_or_directory _ -> (
               let pack = Irmin_pack.Layout.V1_and_v2.pack ~root in
               match Io.classify_path pack with
               | `File -> `Migration_needed
               | `No_such_file_or_directory -> `No_such_file_or_directory pack
               | `Directory | `Other -> `Invalid_layout)
           | error -> error)
    in
    let Payload.
          {
            status;
            appendable_chunk_poff;
            chunk_start_idx = start_idx;
            chunk_num;
            dict_end_poff;
            volume_num;
            _;
          } =
      Control.payload control
    in
    let dead_header_size = dead_header_size_of_status status in
    let generation = generation status in
    (* 2. Open the other files *)
    let* suffix =
      Suffix.open_ro ~root ~appendable_chunk_poff ~start_idx ~chunk_num
        ~dead_header_size
    in
    let* prefix =
      open_prefix ~root ~generation ~mapping_size:(mapping_size status)
    in
    let* dict =
      let filename = Layout.dict ~root in
      Dict.open_ro ~size:dict_end_poff ~dead_header_size filename
    in
    let* index =
      let log_size = Conf.index_log_size config in
      let throttle = Conf.merge_throttle config in
      Index.v ~fresh:false ~readonly:true ~throttle ~log_size root
    in
    (* 3. Open lower layer *)
    let* lower =
      match lower_root with
      | None -> Ok None
      | Some path ->
          let+ l = Lower.v ~readonly:true ~volume_num path in
          Some l
    in
    (* 4. return with success *)
    Ok
      {
        dict;
        control;
        suffix;
        prefix;
        lower;
        use_fsync;
        indexing_strategy;
        index;
        prefix_consumers = [];
        suffix_consumers = [];
        root;
      }

  (* MISC. ****************************************************************** *)

  let version ~root =
    let v2_or_v1 () =
      let path = Irmin_pack.Layout.V1_and_v2.pack ~root in
      match read_version_from_legacy_file path with
      | Ok v -> Ok v
      | Error `Double_close | Error `Invalid_argument | Error `Closed ->
          assert false
      | Error (`No_such_file_or_directory _) -> Error `Invalid_layout
      | Error `Not_a_file -> Error `Invalid_layout
      | Error `Corrupted_legacy_file | Error `Read_out_of_bounds ->
          Error `Corrupted_legacy_file
      | Error (`Io_misc _) as e -> e
    in
    match Io.classify_path root with
    | `No_such_file_or_directory -> Error (`No_such_file_or_directory root)
    | `File | `Other -> Error (`Not_a_directory root)
    | `Directory -> (
        let path = Layout.control ~root in
        match Control.open_ ~path ~tmp_path:None ~readonly:true with
        | Ok _ -> Ok `V3
        | Error (`No_such_file_or_directory _) -> v2_or_v1 ()
        | Error `Not_a_file -> Error `Invalid_layout
        | Error `Closed -> assert false
        | Error
            ( `Io_misc _ | `Corrupted_control_file _
            | `Unknown_major_pack_version _ ) as e ->
            e)

  let swap t ~generation ~mapping_size ~suffix_start_offset ~chunk_start_idx
      ~chunk_num ~suffix_dead_bytes ~latest_gc_target_offset ~volume =
    let open Result_syntax in
    [%log.debug
      "Gc in main: swap gen %d; suffix start %a; chunk start idx %d; chunk num \
       %d; suffix dead bytes %a"
      generation Int63.pp suffix_start_offset chunk_start_idx chunk_num Int63.pp
        suffix_dead_bytes];
    let c0 = Mtime_clock.counter () in
    let pl = Control.payload t.control in

    (* Step 1. Reopen files *)
    let mapping_size = Some mapping_size in
    let* () = reopen_prefix t ~generation ~mapping_size in
    let* () =
      reopen_suffix t ~chunk_start_idx ~chunk_num
        ~appendable_chunk_poff:pl.appendable_chunk_poff
    in
    let span1 = Mtime_clock.count c0 |> Mtime.span_to_us in

    (* Step 2. Update the control file *)
    let* () =
      let pl =
        let open Payload in
        let status =
          match pl.status with
          | From_v1_v2_post_upgrade _ -> assert false
          | Used_non_minimal_indexing_strategy -> assert false
          | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13
          | T14 | T15 ->
              assert false
          | Gced _ | No_gc_yet ->
              Gced
                {
                  suffix_start_offset;
                  generation;
                  latest_gc_target_offset;
                  suffix_dead_bytes;
                  mapping_end_poff = mapping_size;
                }
        in

        { pl with status; chunk_start_idx; chunk_num }
      in
      [%log.debug "GC: writing new control_file"];
      Control.set_payload t.control pl
    in

    (* Step 3. Swap volume and reload lower if needed *)
    let* () =
      match volume with
      | None -> Ok ()
      | Some volume -> (
          match t.lower with
          | None ->
              assert false
              (* Programmer error if lower does not exist but volume is given *)
          | Some lower ->
              Lower.swap ~volume ~generation ~volume_num:pl.volume_num lower)
    in

    let span2 = Mtime_clock.count c0 |> Mtime.span_to_us in
    [%log.debug
      "Gc reopen files, update control: %.0fus, %.0fus" span1 (span2 -. span1)];
    Ok ()

  let readonly t = Suffix.readonly t.suffix

  let generation t =
    let pl = Control.payload t.control in
    match pl.status with
    | From_v1_v2_post_upgrade _ | Used_non_minimal_indexing_strategy -> 0
    | No_gc_yet -> 0
    | Gced x -> x.generation
    | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14
    | T15 ->
        (* Unreachable *)
        assert false

  let gc_behaviour t = match t.lower with Some _ -> `Archive | None -> `Delete

  let gc_destination t =
    match gc_behaviour t with
    | `Delete -> `Delete
    | `Archive -> `Archive (Option.get t.lower)

  let gc_allowed t =
    let pl = Control.payload t.control in
    let action = gc_behaviour t in
    match (action, pl.status) with
    | `Delete, (From_v1_v2_post_upgrade _ | Used_non_minimal_indexing_strategy)
      ->
        false
    | `Delete, (No_gc_yet | Gced _) -> true
    | `Archive, _ -> true
    | ( _,
        ( T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13
        | T14 | T15 ) ) ->
        (* Unreachable *)
        assert false

  let split t =
    let open Result_syntax in
    (* Step 1. Create a new chunk file *)
    let* () = Suffix.add_chunk t.suffix in

    (* Step 2. Update the control file *)
    let pl = Control.payload t.control in
    let pl =
      let open Payload in
      let chunk_num = succ pl.chunk_num in
      (* Update the control file with the poff of the last chunk. As last chunk
         is fresh, the poff is zero. *)
      let appendable_chunk_poff = Int63.zero in
      { pl with chunk_num; appendable_chunk_poff }
    in
    [%log.debug
      "split: update control_file chunk_start_idx:%d chunk_num:%d"
        pl.chunk_start_idx pl.chunk_num];
    Control.set_payload t.control pl

  let add_volume t =
    match t.lower with
    | None -> Error `Add_volume_requires_lower
    | Some lower -> add_volume_and_update_control lower t.control

  let cleanup t =
    let root = t.root in
    let pl : Payload.t = Control.payload t.control in
    let generation = generation t in
    let chunk_start_idx = pl.chunk_start_idx in
    let chunk_num = pl.chunk_num in
    let lower = t.lower in
    cleanup ~root ~generation ~chunk_start_idx ~chunk_num ~lower

  let create_one_commit_store t config gced commit_key =
    let open Result_syntax in
    let src_root = t.root in
    let dst_root = Irmin_pack.Conf.root config in
    (* Step 1. Copy the dict *)
    let src_dict = Layout.dict ~root:src_root in
    let dst_dict = Layout.dict ~root:dst_root in
    let* () = Io.copy_file ~src:src_dict ~dst:dst_dict in
    (* Step 2. Create an empty suffix and close it. *)
    let* suffix =
      Suffix.create_rw ~root:dst_root ~overwrite:false ~start_idx:1
    in
    let* () = Suffix.close suffix in
    (* Step 3. Create the control file and close it. *)
    let status = Payload.Gced gced in
    let dict_end_poff = Io.size_of_path dst_dict |> Errs.raise_if_error in
    let pl =
      {
        Payload.dict_end_poff;
        appendable_chunk_poff = Int63.zero;
        checksum = Int63.zero;
        status;
        upgraded_from = None;
        chunk_num = 1;
        chunk_start_idx = 1;
        volume_num = 0;
      }
    in
    let path = Layout.control ~root:dst_root in
    let* control = Control.create_rw ~path ~tmp_path:None ~overwrite:false pl in
    let* () = Control.close control in
    (* Step 4. Create the index. *)
    let* index =
      let log_size = Conf.index_log_size config in
      let throttle = Conf.merge_throttle config in
      Index.v ~fresh:true ~flush_callback:Fun.id ~readonly:false ~throttle
        ~log_size dst_root
    in
    (* Step 5. Add the commit to the index, close the index. *)
    let () =
      match Pack_key.inspect commit_key with
      | Pack_key.Direct { hash; offset; length; _ } ->
          Index.add index hash (offset, length, Pack_value.Kind.Commit_v2)
      | Indexed _ -> assert false
    in
    let* () = Index.close index in
    Ok ()
end
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct