Source file runtime_arg.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
(*
 * Copyright (c) 2023 Thomas Gazagnaire <thomas@gazagnaire.org>
 *
 * 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 Functoria
include Runtime_arg

(** {2 OCaml runtime} *)

let runtime_arg ~pos name =
  Runtime_arg.create ~pos
    ~packages:[ package "mirage-runtime" ]
    (Fmt.str "Mirage_runtime.%s" name)

let runtime_network_key ~pos fmt =
  Fmt.kstr
    (Runtime_arg.create ~pos
       ~packages:[ package "mirage-runtime" ~sublibs:[ "network" ] ])
    ("Mirage_runtime_network." ^^ fmt)

let delay = runtime_arg ~pos:__POS__ "delay"
let backtrace = runtime_arg ~pos:__POS__ "backtrace"
let randomize_hashtables = runtime_arg ~pos:__POS__ "randomize_hashtables"
let allocation_policy = runtime_arg ~pos:__POS__ "allocation_policy"
let minor_heap_size = runtime_arg ~pos:__POS__ "minor_heap_size"
let major_heap_increment = runtime_arg ~pos:__POS__ "major_heap_increment"
let space_overhead = runtime_arg ~pos:__POS__ "space_overhead"
let max_space_overhead = runtime_arg ~pos:__POS__ "max_space_overhead"
let gc_verbosity = runtime_arg ~pos:__POS__ "gc_verbosity"
let gc_window_size = runtime_arg ~pos:__POS__ "gc_window_size"
let custom_major_ratio = runtime_arg ~pos:__POS__ "custom_major_ratio"
let custom_minor_ratio = runtime_arg ~pos:__POS__ "custom_minor_ratio"
let custom_minor_max_size = runtime_arg ~pos:__POS__ "custom_minor_max_size"

let pp_group ppf = function
  | None | Some "" -> ()
  | Some g -> Fmt.pf ppf "~group:%S " g

let pp_docs ppf = function
  | None | Some "" -> ()
  | Some g -> Fmt.pf ppf "~docs:%S " g

let pp_option pp ppf = function
  | None -> Fmt.pf ppf "None"
  | Some d -> Fmt.pf ppf "(Some %a)" pp d

let escape pp ppf = Fmt.kstr (fun str -> Fmt.Dump.string ppf str) "%a" pp

(** {3 Network keys} *)

let interface ?group ?docs default =
  runtime_network_key ~pos:__POS__ "interface %a%a%S" pp_group group pp_docs
    docs default

module V4 = struct
  open Ipaddr.V4

  let pp_prefix ppf p =
    Fmt.pf ppf "(Ipaddr.V4.Prefix.of_string_exn %a)" (escape Prefix.pp) p

  let pp ppf p = Fmt.pf ppf "(Ipaddr.V4.of_string_exn %a)" (escape pp) p

  let network ?group ?docs default =
    runtime_network_key ~pos:__POS__ "V4.network %a%a%a" pp_group group pp_docs
      docs pp_prefix default

  let gateway ?group ?docs default =
    runtime_network_key ~pos:__POS__ "V4.gateway %a%a%a" pp_group group pp_docs
      docs (pp_option pp) default
end

module V6 = struct
  open Ipaddr.V6

  let pp_prefix ppf p =
    Fmt.pf ppf "(Ipaddr.V6.Prefix.of_string_exn %a)" (escape Prefix.pp) p

  let pp ppf p = Fmt.pf ppf "(Ipaddr.V6.of_string_exn %a)" (escape pp) p

  let network ?group ?docs default =
    runtime_network_key ~pos:__POS__ "V6.network %a%a%a" pp_group group pp_docs
      docs (pp_option pp_prefix) default

  let gateway ?group ?docs default =
    runtime_network_key ~pos:__POS__ "V6.gateway %a%a%a" pp_group group pp_docs
      docs (pp_option pp) default

  let accept_router_advertisements ?group ?docs () =
    runtime_network_key ~pos:__POS__ "V6.accept_router_advertisements %a%a()"
      pp_group group pp_docs docs
end

let ipv4_only ?group ?docs () =
  runtime_network_key ~pos:__POS__ "ipv4_only %a%a()" pp_group group pp_docs
    docs

let ipv6_only ?group ?docs () =
  runtime_network_key ~pos:__POS__ "ipv6_only %a%a()" pp_group group pp_docs
    docs

let resolver ?group ?docs ?(default = []) () =
  let pp_default ppf = function
    | [] -> ()
    | l -> Fmt.pf ppf "~default:%a " Fmt.Dump.(list string) l
  in
  runtime_network_key ~pos:__POS__ "resolver %a%a%a()" pp_group group pp_docs
    docs pp_default default

let pp_ipaddr ?group ?docs ppf p =
  Fmt.pf ppf "Ipaddr.of_string %a%a%a" pp_group group pp_docs docs
    (escape Ipaddr.pp) p

let syslog ?group ?docs default =
  runtime_network_key ~pos:__POS__ "syslog %a%a%a" pp_group group pp_docs docs
    (pp_option pp_ipaddr) default

let monitor ?group ?docs default =
  runtime_network_key ~pos:__POS__ "monitor %a%a%a" pp_group group pp_docs docs
    (pp_option pp_ipaddr) default

let syslog_port ?group ?docs default =
  runtime_network_key ~pos:__POS__ "syslog_port %a%a%a" pp_group group pp_docs
    docs (pp_option Fmt.int) default

let syslog_hostname ?group ?docs default =
  runtime_network_key ~pos:__POS__ "syslog_hostname %a%a%S" pp_group group
    pp_docs docs default

type log_threshold = [ `All | `Src of string ] * Logs.level option

let logs = runtime_arg ~pos:__POS__ "logs"