Source file vat_config.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
let docs = "CAP'N PROTO OPTIONS"

module Auth = Capnp_rpc_net.Auth
module Log = Capnp_rpc.Debug.Log

module Listen_address = struct
  include Network.Location

  open Cmdliner

  let cmd =
    let i = Arg.info ~docs ["capnp-listen-address"] ~docv:"ADDR" ~doc:"Address to listen on, e.g. $(b,unix:/run/my.socket)." in
    Arg.(required @@ opt (some cmdliner_conv) None i)
end

module Secret_hash : sig
  type t

  val of_pem_data : string -> t
  val to_string : t -> string
end = struct
  type t = string

  let of_pem_data data = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) |> Cstruct.to_string
  let to_string x = x
end

type t = {
  backlog : int;
  secret_key : (Auth.Secret_key.t * Secret_hash.t) Lazy.t;
  serve_tls : bool;
  listen_address : Listen_address.t;
  public_address : Network.Location.t;
}

let secret_key t = fst @@ Lazy.force t.secret_key

let hashed_secret t = Secret_hash.to_string @@ snd @@ Lazy.force t.secret_key

let secret_key_file =
  let open Cmdliner in
  let i = Arg.info ~docs ["capnp-secret-key-file"] ~docv:"PATH"
      ~doc:"File in which to store secret key (or \"\" for an ephemeral key)." in
  Arg.(required @@ opt (some string) None i)

let read_whole_file path =
  let ic = open_in_bin path in
  Fun.protect ~finally:(fun () -> close_in ic) @@ fun () ->
  let len = in_channel_length ic in
  really_input_string ic len

let write_whole_file path data =
  let oc = open_out_gen [Open_wronly; Open_creat; Open_excl; Open_binary] 0o600 path in
  Fun.protect ~finally:(fun () -> close_out oc) @@ fun () ->
  output_string oc data

let init_secret_key_file key_file =
  if Sys.file_exists key_file then (
    Log.info (fun f -> f "Restoring saved secret key from existing file %S" key_file);
    let data = read_whole_file key_file in
    (Auth.Secret_key.of_pem_data data, Secret_hash.of_pem_data data)
  ) else (
    Log.info (fun f -> f "Generating new secret key to store in %S" key_file);
    let secret_key = Auth.Secret_key.generate () in
    let data = Auth.Secret_key.to_pem_data secret_key in
    write_whole_file key_file data;
    (secret_key, Secret_hash.of_pem_data data)
  )

let create ?(backlog=5) ?public_address ~secret_key ?(serve_tls=true) listen_address =
  let public_address =
    match public_address with
    | Some x -> x
    | None -> listen_address
  in
  Network.Location.validate_public public_address;
  let secret_key = lazy (
    match secret_key with
    | `File path -> init_secret_key_file path
    | `PEM data -> (Auth.Secret_key.of_pem_data data, Secret_hash.of_pem_data data)
    | `Ephemeral ->
      let key = Auth.Secret_key.generate () in
      let data = Auth.Secret_key.to_pem_data key in
      (key, Secret_hash.of_pem_data data)
  ) in
  { backlog; secret_key; serve_tls; listen_address; public_address }

let secret_key_term =
  let get = function
    | "" -> `Ephemeral
    | path -> `File path
  in
  Cmdliner.Term.(const get $ secret_key_file)

let derived_id t name =
  let secret = hashed_secret t in
  Capnp_rpc_net.Restorer.Id.derived ~secret name

let auth t =
  if t.serve_tls then Capnp_rpc_net.Auth.Secret_key.digest (secret_key t)
  else Capnp_rpc_net.Auth.Digest.insecure

let sturdy_uri t service =
  let address = (t.public_address, auth t) in
  Network.Address.to_uri (address, Capnp_rpc_net.Restorer.Id.to_string service)

open Cmdliner

let pp f {backlog; secret_key; serve_tls; listen_address; public_address} =
  Fmt.pf f "{backlog=%d; fingerprint=%a; serve_tls=%b; listen_address=%a; public_address=%a}"
    backlog
    (Auth.Secret_key.pp_fingerprint `SHA256) (fst @@ Lazy.force secret_key)
    serve_tls
    Listen_address.pp listen_address
    Network.Location.pp public_address

let equal {backlog; secret_key; serve_tls; listen_address; public_address} b =
  backlog = b.backlog &&
  serve_tls = serve_tls &&
  Listen_address.equal listen_address b.listen_address &&
  Network.Location.equal public_address b.public_address &&
  Auth.Secret_key.equal (fst @@ Lazy.force secret_key) (fst @@ Lazy.force b.secret_key)

let public_address =
  let i = Arg.info ~docs ["capnp-public-address"] ~docv:"ADDR" ~doc:"Address to tell others to connect on." in
  Arg.(value @@ opt (some Network.Location.cmdliner_conv) None i)

let disable_tls =
  let i = Arg.info ~docs ["capnp-disable-tls"] ~doc:"Do not use TLS for incoming connections." in
  Arg.(value @@ flag i)

let cmd =
  let make secret_key disable_tls listen_address public_address =
    let public_address =
      match public_address with
      | None -> listen_address
      | Some x -> x
    in
    create ~secret_key ~serve_tls:(not disable_tls) ~public_address listen_address
  in
  Term.(const make $ secret_key_term $ disable_tls $ Listen_address.cmd $ public_address)