From ae061ad9c0b815a0e8c367bb486405d85928190f Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 6 Oct 2023 13:27:07 +0200 Subject: [PATCH 1/4] Random number generator initialisation is domain-safe --- rng/entropy.ml | 8 ++++---- rng/rng.ml | 8 ++++---- rng/unix/mirage_crypto_rng_unix.ml | 6 +++--- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/rng/entropy.ml b/rng/entropy.ml index f7daca7e..bbb72f57 100644 --- a/rng/entropy.ml +++ b/rng/entropy.ml @@ -43,19 +43,19 @@ module Cpu_native = struct | _ -> assert false end -let _sources = ref [] +let _sources = Atomic.make [] type source = Rng.source let register_source name = - let n = List.length !_sources in + let n = List.length (Atomic.get _sources) in let source = (n, name) in - _sources := source :: !_sources; + Atomic.set _sources (source :: (Atomic.get _sources)); source let id (idx, _) = idx -let sources () = !_sources +let sources () = Atomic.get _sources let pp_source ppf (idx, name) = Format.fprintf ppf "[%d] %s" idx name diff --git a/rng/rng.ml b/rng/rng.ml index 7041f573..9262617f 100644 --- a/rng/rng.ml +++ b/rng/rng.ml @@ -54,14 +54,14 @@ let create (type a) ?g ?seed ?(strict=false) ?time (m : a generator) = Option.iter (M.reseed ~g) seed; Generator (g, strict, m) -let _default_generator = ref None +let _default_generator = Atomic.make None -let set_default_generator g = _default_generator := Some g +let set_default_generator g = Atomic.set _default_generator (Some g) -let unset_default_generator () = _default_generator := None +let unset_default_generator () = Atomic.set _default_generator None let default_generator () = - match !_default_generator with + match Atomic.get _default_generator with | None -> raise No_default_generator | Some g -> g diff --git a/rng/unix/mirage_crypto_rng_unix.ml b/rng/unix/mirage_crypto_rng_unix.ml index 43f8300b..2c30f9c1 100644 --- a/rng/unix/mirage_crypto_rng_unix.ml +++ b/rng/unix/mirage_crypto_rng_unix.ml @@ -16,10 +16,10 @@ let getrandom_init i = let data = getrandom 128 in Entropy.header i data -let running = ref false +let running = Atomic.make false let initialize (type a) ?g (rng : a generator) = - if !running then + if Atomic.get running then Log.debug (fun m -> m "Mirage_crypto_rng_unix.initialize has already been called, \ ignoring this call.") @@ -30,7 +30,7 @@ let initialize (type a) ?g (rng : a generator) = been set, check that this call is intentional"); with No_default_generator -> ()); - running := true ; + Atomic.set running true ; let seed = let init = Entropy.[ bootstrap ; whirlwind_bootstrap ; bootstrap ; getrandom_init ] From 231369563344ccb4039b6c2c8ebcb81ada1b1ca9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 6 Oct 2023 13:27:27 +0200 Subject: [PATCH 2/4] Fix some data-races recognized by tsan --- src/cipher_block.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/cipher_block.ml b/src/cipher_block.ml index 889826e0..ca13cf5e 100644 --- a/src/cipher_block.ml +++ b/src/cipher_block.ml @@ -89,14 +89,13 @@ module Counters = struct val unsafe_count_into : ctr -> Native.buffer -> int -> blocks:int -> unit end - let _tmp = Bytes.make 16 '\x00' - module C64be = struct type ctr = int64 let size = 8 let of_cstruct cs = BE.get_uint64 cs 0 let add = Int64.add let unsafe_count_into t buf off ~blocks = + let _tmp = Bytes.make 16 '\x00' in Bytes.set_int64_be _tmp 0 t; Native.count8be _tmp buf off ~blocks end @@ -110,6 +109,7 @@ module Counters = struct let flip = if Int64.logxor w0 w0' < 0L then w0' > w0 else w0' < w0 in ((if flip then Int64.succ w1 else w1), w0') let unsafe_count_into (w1, w0) buf off ~blocks = + let _tmp = Bytes.make 16 '\x00' in Bytes.set_int64_be _tmp 0 w1; Bytes.set_int64_be _tmp 8 w0; Native.count16be _tmp buf off ~blocks end @@ -120,6 +120,7 @@ module Counters = struct let hi = 0xffffffff00000000L and lo = 0x00000000ffffffffL in (w1, Int64.(logor (logand hi w0) (add n w0 |> logand lo))) let unsafe_count_into (w1, w0) buf off ~blocks = + let _tmp = Bytes.make 16 '\x00' in Bytes.set_int64_be _tmp 0 w1; Bytes.set_int64_be _tmp 8 w0; Native.count16be4 _tmp buf off ~blocks end @@ -239,9 +240,9 @@ module Modes = struct assert (cs.len >= tagsize); let k = Bytes.create keysize in Native.GHASH.keyinit cs.buffer cs.off k; k - let _cs = create_unsafe tagsize let hash0 = Bytes.make tagsize '\x00' let digesti ~key i = (* Clobbers `_cs`! *) + let _cs = create_unsafe tagsize in let res = Bytes.copy hash0 in i (fun cs -> Native.GHASH.ghash key res cs.buffer cs.off cs.len); blit_from_bytes res 0 _cs 0 tagsize; _cs @@ -256,15 +257,17 @@ module Modes = struct let tag_size = GHASH.tagsize let key_sizes, block_size = C.(key, block) - let z128, h = create block_size, create block_size let of_secret cs = let key = C.e_of_secret cs in + let z128 = create block_size in + let h = create block_size in C.encrypt ~key ~blocks:1 z128.buffer z128.off h.buffer h.off; { key ; hkey = GHASH.derive h } let bits64 cs = Int64.of_int (length cs * 8) - let pack64s = let _cs = create_unsafe 16 in fun a b -> + let pack64s = fun a b -> + let _cs = create_unsafe 16 in BE.set_uint64 _cs 0 a; BE.set_uint64 _cs 8 b; _cs let counter ~hkey nonce = match length nonce with From 13bd9191f42cfcad84a808a79d97788f65af90e9 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Sun, 8 Oct 2023 19:32:24 +0200 Subject: [PATCH 3/4] Atomic is only available since OCaml 4.12 --- mirage-crypto-rng.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mirage-crypto-rng.opam b/mirage-crypto-rng.opam index 12c8c551..94352a2a 100644 --- a/mirage-crypto-rng.opam +++ b/mirage-crypto-rng.opam @@ -13,7 +13,7 @@ build: [ ["dune" "subst"] {dev} ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ - "ocaml" {>= "4.08.0"} + "ocaml" {>= "4.12.0"} "dune" {>= "2.7"} "dune-configurator" {>= "2.0.0"} "duration" From 08ad0a9d894fdc2df5304630ed0430b33602bc53 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 24 Jan 2024 12:11:04 +0100 Subject: [PATCH 4/4] Provide a Domain_shism module to be compatible with OCaml 5.0 --- config/cfg_domain.ml | 7 +++++++ config/dune | 14 ++++++++++++-- src/cipher_block.ml | 21 +++++++++++++-------- src/domain.pre500.ml | 14 ++++++++++++++ src/domain.stable.ml | 1 + src/dune | 3 +++ 6 files changed, 50 insertions(+), 10 deletions(-) create mode 100644 config/cfg_domain.ml create mode 100644 src/domain.pre500.ml create mode 100644 src/domain.stable.ml diff --git a/config/cfg_domain.ml b/config/cfg_domain.ml new file mode 100644 index 00000000..0bfd61af --- /dev/null +++ b/config/cfg_domain.ml @@ -0,0 +1,7 @@ +let parse s = Scanf.sscanf s "%d.%d" (fun major minor -> (major, minor)) + +let () = + let version = parse Sys.ocaml_version in + if version >= (5, 0) + then print_string "domain.stable.ml" + else print_string "domain.pre500.ml" diff --git a/config/dune b/config/dune index b910e511..e27a2748 100644 --- a/config/dune +++ b/config/dune @@ -1,3 +1,13 @@ -(executables - (names cfg) +(executable + (name cfg) + (modules cfg) (libraries dune-configurator)) + +(executable + (name cfg_domain) + (modules cfg_domain)) + +(rule + (with-stdout-to + domain_shims + (run ./cfg_domain.exe))) diff --git a/src/cipher_block.ml b/src/cipher_block.ml index ca13cf5e..afd3a45f 100644 --- a/src/cipher_block.ml +++ b/src/cipher_block.ml @@ -89,13 +89,15 @@ module Counters = struct val unsafe_count_into : ctr -> Native.buffer -> int -> blocks:int -> unit end + let _tmp = Domain_shims.DLS.new_key (Fun.const (Bytes.make 16 '\000')) + module C64be = struct type ctr = int64 let size = 8 let of_cstruct cs = BE.get_uint64 cs 0 let add = Int64.add let unsafe_count_into t buf off ~blocks = - let _tmp = Bytes.make 16 '\x00' in + let _tmp = Domain_shims.DLS.get _tmp in Bytes.set_int64_be _tmp 0 t; Native.count8be _tmp buf off ~blocks end @@ -109,7 +111,7 @@ module Counters = struct let flip = if Int64.logxor w0 w0' < 0L then w0' > w0 else w0' < w0 in ((if flip then Int64.succ w1 else w1), w0') let unsafe_count_into (w1, w0) buf off ~blocks = - let _tmp = Bytes.make 16 '\x00' in + let _tmp = Domain_shims.DLS.get _tmp in Bytes.set_int64_be _tmp 0 w1; Bytes.set_int64_be _tmp 8 w0; Native.count16be _tmp buf off ~blocks end @@ -120,7 +122,7 @@ module Counters = struct let hi = 0xffffffff00000000L and lo = 0x00000000ffffffffL in (w1, Int64.(logor (logand hi w0) (add n w0 |> logand lo))) let unsafe_count_into (w1, w0) buf off ~blocks = - let _tmp = Bytes.make 16 '\x00' in + let _tmp = Domain_shims.DLS.get _tmp in Bytes.set_int64_be _tmp 0 w1; Bytes.set_int64_be _tmp 8 w0; Native.count16be4 _tmp buf off ~blocks end @@ -240,11 +242,12 @@ module Modes = struct assert (cs.len >= tagsize); let k = Bytes.create keysize in Native.GHASH.keyinit cs.buffer cs.off k; k + let _cs = Domain_shims.DLS.new_key (Fun.const (create_unsafe tagsize)) let hash0 = Bytes.make tagsize '\x00' let digesti ~key i = (* Clobbers `_cs`! *) - let _cs = create_unsafe tagsize in let res = Bytes.copy hash0 in i (fun cs -> Native.GHASH.ghash key res cs.buffer cs.off cs.len); + let _cs = Domain_shims.DLS.get _cs in blit_from_bytes res 0 _cs 0 tagsize; _cs end @@ -257,17 +260,19 @@ module Modes = struct let tag_size = GHASH.tagsize let key_sizes, block_size = C.(key, block) + let z128 = Domain_shims.DLS.new_key (Fun.const (create block_size)) + let h = Domain_shims.DLS.new_key (Fun.const (create block_size)) let of_secret cs = let key = C.e_of_secret cs in - let z128 = create block_size in - let h = create block_size in + let z128 = Domain_shims.DLS.get z128 in + let h = Domain_shims.DLS.get h in C.encrypt ~key ~blocks:1 z128.buffer z128.off h.buffer h.off; { key ; hkey = GHASH.derive h } let bits64 cs = Int64.of_int (length cs * 8) - let pack64s = fun a b -> - let _cs = create_unsafe 16 in + let _cs = Domain_shims.DLS.new_key (Fun.const (create_unsafe 16)) + let pack64s = let _cs = Domain_shims.DLS.get _cs in fun a b -> BE.set_uint64 _cs 0 a; BE.set_uint64 _cs 8 b; _cs let counter ~hkey nonce = match length nonce with diff --git a/src/domain.pre500.ml b/src/domain.pre500.ml new file mode 100644 index 00000000..0b082d66 --- /dev/null +++ b/src/domain.pre500.ml @@ -0,0 +1,14 @@ +module DLS = struct + type 'a key = + { init : unit -> 'a + ; cell : 'a option ref } + + let new_key ?split_from_parent:_ fn = + { init= fn; cell= ref None } + + let get { init; cell; } = match !cell with + | None -> cell := Some (init ()); Option.get !cell + | Some value -> value + + let set { cell; _ } value = cell := Some value +end diff --git a/src/domain.stable.ml b/src/domain.stable.ml new file mode 100644 index 00000000..6ca749d1 --- /dev/null +++ b/src/domain.stable.ml @@ -0,0 +1 @@ +include Stdlib.Domain diff --git a/src/dune b/src/dune index db7dc7f1..67b51632 100644 --- a/src/dune +++ b/src/dune @@ -19,6 +19,9 @@ (:standard) (:include cflags.sexp)))) +(rule + (copy %{read:../config/domain_shims} domain_shims.ml)) + (env (dev (c_flags (:include cflags_warn.sexp))))