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
(*
 * Copyright (c) 2018-2021 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.
 *)

module type S = sig
  val entries : int
  val stable_hash : int

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

  val inode_child_order : inode_child_order
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 freeze_throttle = `Block_writes
end

let fresh_key =
  Irmin.Private.Conf.key ~doc:"Start with a fresh disk." "fresh"
    Irmin.Private.Conf.bool Default.fresh

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

let index_log_size_key =
  Irmin.Private.Conf.key ~doc:"Size of index logs." "index-log-size"
    Irmin.Private.Conf.int Default.index_log_size

let readonly_key =
  Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly"
    Irmin.Private.Conf.bool Default.readonly

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

let merge_throttle_converter : merge_throttle Irmin.Private.Conf.converter =
  let parse = function
    | "block-writes" -> Ok `Block_writes
    | "overcommit-memory" -> Ok `Overcommit_memory
    | s ->
        Fmt.error_msg
          "invalid %s, expected one of: `block-writes' or `overcommit-memory'" s
  in
  let print =
    Fmt.of_to_string (function
      | `Block_writes -> "block-writes"
      | `Overcommit_memory -> "overcommit-memory")
  in
  (parse, print)

type freeze_throttle = [ `Block_writes | `Overcommit_memory | `Cancel_existing ]
[@@deriving irmin]

let freeze_throttle_converter : freeze_throttle Irmin.Private.Conf.converter =
  let parse = function
    | "block-writes" -> Ok `Block_writes
    | "overcommit-memory" -> Ok `Overcommit_memory
    | "cancel-existing" -> Ok `Cancel_existing
    | s ->
        Fmt.error_msg
          "invalid %s, expected one of: `block-writes, `overcommit-memory' or \
           `cancel-existing'"
          s
  in
  let print =
    Fmt.of_to_string (function
      | `Block_writes -> "block-writes"
      | `Overcommit_memory -> "overcommit-memory"
      | `Cancel_existing -> "cancel-existing")
  in
  (parse, print)

let merge_throttle_key =
  Irmin.Private.Conf.key
    ~doc:"Strategy to use for large writes when index caches are full."
    "merge-throttle" merge_throttle_converter Default.merge_throttle

let freeze_throttle_key =
  Irmin.Private.Conf.key ~doc:"Strategy to use for long-running freezes."
    "freeze-throttle" freeze_throttle_converter Default.freeze_throttle

let fresh config = Irmin.Private.Conf.get config fresh_key
let lru_size config = Irmin.Private.Conf.get config lru_size_key
let readonly config = Irmin.Private.Conf.get config readonly_key
let index_log_size config = Irmin.Private.Conf.get config index_log_size_key
let merge_throttle config = Irmin.Private.Conf.get config merge_throttle_key
let freeze_throttle config = Irmin.Private.Conf.get config freeze_throttle_key
let root_key = Irmin.Private.Conf.root

let root config =
  match Irmin.Private.Conf.get config root_key with
  | None -> failwith "no root set"
  | Some r -> r

let v ?(fresh = Default.fresh) ?(readonly = Default.readonly)
    ?(lru_size = Default.lru_size) ?(index_log_size = Default.index_log_size)
    ?(merge_throttle = Default.merge_throttle)
    ?(freeze_throttle = Default.freeze_throttle) root =
  let config = Irmin.Private.Conf.empty in
  let config = Irmin.Private.Conf.add config fresh_key fresh in
  let config = Irmin.Private.Conf.add config root_key (Some root) in
  let config = Irmin.Private.Conf.add config lru_size_key lru_size in
  let config =
    Irmin.Private.Conf.add config index_log_size_key index_log_size
  in
  let config = Irmin.Private.Conf.add config readonly_key readonly in
  let config =
    Irmin.Private.Conf.add config merge_throttle_key merge_throttle
  in
  let config =
    Irmin.Private.Conf.add config freeze_throttle_key freeze_throttle
  in
  config