Source file conf.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
(*
 * Copyright (c) 2018-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.
 *)

type length_header = [ `Varint ] option

type inode_child_order =
  [ `Seeded_hash | `Hash_bits | `Custom of depth:int -> bytes -> int ]

module type S = sig
  val entries : int
  val stable_hash : int
  val contents_length_header : length_header
  val inode_child_order : inode_child_order
  val forbid_empty_dir_persistence : bool
end

module Default = struct
  let fresh = false
  let lru_size = 100_000
  let index_log_size = 2_500_000
  let readonly = false
  let merge_throttle = `Block_writes
  let indexing_strategy = Indexing_strategy.default
  let use_fsync = false
  let dict_auto_flush_threshold = 1_000_000
  let suffix_auto_flush_threshold = 1_000_000
  let no_migrate = false
end

open Irmin.Backend.Conf

let spec = Spec.v "pack"

type merge_throttle = [ `Block_writes | `Overcommit_memory ] [@@deriving irmin]

module Key = struct
  let fresh =
    key ~spec ~doc:"Start with a fresh disk." "fresh" Irmin.Type.bool
      Default.fresh

  let lru_size =
    key ~spec ~doc:"Size of the LRU cache for pack entries." "lru-size"
      Irmin.Type.int Default.lru_size

  let index_log_size =
    key ~spec ~doc:"Size of index logs." "index-log-size" Irmin.Type.int
      Default.index_log_size

  let readonly =
    key ~spec ~doc:"Start with a read-only disk." "readonly" Irmin.Type.bool
      Default.readonly

  let merge_throttle =
    key ~spec
      ~doc:"Strategy to use for large writes when index caches are full."
      "merge-throttle" merge_throttle_t Default.merge_throttle

  let root = root spec

  let indexing_strategy =
    let serialisable_t = [%typ: [ `Always | `Minimal ]] in
    key ~spec ~doc:"Strategy to use for adding objects to the index"
      "indexing-strategy"
      (Irmin.Type.map serialisable_t
         (function
           | `Always -> Indexing_strategy.always
           | `Minimal -> Indexing_strategy.minimal)
         (fun _ -> Fmt.failwith "Can't serialise indexing strategy"))
      Default.indexing_strategy

  let use_fsync =
    key ~spec
      ~doc:"Whether fsync should be used to ensure persistence order of files"
      "use-fsync" Irmin.Type.bool Default.use_fsync

  let dict_auto_flush_threshold =
    key ~spec ~doc:"Buffer size of the dict at which automatic flushes occur"
      "dict-auto-flush-threshold" Irmin.Type.int
      Default.dict_auto_flush_threshold

  let suffix_auto_flush_threshold =
    key ~spec ~doc:"Buffer size of the suffix at which automatic flushes occur"
      "suffix-auto-flush-threshold" Irmin.Type.int
      Default.suffix_auto_flush_threshold

  let no_migrate =
    key ~spec ~doc:"Prevent migration of V1 and V2 stores" "no-migrate"
      Irmin.Type.bool Default.no_migrate
end

let fresh config = get config Key.fresh
let lru_size config = get config Key.lru_size
let readonly config = get config Key.readonly
let index_log_size config = get config Key.index_log_size
let merge_throttle config = get config Key.merge_throttle

let root config =
  match find_root config with
  | None ->
      failwith
        "unintialised root, call [Irmin_pack.Conf.init root] before opening \
         the store"
  | Some root -> root

let indexing_strategy config = get config Key.indexing_strategy
let use_fsync config = get config Key.use_fsync
let dict_auto_flush_threshold config = get config Key.dict_auto_flush_threshold

let suffix_auto_flush_threshold config =
  get config Key.suffix_auto_flush_threshold

let no_migrate config = get config Key.no_migrate

let init ?(fresh = Default.fresh) ?(readonly = Default.readonly)
    ?(lru_size = Default.lru_size) ?(index_log_size = Default.index_log_size)
    ?(merge_throttle = Default.merge_throttle)
    ?(indexing_strategy = Default.indexing_strategy)
    ?(use_fsync = Default.use_fsync)
    ?(dict_auto_flush_threshold = Default.dict_auto_flush_threshold)
    ?(suffix_auto_flush_threshold = Default.suffix_auto_flush_threshold)
    ?(no_migrate = Default.no_migrate) root =
  let config = empty spec in
  let config = add config Key.root root in
  let config = add config Key.fresh fresh in
  let config = add config Key.lru_size lru_size in
  let config = add config Key.index_log_size index_log_size in
  let config = add config Key.readonly readonly in
  let config = add config Key.merge_throttle merge_throttle in
  let config = add config Key.indexing_strategy indexing_strategy in
  let config = add config Key.use_fsync use_fsync in
  let config =
    add config Key.dict_auto_flush_threshold dict_auto_flush_threshold
  in
  let config =
    add config Key.suffix_auto_flush_threshold suffix_auto_flush_threshold
  in
  let config = add config Key.no_migrate no_migrate in
  verify config