├── rng ├── miou │ ├── pfortuna.mli │ ├── dune │ ├── mirage_crypto_rng_miou_unix.mli │ ├── mirage_crypto_rng_miou_unix.ml │ └── pfortuna.ml ├── mirage_crypto_rng.ml ├── dune ├── mirage │ ├── dune │ ├── mirage_crypto_rng_mirage.mli │ └── mirage_crypto_rng_mirage.ml ├── unix │ ├── discover.ml │ ├── dune │ ├── urandom.ml │ ├── getentropy.ml │ ├── mirage_crypto_rng_unix.mli │ ├── mirage_crypto_rng_unix.ml │ └── mc_getrandom_stubs.c ├── hmac_drbg.ml ├── rng.ml ├── fortuna.ml └── entropy.ml ├── config ├── dune └── cfg.ml ├── dune-project ├── pk ├── mirage_crypto_pk.ml ├── common.ml ├── dune ├── z_extra.ml └── dsa.ml ├── .gitattributes ├── ec ├── gen_tables │ ├── dune │ └── gen_tables.ml ├── dune ├── native │ ├── README.md │ ├── inversion_template.h │ ├── np256_stubs.c │ ├── np384_stubs.c │ ├── np521_stubs.c │ ├── p384_stubs.c │ ├── p521_stubs.c │ ├── p256_stubs.c │ └── GNUmakefile └── implementation.mld ├── tests ├── wycheproof │ ├── dune │ ├── wycheproof.mli │ └── wycheproof.ml ├── test_pk_runner.ml ├── test_symmetric_runner.ml ├── test_base.ml ├── test_miou_rng.ml ├── test_miou_entropy_collection.ml ├── test_entropy_collection.ml ├── test_numeric.ml ├── test_entropy.ml ├── test_common.ml ├── dune ├── test_dh.ml ├── misc_pk.ml └── test_random_runner.ml ├── src ├── mirage_crypto.ml ├── dune ├── uncommon.ml ├── native │ ├── chacha_generic.c │ ├── chacha.c │ ├── detect_cpu_features.c │ ├── poly1305-donna.c │ ├── misc_sse.c │ ├── misc.c │ ├── ghash_generic.c │ ├── mirage_crypto.h │ ├── bitfn.h │ ├── poly1305-donna-64.h │ └── poly1305-donna-32.h ├── aead.ml ├── cipher_stream.ml ├── poly1305.ml ├── native.ml ├── ccm.ml └── chacha20.ml ├── .gitignore ├── mirage ├── config.ml └── unikernel.ml ├── bench ├── dune └── miou.ml ├── .cirrus.yml ├── LICENSE.md ├── .test-mirage.sh ├── mirage-crypto.opam ├── mirage-crypto-rng-miou-unix.opam ├── mirage-crypto-rng-mirage.opam ├── mirage-crypto-pk.opam ├── mirage-crypto-rng.opam ├── .github └── workflows │ ├── windows.yml │ └── test.yml ├── LICENSE.md.mirage-crypto-rng-mirage ├── README.md ├── mirage-crypto-ec.opam └── LICENSE.md.mirage-crypto-ec /rng/miou/pfortuna.mli: -------------------------------------------------------------------------------- 1 | include Mirage_crypto_rng.Generator 2 | -------------------------------------------------------------------------------- /config/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names cfg) 3 | (libraries dune-configurator)) 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name mirage-crypto) 3 | (formatting disabled) 4 | -------------------------------------------------------------------------------- /pk/mirage_crypto_pk.ml: -------------------------------------------------------------------------------- 1 | module Dh = Dh 2 | module Dsa = Dsa 3 | module Rsa = Rsa 4 | module Z_extra = Z_extra 5 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.ml linguist-language=OCaml 2 | 3 | # Shell scripts are required to be LF 4 | *.sh text eol=lf 5 | -------------------------------------------------------------------------------- /ec/gen_tables/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs no) 2 | (executable 3 | (name gen_tables) 4 | (libraries mirage_crypto_ec)) 5 | -------------------------------------------------------------------------------- /rng/mirage_crypto_rng.ml: -------------------------------------------------------------------------------- 1 | include Rng 2 | 3 | module Fortuna = Fortuna 4 | module Hmac_drbg = Hmac_drbg.Make 5 | module Entropy = Entropy 6 | -------------------------------------------------------------------------------- /pk/common.ml: -------------------------------------------------------------------------------- 1 | let rec until p f = let r = f () in if p r then r else until p f 2 | 3 | let guard p err = if p then Ok () else Error err 4 | 5 | let ( let* ) = Result.bind 6 | -------------------------------------------------------------------------------- /rng/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_crypto_rng) 3 | (public_name mirage-crypto-rng) 4 | (libraries mirage-crypto digestif logs) 5 | (private_modules entropy fortuna hmac_drbg rng)) 6 | -------------------------------------------------------------------------------- /tests/wycheproof/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name wycheproof) 3 | (libraries yojson ppx_deriving_yojson.runtime) 4 | (preprocess 5 | (pps ppx_deriving.std ppx_deriving_yojson)) 6 | (optional)) 7 | -------------------------------------------------------------------------------- /pk/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_crypto_pk) 3 | (public_name mirage-crypto-pk) 4 | (libraries zarith mirage-crypto mirage-crypto-rng eqaf) 5 | (private_modules common dh dsa rsa z_extra)) 6 | -------------------------------------------------------------------------------- /src/mirage_crypto.ml: -------------------------------------------------------------------------------- 1 | module Uncommon = Uncommon 2 | module Poly1305 = Poly1305.It 3 | module type AEAD = Aead.AEAD 4 | include Cipher_block 5 | module Chacha20 = Chacha20 6 | include Cipher_stream 7 | -------------------------------------------------------------------------------- /rng/mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_crypto_rng_mirage) 3 | (public_name mirage-crypto-rng-mirage) 4 | (libraries lwt mirage-runtime mirage-crypto-rng mirage-sleep mirage-mtime 5 | duration logs)) 6 | -------------------------------------------------------------------------------- /rng/miou/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_crypto_rng_miou_unix) 3 | (public_name mirage-crypto-rng-miou-unix) 4 | (libraries miou miou.unix mirage-crypto mirage-crypto-rng mirage-crypto-rng.unix digestif duration mtime.clock.os logs) 5 | (modules mirage_crypto_rng_miou_unix pfortuna)) 6 | -------------------------------------------------------------------------------- /rng/unix/discover.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let open Configurator.V1 in 3 | main ~name:"rng_flags" (fun _t -> 4 | let c_lib_flags = 5 | match Sys.os_type with 6 | | "Win32" | "Cygwin" -> ["-lbcrypt"] 7 | | _ -> [] 8 | in 9 | Flags.write_sexp "rng_c_flags.sexp" c_lib_flags 10 | ) 11 | -------------------------------------------------------------------------------- /tests/test_pk_runner.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let suite = 4 | "All" >::: [ 5 | "Numeric" >::: Test_numeric.suite; 6 | "DHE" >::: Test_dh.suite; 7 | "DSA" >::: Test_dsa.suite; 8 | "RSA" >::: Test_rsa.suite; 9 | ] 10 | 11 | let () = 12 | Mirage_crypto_rng_unix.use_default (); 13 | run_test_tt_main suite 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | .*.swp 4 | mirage/Makefile 5 | mirage/crypto_test* 6 | mirage/dune 7 | mirage/dune-project 8 | mirage/dune.build 9 | mirage/dune.config 10 | mirage/key_gen.ml 11 | mirage/main.ml 12 | mirage/main.native 13 | mirage/*opam 14 | mirage/myocamlbuild.ml 15 | mirage/.mirage.config 16 | _opam 17 | *.install 18 | .opam/ 19 | -------------------------------------------------------------------------------- /mirage/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = 4 | let packages = [ 5 | package "mirage-crypto-rng" ; 6 | package "mirage-crypto-pk" ; 7 | package "mirage-crypto" ; 8 | package ~min:"0.8.7" "fmt" ; 9 | package "ohex" ; 10 | ] 11 | in 12 | main ~packages "Unikernel" job 13 | 14 | let () = 15 | register "crypto-test" [main] 16 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names speed) 3 | (modules speed) 4 | (libraries mirage-crypto mirage-crypto-rng mirage-crypto-rng.unix 5 | mirage-crypto-pk mirage-crypto-ec)) 6 | 7 | ; marking as "(optional)" leads to OCaml-CI failures 8 | ; marking with "(package mirage-crypto-rng-miou-unix)" only has an effect with a "public_name" 9 | ;(executables 10 | ; (names miou) 11 | ; (modules miou) 12 | ; (libraries mirage-crypto-rng-miou-unix)) 13 | -------------------------------------------------------------------------------- /tests/test_symmetric_runner.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let () = 4 | Format.printf "accel: %a\n%!" 5 | (fun ppf -> List.iter @@ fun x -> 6 | Format.fprintf ppf "%s " @@ 7 | match x with `XOR -> "XOR" | `AES -> "AES" | `GHASH -> "GHASH") 8 | Mirage_crypto.accelerated 9 | 10 | let suite = 11 | "All" >::: [ 12 | "Basic" >::: Test_base.suite; 13 | "Cipher" >::: Test_cipher.suite; 14 | ] 15 | 16 | let () = 17 | run_test_tt_main suite 18 | -------------------------------------------------------------------------------- /ec/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_crypto_ec) 3 | (public_name mirage-crypto-ec) 4 | (libraries eqaf mirage-crypto-rng digestif) 5 | (foreign_stubs 6 | (language c) 7 | (names p256_stubs np256_stubs p384_stubs np384_stubs p521_stubs np521_stubs 8 | curve25519_stubs) 9 | (include_dirs ../src/native) 10 | (flags 11 | (:standard -DNDEBUG) 12 | (:include cflags_optimized.sexp)))) 13 | 14 | (env 15 | (dev 16 | (c_flags (:include cflags_warn.sexp)))) 17 | 18 | (include_subdirs unqualified) 19 | 20 | (rule 21 | (targets cflags_optimized.sexp cflags_warn.sexp) 22 | (action 23 | (run ../config/cfg.exe))) 24 | -------------------------------------------------------------------------------- /tests/test_base.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | open Mirage_crypto 4 | 5 | open Test_common 6 | 7 | (* Xor *) 8 | 9 | let xor_cases = 10 | cases_of (f2_eq ~msg:"xor" Uncommon.xor) [ 11 | "00 01 02 03 04 05 06 07 08 09 0a 0b 0c" , 12 | "0c 0b 0a 09 08 07 06 05 04 03 02 01 00" , 13 | "0c 0a 08 0a 0c 02 00 02 0c 0a 08 0a 0c" ; 14 | 15 | "00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f" , 16 | "0f 0e 0d 0c 0b 0a 09 08 07 06 05 04 03 02 01 00" , 17 | "0f 0f 0f 0f 0f 0f 0f 0f 0f 0f 0f 0f 0f 0f 0f 0f" ; 18 | 19 | "00", "00", "00" ; 20 | 21 | "", "", "" ; 22 | ] 23 | 24 | let suite = [ 25 | "XOR" >::: [ "example" >::: xor_cases ]; 26 | ] 27 | -------------------------------------------------------------------------------- /.cirrus.yml: -------------------------------------------------------------------------------- 1 | freebsd_instance: 2 | image_family: freebsd-14-3 3 | 4 | freebsd_task: 5 | env: 6 | matrix: 7 | - OCAML_VERSION: 4.14.2 8 | 9 | pkg_install_script: pkg install -y ocaml-opam gmp gmake pkgconf bash 10 | 11 | ocaml_script: 12 | - opam init -a --comp=$OCAML_VERSION 13 | - opam env 14 | 15 | pin_packages_script: 16 | - opam install -y --deps-only -t ./mirage-crypto.opam ./mirage-crypto-rng.opam ./mirage-crypto-rng-mirage.opam ./mirage-crypto-ec.opam ./mirage-crypto-pk.opam 17 | 18 | test_script: opam exec -- dune runtest -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-mirage,mirage-crypto-pk,mirage-crypto-ec 19 | 20 | test_mirage_script: eval `opam env` && ./.test-mirage.sh 21 | -------------------------------------------------------------------------------- /rng/unix/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (modules discover) 4 | (libraries dune-configurator)) 5 | 6 | (rule 7 | (targets rng_c_flags.sexp) 8 | (action 9 | (run ./discover.exe))) 10 | 11 | (rule 12 | (targets cflags_warn.sexp) 13 | (action 14 | (run ../../config/cfg.exe))) 15 | 16 | (library 17 | (name mirage_crypto_rng_unix) 18 | (public_name mirage-crypto-rng.unix) 19 | (modules mirage_crypto_rng_unix urandom getentropy) 20 | (libraries mirage-crypto-rng unix logs threads.posix) 21 | (foreign_stubs 22 | (language c) 23 | (include_dirs ../../src/native) 24 | (names mc_getrandom_stubs)) 25 | (c_library_flags 26 | (:include rng_c_flags.sexp))) 27 | 28 | (env 29 | (dev 30 | (c_flags (:include cflags_warn.sexp)))) 31 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2016 David Kaloper Meršinjak 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_crypto) 3 | (public_name mirage-crypto) 4 | (libraries eqaf) 5 | (private_modules aead chacha20 ccm cipher_block cipher_stream native 6 | poly1305 uncommon) 7 | (foreign_stubs 8 | (language c) 9 | (names detect_cpu_features misc misc_sse aes_generic aes_aesni ghash_generic 10 | ghash_pclmul ghash_ctmul des_generic chacha poly1305-donna 11 | entropy_cpu_stubs) 12 | (flags 13 | (:standard) 14 | (:include cflags_optimized.sexp))) 15 | (foreign_stubs 16 | (language c) 17 | (names chacha_generic) 18 | (flags 19 | (:standard) 20 | (:include cflags.sexp)))) 21 | 22 | (env 23 | (dev 24 | (c_flags (:include cflags_warn.sexp)))) 25 | 26 | (include_subdirs unqualified) 27 | 28 | (rule 29 | (targets cflags.sexp cflags_optimized.sexp cflags_warn.sexp) 30 | (action 31 | (run ../config/cfg.exe))) 32 | -------------------------------------------------------------------------------- /rng/unix/urandom.ml: -------------------------------------------------------------------------------- 1 | 2 | type g = In_channel.t * Mutex.t 3 | 4 | (* The OCaml runtime always reads at least IO_BUFFER_SIZE from an input channel, which is currently 64 KiB *) 5 | let block = 65536 6 | 7 | let create ?time:_ () = 8 | let ic = In_channel.open_bin "/dev/urandom" 9 | and mutex = Mutex.create () 10 | in 11 | at_exit (fun () -> In_channel.close ic); 12 | (ic, mutex) 13 | 14 | let generate_into ~g:(ic, m) buf ~off len = 15 | let finally () = Mutex.unlock m in 16 | Mutex.lock m; 17 | Fun.protect ~finally (fun () -> 18 | match In_channel.really_input ic buf off len with 19 | | None -> failwith "couldn't read enough bytes from /dev/urandom" 20 | | Some () -> ()) 21 | 22 | let reseed ~g:_ _data = () 23 | 24 | let accumulate ~g:_ _source = 25 | `Acc (fun _data -> ()) 26 | 27 | let seeded ~g:_ = true 28 | 29 | let pools = 0 30 | -------------------------------------------------------------------------------- /tests/test_miou_rng.ml: -------------------------------------------------------------------------------- 1 | let () = Miou_unix.run @@ fun () -> 2 | let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in 3 | let random_num = Mirage_crypto_rng.generate 32 in 4 | assert (String.length random_num = 32); 5 | Printf.printf "32 bit random number: %s\n%!" (Ohex.encode random_num); 6 | let random_num = Mirage_crypto_rng.generate 16 in 7 | assert (String.length random_num = 16); 8 | Printf.printf "16 bit random number: %s\n%!" (Ohex.encode random_num); 9 | (* NOTE(dinosaure): the test below shows that [Pfortuna] is domain-safe when 10 | run with TSan. If we use the Fortuna engine, TSan will report invalid 11 | accesses between the domain that seeds the RNG and [dom0]. *) 12 | for _ = 0 to 4 do 13 | let _ = Mirage_crypto_rng.generate 16 in 14 | Miou_unix.sleep 0.5; 15 | done; 16 | Mirage_crypto_rng_miou_unix.kill rng 17 | -------------------------------------------------------------------------------- /.test-mirage.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -ex 4 | 5 | opam install --confirm-level=unsafe-yes "mirage>4" 6 | # to satisfy hardcoded version constraints in mirage, we need to be < 0.12.0 7 | # and "dune subst" doesn't work on these PR checkouts 8 | version='version: "2.99.0~dev"' 9 | echo $version >> mirage-crypto-rng-mirage.opam 10 | echo $version >> mirage-crypto-rng.opam 11 | echo $version >> mirage-crypto.opam 12 | echo $version >> mirage-crypto-pk.opam 13 | (mirage configure -t unix -f mirage/config.ml && gmake depend && dune build --root . mirage/dist/ && mirage/dist/crypto-test) || exit 1 14 | (mirage configure -t hvt -f mirage/config.ml && gmake depend && dune build --root . mirage/dist/) || exit 1 15 | if [ $(uname -m) = "amd64" ] || [ $(uname -m) = "x86_64" ]; then 16 | (mirage configure -t xen -f mirage/config.ml && gmake depend && dune build --root . mirage/dist/) || exit 1 17 | fi 18 | -------------------------------------------------------------------------------- /src/uncommon.ml: -------------------------------------------------------------------------------- 1 | (** [Uncommon] is a [Common], now with less name clashes. *) 2 | 3 | let kasprintf k fmt = 4 | Format.(kfprintf (fun _ -> k (flush_str_formatter ())) str_formatter fmt) 5 | 6 | let invalid_arg fmt = kasprintf invalid_arg ("Mirage_crypto: " ^^ fmt) 7 | 8 | let (//) x y = 9 | if y < 1 then raise Division_by_zero else 10 | if x > 0 then 1 + ((x - 1) / y) else 0 [@@inline] 11 | 12 | let imin (a : int) b = if a < b then a else b 13 | let imax (a : int) b = if a < b then b else a 14 | 15 | type 'a iter = ('a -> unit) -> unit 16 | 17 | let iter2 a b f = f a; f b 18 | let iter3 a b c f = f a; f b; f c 19 | 20 | let unsafe_xor_into src ~src_off dst ~dst_off n = 21 | Native.xor_into_bytes src src_off dst dst_off n 22 | 23 | let xor a b = 24 | assert (String.length a = String.length b); 25 | let b' = Bytes.of_string b in 26 | unsafe_xor_into a ~src_off:0 b' ~dst_off:0 (Bytes.length b'); 27 | Bytes.unsafe_to_string b' 28 | -------------------------------------------------------------------------------- /rng/unix/getentropy.ml: -------------------------------------------------------------------------------- 1 | 2 | external getrandom_buf : bytes -> int -> int -> unit = "mc_getrandom" [@@noalloc] 3 | 4 | type g = unit 5 | 6 | (* The maximum value for length is GETENTROPY_MAX for `getentropy`: https://pubs.opengroup.org/onlinepubs/9799919799/functions/getentropy.html 7 | The minimum acceptable value for GETENTROPY_MAX is 256 https://pubs.opengroup.org/onlinepubs/9799919799/basedefs/limits.h.html 8 | 9 | The actual implementation may be one of `getrandom`, `getentropy`, or `BCryptGenRandom`, and will internally limit the maximum bytes read in one go and loop as needed if more bytes are requested and we get a short read. 10 | *) 11 | let block = 256 12 | 13 | let create ?time:_ () = () 14 | 15 | let generate_into ~g:_ buf ~off len = 16 | getrandom_buf buf off len 17 | 18 | let reseed ~g:_ _data = () 19 | 20 | let accumulate ~g:_ _source = 21 | `Acc (fun _data -> ()) 22 | 23 | let seeded ~g:_ = true 24 | 25 | let pools = 0 26 | -------------------------------------------------------------------------------- /tests/test_miou_entropy_collection.ml: -------------------------------------------------------------------------------- 1 | module Printing_rng = struct 2 | type g = unit 3 | 4 | let block = 16 5 | let create ?time:_ () = () 6 | let generate_into ~g:_ _buf ~off:_ _len = assert false 7 | let seeded ~g:_ = true 8 | let pools = 1 9 | 10 | let reseed ~g:_ data = 11 | Format.printf "reseeding:@.%a@.%!" (Ohex.pp_hexdump ()) data 12 | 13 | let accumulate ~g:_ source = 14 | let print data = 15 | Format.printf "accumulate: (src: %a) %a@.%!" 16 | Mirage_crypto_rng.Entropy.pp_source source Ohex.pp data 17 | in 18 | `Acc print 19 | end 20 | 21 | let () = 22 | Miou_unix.run @@ fun () -> 23 | let rng = Mirage_crypto_rng_miou_unix.initialize (module Printing_rng) in 24 | Format.printf "entropy sources: %a@,%!" 25 | (fun ppf -> List.iter (fun x -> 26 | Mirage_crypto_rng.Entropy.pp_source ppf x; 27 | Format.pp_print_space ppf ())) 28 | (Mirage_crypto_rng.Entropy.sources ()); 29 | let sleep = Duration.(of_sec 2 |> to_f) in 30 | Miou_unix.sleep sleep; 31 | Mirage_crypto_rng_miou_unix.kill rng 32 | -------------------------------------------------------------------------------- /tests/test_entropy_collection.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Printing_rng = struct 4 | type g = unit 5 | 6 | let block = 16 7 | 8 | let create ?time:_ () = () 9 | 10 | let generate_into ~g:_ _buf ~off:_ _len = assert false 11 | 12 | let reseed ~g:_ data = 13 | Format.printf "reseeding:@.%a@.%!" (Ohex.pp_hexdump ()) data 14 | 15 | let accumulate ~g:_ source = 16 | let print data = 17 | Format.printf "accumulate: (src: %a) %a@.%!" 18 | Mirage_crypto_rng.Entropy.pp_source source Ohex.pp data 19 | in 20 | `Acc print 21 | 22 | let seeded ~g:_ = true 23 | let pools = 1 24 | end 25 | 26 | let with_entropy act = 27 | Mirage_crypto_rng_mirage.initialize (module Printing_rng) >>= fun () -> 28 | Format.printf "entropy sources: %a@,%!" 29 | (fun ppf -> List.iter (fun x -> 30 | Mirage_crypto_rng.Entropy.pp_source ppf x; 31 | Format.pp_print_space ppf ())) 32 | (Mirage_crypto_rng.Entropy.sources ()); 33 | act () 34 | 35 | let () = 36 | Unix_os.(Main.run (with_entropy (fun () -> Time.sleep_ns (Duration.of_sec 3)))) 37 | -------------------------------------------------------------------------------- /ec/native/README.md: -------------------------------------------------------------------------------- 1 | # Generated code from fiat 2 | 3 | This directory includes several files ("p*.h") that are generated by 4 | [fiat](https://github.com/mit-plv/fiat-crypto). The GNUmakefile provides 5 | targets to generate these files. 6 | 7 | The file "inversion_template.h" is copied from the fiat-crypto repository 8 | at e31a36d5f1b20134e67ccc5339d88f0ff3cb0f86 (inversion-c/inversion_template.c), 9 | and has some modifications: the "inversion" function is declared "static", 10 | and the convenience function "inversion" is provided. 11 | 12 | The "*_stubs.c" files are handcrafted. 13 | 14 | The "p*_tables_32/64.c" are generated from `../gen_tables` (see each file's 15 | header) and contain pre-computed data to speed up scalar multiplication for 16 | ECDSA. The 64- and 32-bit tables must be respectively generated from a 64-bit or 17 | 32-bit build of `gen_tables`. 18 | 19 | # Code from BoringSSL 20 | 21 | The code in "curve25519_tables.h", and large parts of 22 | "curve25519_stubs.c" and "point_operations.h" (excluding scalar multiplication) 23 | originate from BoringSSL. Minor adjustments have been done manually. 24 | -------------------------------------------------------------------------------- /mirage-crypto.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirage/mirage-crypto" 3 | dev-repo: "git+https://github.com/mirage/mirage-crypto.git" 4 | bug-reports: "https://github.com/mirage/mirage-crypto/issues" 5 | doc: "https://mirage.github.io/mirage-crypto/doc" 6 | authors: ["David Kaloper " "Hannes Mehnert " ] 7 | maintainer: "Hannes Mehnert " 8 | license: "ISC" 9 | synopsis: "Simple symmetric cryptography for the modern age" 10 | 11 | build: [ ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs ] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] 14 | 15 | depends: [ 16 | "ocaml" {>= "4.13.0"} 17 | "dune" {>= "2.7"} 18 | "dune-configurator" {>= "2.0.0"} 19 | "ounit2" {with-test} 20 | "ohex" {with-test & >= "0.2.0"} 21 | "eqaf" {>= "0.8"} 22 | ] 23 | conflicts: [ 24 | "ocaml-freestanding" 25 | "result" {< "1.5"} 26 | ] 27 | description: """ 28 | Mirage-crypto provides symmetric ciphers (DES, AES, RC4, ChaCha20/Poly1305). 29 | """ 30 | x-maintenance-intent: [ "(latest)" ] 31 | -------------------------------------------------------------------------------- /src/native/chacha_generic.c: -------------------------------------------------------------------------------- 1 | /* Based on https://github.com/abeaumont/ocaml-chacha.git */ 2 | 3 | #include "mirage_crypto.h" 4 | 5 | static inline void mc_chacha_quarterround(uint32_t *x, int a, int b, int c, int d) { 6 | x[a] += x[b]; x[d] = rol32(x[d] ^ x[a], 16); 7 | x[c] += x[d]; x[b] = rol32(x[b] ^ x[c], 12); 8 | x[a] += x[b]; x[d] = rol32(x[d] ^ x[a], 8); 9 | x[c] += x[d]; x[b] = rol32(x[b] ^ x[c], 7); 10 | } 11 | 12 | void mc_chacha_core_generic(int count, const uint32_t *src, uint32_t *dst) { 13 | uint32_t x[16]; 14 | cpu_to_le32_array(x, src, 16); 15 | for (int i = 0; i < count; i++) { 16 | mc_chacha_quarterround(x, 0, 4, 8, 12); 17 | mc_chacha_quarterround(x, 1, 5, 9, 13); 18 | mc_chacha_quarterround(x, 2, 6, 10, 14); 19 | mc_chacha_quarterround(x, 3, 7, 11, 15); 20 | 21 | mc_chacha_quarterround(x, 0, 5, 10, 15); 22 | mc_chacha_quarterround(x, 1, 6, 11, 12); 23 | mc_chacha_quarterround(x, 2, 7, 8, 13); 24 | mc_chacha_quarterround(x, 3, 4, 9, 14); 25 | } 26 | for (int i = 0; i < 16; i++) { 27 | uint32_t xi = x[i]; 28 | uint32_t hj = cpu_to_le32(src[i]); 29 | dst[i] = le32_to_cpu(xi + hj); 30 | } 31 | } 32 | 33 | -------------------------------------------------------------------------------- /mirage-crypto-rng-miou-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirage/mirage-crypto" 3 | dev-repo: "git+https://github.com/mirage/mirage-crypto.git" 4 | bug-reports: "https://github.com/mirage/mirage-crypto/issues" 5 | doc: "https://mirage.github.io/mirage-crypto/doc" 6 | authors: ["Romain Calascibetta " ] 7 | maintainer: "Romain Calascibetta " 8 | license: "ISC" 9 | synopsis: "Feed the entropy source in an miou.unix-friendly way" 10 | 11 | build: [ ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs ] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] 14 | 15 | depends: [ 16 | "ocaml" {>= "5.0.0"} 17 | "dune" {>= "2.7"} 18 | "miou" {>= "0.2.0"} 19 | "logs" 20 | "mirage-crypto-rng" {=version} 21 | "duration" 22 | "mtime" {>= "1.0.0"} 23 | "digestif" {>= "1.2.0"} 24 | "ohex" {with-test & >= "0.2.0"} 25 | ] 26 | description: """ 27 | Mirage-crypto-rng-miou-unix feeds the entropy source for Mirage_crypto_rng-based 28 | random number generator implementations, in an miou.unix-friendly way. 29 | """ 30 | x-maintenance-intent: [ "(latest)" ] 31 | -------------------------------------------------------------------------------- /mirage-crypto-rng-mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirage/mirage-crypto" 3 | dev-repo: "git+https://github.com/mirage/mirage-crypto.git" 4 | bug-reports: "https://github.com/mirage/mirage-crypto/issues" 5 | doc: "https://mirage.github.io/mirage-crypto/doc" 6 | authors: ["David Kaloper " "Hannes Mehnert " ] 7 | maintainer: "Hannes Mehnert " 8 | license: "BSD-2-Clause" 9 | synopsis: "Entropy collection for a cryptographically secure PRNG" 10 | 11 | build: [ ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs ] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] 14 | 15 | depends: [ 16 | "ocaml" {>= "4.13.0"} 17 | "dune" {>= "2.7"} 18 | "mirage-crypto-rng" {=version} 19 | "duration" 20 | "logs" 21 | "lwt" {>= "4.0.0"} 22 | "mirage-runtime" {>= "3.8.0"} 23 | "mirage-sleep" {>= "4.0.0"} 24 | "mirage-mtime" {>= "4.0.0"} 25 | "mirage-unix" {with-test & >= "5.0.0"} 26 | "ohex" {with-test & >= "0.2.0"} 27 | ] 28 | description: """ 29 | Mirage-crypto-rng-mirage provides entropy collection code for the RNG. 30 | """ 31 | x-maintenance-intent: [ "(latest)" ] 32 | -------------------------------------------------------------------------------- /mirage-crypto-pk.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirage/mirage-crypto" 3 | dev-repo: "git+https://github.com/mirage/mirage-crypto.git" 4 | bug-reports: "https://github.com/mirage/mirage-crypto/issues" 5 | doc: "https://mirage.github.io/mirage-crypto/doc" 6 | authors: ["David Kaloper " "Hannes Mehnert " ] 7 | maintainer: "Hannes Mehnert " 8 | license: "ISC" 9 | synopsis: "Simple public-key cryptography for the modern age" 10 | 11 | build: [ ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs ] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] 14 | 15 | depends: [ 16 | "conf-gmp-powm-sec" {build} 17 | "ocaml" {>= "4.13.0"} 18 | "dune" {>= "2.7"} 19 | "ounit2" {with-test} 20 | "randomconv" {with-test & >= "0.2.0"} 21 | "ohex" {with-test & >= "0.2.0"} 22 | "mirage-crypto" {=version} 23 | "mirage-crypto-rng" {=version} 24 | "digestif" {>= "1.2.0"} 25 | "zarith" {>= "1.13"} 26 | "eqaf" {>= "0.8"} 27 | ] 28 | conflicts: [ 29 | "ocaml-freestanding" 30 | ] 31 | description: """ 32 | Mirage-crypto-pk provides public-key cryptography (RSA, DSA, DH). 33 | """ 34 | x-maintenance-intent: [ "(latest)" ] 35 | -------------------------------------------------------------------------------- /src/aead.ml: -------------------------------------------------------------------------------- 1 | module type AEAD = sig 2 | val tag_size : int 3 | type key 4 | val of_secret : string -> key 5 | val authenticate_encrypt : key:key -> nonce:string -> ?adata:string -> 6 | string -> string 7 | val authenticate_decrypt : key:key -> nonce:string -> ?adata:string -> 8 | string -> string option 9 | val authenticate_encrypt_tag : key:key -> nonce:string -> ?adata:string -> 10 | string -> string * string 11 | val authenticate_decrypt_tag : key:key -> nonce:string -> ?adata:string -> 12 | tag:string -> string -> string option 13 | val authenticate_encrypt_into : key:key -> nonce:string -> 14 | ?adata:string -> string -> src_off:int -> bytes -> dst_off:int -> 15 | tag_off:int -> int -> unit 16 | val authenticate_decrypt_into : key:key -> nonce:string -> 17 | ?adata:string -> string -> src_off:int -> tag_off:int -> bytes -> 18 | dst_off:int -> int -> bool 19 | val unsafe_authenticate_encrypt_into : key:key -> nonce:string -> 20 | ?adata:string -> string -> src_off:int -> bytes -> dst_off:int -> 21 | tag_off:int -> int -> unit 22 | val unsafe_authenticate_decrypt_into : key:key -> nonce:string -> 23 | ?adata:string -> string -> src_off:int -> tag_off:int -> bytes -> 24 | dst_off:int -> int -> bool 25 | end 26 | -------------------------------------------------------------------------------- /mirage-crypto-rng.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/mirage/mirage-crypto" 3 | dev-repo: "git+https://github.com/mirage/mirage-crypto.git" 4 | bug-reports: "https://github.com/mirage/mirage-crypto/issues" 5 | doc: "https://mirage.github.io/mirage-crypto/doc" 6 | authors: ["David Kaloper " "Hannes Mehnert " ] 7 | maintainer: "Hannes Mehnert " 8 | license: "ISC" 9 | synopsis: "A cryptographically secure PRNG" 10 | 11 | build: [ ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs ] 13 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] 14 | 15 | depends: [ 16 | "ocaml" {>= "4.14.0"} 17 | "dune" {>= "2.7"} 18 | "dune-configurator" {>= "2.0.0"} 19 | "duration" 20 | "logs" 21 | "mirage-crypto" {=version} 22 | "digestif" {>= "1.1.4"} 23 | "ounit2" {with-test} 24 | "randomconv" {with-test & >= "0.2.0"} 25 | "ohex" {with-test & >= "0.2.0"} 26 | ] 27 | conflicts: [ "mirage-runtime" {< "3.8.0"} ] 28 | description: """ 29 | Mirage-crypto-rng provides a random number generator interface, and 30 | implementations: Fortuna, HMAC-DRBG, getrandom/getentropy based (in the unix 31 | sublibrary) 32 | """ 33 | x-maintenance-intent: [ "(latest)" ] 34 | -------------------------------------------------------------------------------- /mirage/unikernel.ml: -------------------------------------------------------------------------------- 1 | let start () = 2 | Logs.info (fun m -> m "using Fortuna, entropy sources: %a" 3 | Fmt.(list ~sep:(any ", ") Mirage_crypto_rng.Entropy.pp_source) 4 | (Mirage_crypto_rng.Entropy.sources ())) ; 5 | Logs.info (fun m -> m "64 byte random:@ %a" (Ohex.pp_hexdump ()) 6 | (Mirage_crypto_rng.generate 64)) ; 7 | let n = Bytes.(unsafe_to_string (create 32)) in 8 | let key = Mirage_crypto.Chacha20.of_secret n 9 | and nonce = Bytes.(unsafe_to_string (create 12)) 10 | in 11 | Logs.info (fun m -> m "Chacha20/Poly1305 of 32*0, key 32*0, nonce 12*0: %a" 12 | (Ohex.pp_hexdump ()) 13 | (Mirage_crypto.Chacha20.authenticate_encrypt ~key ~nonce n)); 14 | let key = Mirage_crypto_pk.Rsa.generate ~bits:4096 () in 15 | let signature = 16 | Mirage_crypto_pk.Rsa.PKCS1.sign ~hash:`SHA256 ~key (`Message n) 17 | in 18 | let verified = 19 | let key = Mirage_crypto_pk.Rsa.pub_of_priv key in 20 | let hashp = function `SHA256 -> true | _ -> false in 21 | Mirage_crypto_pk.Rsa.PKCS1.verify ~hashp ~key ~signature (`Message n) 22 | in 23 | Logs.info (fun m -> m "Generated a RSA key of %d bits (sign + verify %B)" 24 | (Mirage_crypto_pk.Rsa.priv_bits key) verified); 25 | Lwt.return_unit 26 | -------------------------------------------------------------------------------- /.github/workflows/windows.yml: -------------------------------------------------------------------------------- 1 | name: Crypto 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | tests: 7 | name: Tests 8 | 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | ocaml-version: ["4.14.2"] 13 | operating-system: [windows-latest] 14 | 15 | runs-on: ${{ matrix.operating-system }} 16 | 17 | steps: 18 | - name: Checkout code 19 | uses: actions/checkout@v4 20 | 21 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 22 | uses: ocaml/setup-ocaml@v3 23 | with: 24 | opam-repositories: | 25 | opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 26 | default: https://github.com/ocaml/opam-repository.git 27 | opam-local-packages: | 28 | *.opam 29 | !mirage-crypto-rng-miou-unix.opam 30 | ocaml-compiler: ${{ matrix.ocaml-version }} 31 | 32 | - name: Install dependencies 33 | run: opam install --deps-only -t mirage-crypto mirage-crypto-rng mirage-crypto-rng-mirage mirage-crypto-pk mirage-crypto-ec 34 | 35 | - name: Build 36 | run: opam exec -- dune build -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-mirage,mirage-crypto-pk,mirage-crypto-ec 37 | 38 | - name: Test 39 | run: opam exec -- dune runtest -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-mirage,mirage-crypto-pk,mirage-crypto-ec 40 | -------------------------------------------------------------------------------- /LICENSE.md.mirage-crypto-rng-mirage: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2016, Hannes Mehnert, Anil Madhavapeddy, David Kaloper Meršinjak 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /tests/test_numeric.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | open Mirage_crypto.Uncommon 4 | open Mirage_crypto_pk 5 | 6 | open Test_common 7 | 8 | let n_encode_decode_selftest ~typ ~bound n = 9 | typ ^ "selftest" >:: times ~n @@ fun _ -> 10 | let r = Z_extra.gen bound in 11 | let s = Z_extra.(of_octets_be @@ to_octets_be r) 12 | and t = Z_extra.(of_octets_be @@ to_octets_be ~size:24 r) in 13 | assert_equal r s; 14 | assert_equal r t 15 | 16 | let n_decode_reencode_selftest ~typ ~bytes n = 17 | typ ^ " selftest" >:: times ~n @@ fun _ -> 18 | let cs = Mirage_crypto_rng.generate bytes in 19 | let cs' = Z_extra.(to_octets_be ~size:bytes @@ of_octets_be cs) in 20 | assert_oct_equal cs cs' 21 | 22 | let random_n_selftest ~typ n bounds = 23 | typ ^ " selftest" >::: ( 24 | bounds |> List.map @@ fun (lo, hi) -> 25 | "selftest" >:: times ~n @@ fun _ -> 26 | let x = Z_extra.gen_r lo hi in 27 | if x < lo || x >= hi then assert_failure "range error" 28 | ) 29 | 30 | let int_safe_bytes = Sys.word_size // 8 - 1 31 | 32 | let suite = [ 33 | "Numeric extraction 1" >::: [ 34 | n_encode_decode_selftest 35 | ~typ:"z" ~bound:Z.(of_int64 Int64.max_int) 2000 ; 36 | ] ; 37 | 38 | "Numeric extraction 2" >::: [ 39 | n_decode_reencode_selftest ~typ:"z" ~bytes:37 2000 ; 40 | ]; 41 | 42 | "RNG extraction" >::: [ 43 | random_n_selftest ~typ:"Z" 1000 [ 44 | Z.(of_int 7, of_int 135); 45 | Z.(of_int 0, of_int 536870913); 46 | Z.(of_int 0, of_int64 2305843009213693953L) 47 | ] ; 48 | ] 49 | ] 50 | -------------------------------------------------------------------------------- /tests/test_entropy.ml: -------------------------------------------------------------------------------- 1 | 2 | let data = ref "" 3 | 4 | let cpu_bootstrap_check () = 5 | match Mirage_crypto_rng.Entropy.cpu_rng_bootstrap with 6 | | Error `Not_supported -> print_endline "no CPU RNG available" 7 | | Ok cpu_rng_bootstrap -> 8 | match cpu_rng_bootstrap 1 with 9 | | exception Failure _ -> print_endline "bad CPU RNG" 10 | | data' -> 11 | data := data'; 12 | for i = 0 to 10 do 13 | try 14 | let data' = cpu_rng_bootstrap 1 in 15 | if String.equal !data data' then begin 16 | Ohex.pp Format.std_formatter data'; 17 | failwith ("same data from CPU bootstrap at " ^ string_of_int i); 18 | end; 19 | data := data' 20 | with Failure _ -> print_endline ("CPU RNG failed at " ^ string_of_int i) 21 | done 22 | 23 | let whirlwind_bootstrap_check () = 24 | for i = 0 to 10 do 25 | let data' = Mirage_crypto_rng.Entropy.whirlwind_bootstrap 1 in 26 | if String.equal !data data' then begin 27 | Ohex.pp Format.std_formatter data'; 28 | failwith ("same data from whirlwind bootstrap at " ^ string_of_int i); 29 | end; 30 | data := data' 31 | done 32 | 33 | let timer_check () = 34 | for i = 0 to 10 do 35 | let data' = Mirage_crypto_rng.Entropy.interrupt_hook () in 36 | if String.equal !data data' then begin 37 | Ohex.pp Format.std_formatter data'; 38 | failwith ("same data from timer at " ^ string_of_int i); 39 | end; 40 | data := data' 41 | done 42 | 43 | let () = 44 | timer_check (); 45 | cpu_bootstrap_check (); 46 | whirlwind_bootstrap_check (); 47 | print_endline "test entropy OK" 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mirage-crypto - Cryptographic primitives for MirageOS 2 | 3 | %%VERSION%% 4 | 5 | mirage-crypto is a small cryptographic library that puts emphasis on the 6 | applicative style and ease of use. It includes basic ciphers (AES, 3DES, RC4, 7 | ChaCha20/Poly1305), AEAD primitives (AES-GCM, AES-CCM, ChaCha20/Poly1305), 8 | public-key primitives (RSA, DSA, DH), elliptic curves (NIST P-256, P-384, P-521, 9 | and curve 25519), and a strong RNG (Fortuna). 10 | 11 | RSA timing attacks are countered by blinding. AES timing attacks are avoided by 12 | delegating to AES-NI. 13 | 14 | Mirage-crypto is a fork of the 15 | [ocaml-nocrypto](https://github.com/mirleft/ocaml-nocrypto) written by David 16 | Kaloper. It was forked with the permission of the original author in order to 17 | facilitate changes (e.g. build system) required by Mirage that the upstream 18 | didn't have time to keep up with. 19 | 20 | Mirage-crypto-rng embeds the former mirage-entropy opam package, which 21 | implements various entropy sources: 22 | - non-deterministic execution time (used at initial seeding, see the [whirlwind RNG paper](https://www.ieee-security.org/TC/SP2014/papers/Not-So-RandomNumbersinVirtualizedLinuxandtheWhirlwindRNG.pdf)) 23 | - a hook into the Lwt event loop that collects a timestamp of each event 24 | - rdseed and rdrand (x86/x86-64 only) 25 | 26 | [API documentation online](https://mirage.github.io/mirage-crypto/doc) 27 | 28 | ## Build 29 | 30 | ```bash 31 | dune build 32 | dune runtest 33 | ``` 34 | 35 | ## FAQ 36 | 37 | #### RNG seeding 38 | 39 | If RNG fails with `Fatal error: exception Unseeded_generator`, you need to 40 | seed it. 41 | 42 | ```OCaml 43 | let () = Mirage_crypto_rng_unix.use_default () 44 | ``` 45 | -------------------------------------------------------------------------------- /src/cipher_stream.ml: -------------------------------------------------------------------------------- 1 | open Uncommon 2 | 3 | module type Stream = sig 4 | type key 5 | type result = { message : string ; key : key } 6 | val of_secret : string -> key 7 | val encrypt : key:key -> string -> result 8 | val decrypt : key:key -> string -> result 9 | end 10 | 11 | module ARC4 = struct 12 | 13 | type key = int * int * int array 14 | 15 | type result = { message : string ; key : key } 16 | 17 | let of_secret buf = 18 | let len = String.length buf in 19 | if len < 1 || len > 256 then invalid_arg "ARC4.of_secret: key size %d" len; 20 | let s = Array.init 256 (fun x -> x) in 21 | let rec loop j = function 22 | | 256 -> () 23 | | i -> 24 | let x = String.get_uint8 buf (i mod len) in 25 | let si = s.(i) in 26 | let j = (j + si + x) land 0xff in 27 | let sj = s.(j) in 28 | s.(i) <- sj ; s.(j) <- si ; 29 | (loop [@tailcall]) j (succ i) 30 | in 31 | ( loop 0 0 ; (0, 0, s) ) 32 | 33 | let encrypt ~key:(i, j, s') buf = 34 | let s = Array.copy s' 35 | and len = String.length buf in 36 | let res = Bytes.create len in 37 | let rec mix i j = function 38 | | n when n = len -> (i, j, s) 39 | | n -> 40 | let i = succ i land 0xff in 41 | let si = s.(i) in 42 | let j = (j + si) land 0xff in 43 | let sj = s.(j) in 44 | s.(i) <- sj ; s.(j) <- si ; 45 | let k = s.((si + sj) land 0xff) in 46 | Bytes.set_uint8 res n (k lxor String.get_uint8 buf n); 47 | (mix [@tailcall]) i j (succ n) 48 | in 49 | let key' = mix i j 0 in 50 | { key = key' ; message = Bytes.unsafe_to_string res } 51 | 52 | let decrypt = encrypt 53 | 54 | end 55 | -------------------------------------------------------------------------------- /rng/unix/mirage_crypto_rng_unix.mli: -------------------------------------------------------------------------------- 1 | (** {b RNG} seeding on {b Unix}. 2 | 3 | This module initializes a Fortuna RNG with [getrandom()], and CPU RNG. 4 | On BSD systems (FreeBSD, OpenBSD, macOS) [getentropy ()] is used instead 5 | of [getrandom ()]. On Windows 10 or higher, [BCryptGenRandom()] is used 6 | with the default RNG. Windows 8 or lower are not supported by this library. 7 | *) 8 | 9 | (** [initialize ~g rng] will bring the RNG into a working state. *) 10 | val initialize : ?g:'a -> 'a Mirage_crypto_rng.generator -> unit 11 | [@@deprecated "Use 'Mirage_crypto_rng_unix.use_default ()' instead."] 12 | 13 | (** [getrandom size] returns a buffer of [size] filled with random bytes. *) 14 | val getrandom : int -> string 15 | 16 | (** A generator that opens /dev/urandom and reads from that file descriptor 17 | data whenever random data is needed. The file descriptor is closed in 18 | [at_exit]. *) 19 | module Urandom : Mirage_crypto_rng.Generator 20 | 21 | (** A generator using [getrandom(3)] on Linux, [getentropy(3)] on BSD and macOS, 22 | and [BCryptGenRandom()] on Windows. *) 23 | module Getentropy : Mirage_crypto_rng.Generator 24 | 25 | (** [use_default ()] initializes the RNG [Mirage_crypto_rng.default_generator] 26 | with a sensible default, at the moment using [Getentropy]. *) 27 | val use_default : unit -> unit 28 | 29 | (** [use_dev_random ()] initializes the RNG 30 | [Mirage_crypto_rng.default_generator] with the [Urandom] generator. This 31 | raises an exception if "/dev/urandom" cannot be opened. *) 32 | val use_dev_urandom : unit -> unit 33 | 34 | (** [use_getentropy ()] initializes the RNG [Mirage_crypto_rng.default_generator] 35 | with the [Getentropy] generator. *) 36 | val use_getentropy : unit -> unit 37 | -------------------------------------------------------------------------------- /rng/unix/mirage_crypto_rng_unix.ml: -------------------------------------------------------------------------------- 1 | open Mirage_crypto_rng 2 | 3 | module Urandom = Urandom 4 | 5 | module Getentropy = Getentropy 6 | 7 | let use_dev_urandom () = 8 | let g = create (module Urandom) in 9 | set_default_generator g 10 | 11 | let use_getentropy () = 12 | let g = create (module Getentropy) in 13 | set_default_generator g 14 | 15 | let use_default () = use_getentropy () 16 | 17 | let src = Logs.Src.create "mirage-crypto-rng.unix" ~doc:"Mirage crypto RNG Unix" 18 | module Log = (val Logs.src_log src : Logs.LOG) 19 | 20 | external getrandom_buf : bytes -> int -> int -> unit = "mc_getrandom" [@@noalloc] 21 | 22 | let getrandom_into buf ~off ~len = 23 | getrandom_buf buf off len 24 | 25 | let getrandom size = 26 | let buf = Bytes.create size in 27 | getrandom_into buf ~off:0 ~len:size; 28 | Bytes.unsafe_to_string buf 29 | 30 | let getrandom_init i = 31 | let data = getrandom 128 in 32 | Entropy.header i data 33 | 34 | let running = Atomic.make false 35 | 36 | let initialize (type a) ?g (rng : a generator) = 37 | if Atomic.get running then 38 | Log.debug 39 | (fun m -> m "Mirage_crypto_rng_unix.initialize has already been called, \ 40 | ignoring this call.") 41 | else begin 42 | (try 43 | let _ = default_generator () in 44 | Log.warn (fun m -> m "Mirage_crypto_rng.default_generator has already \ 45 | been set, check that this call is intentional"); 46 | with 47 | No_default_generator -> ()); 48 | Atomic.set running true ; 49 | let seed = 50 | let init = 51 | Entropy.[ bootstrap ; whirlwind_bootstrap ; bootstrap ; getrandom_init ] 52 | in 53 | List.mapi (fun i f -> f i) init |> String.concat "" 54 | in 55 | let _ = Entropy.register_source "getrandom" in 56 | set_default_generator (create ?g ~seed rng) 57 | end 58 | -------------------------------------------------------------------------------- /rng/hmac_drbg.ml: -------------------------------------------------------------------------------- 1 | module Make (H : Digestif.S) = struct 2 | type g = 3 | { mutable k : string 4 | ; mutable v : string 5 | ; mutable seeded : bool 6 | } 7 | 8 | let block = H.digest_size 9 | 10 | let (bx00, bx01) = "\x00", "\x01" 11 | 12 | let k0 = String.make H.digest_size '\x00' 13 | and v0 = String.make H.digest_size '\x01' 14 | 15 | let create ?time:_ () = { k = k0 ; v = v0 ; seeded = false } 16 | 17 | let seeded ~g = g.seeded 18 | 19 | let reseed ~g buf = 20 | let (k, v) = (g.k, g.v) in 21 | let k = H.hmac_string ~key:k @@ String.concat "" [v; bx00; buf] |> H.to_raw_string in 22 | let v = H.hmac_string ~key:k v |> H.to_raw_string in 23 | let k = H.hmac_string ~key:k @@ String.concat "" [v; bx01; buf] |> H.to_raw_string in 24 | let v = H.hmac_string ~key:k v |> H.to_raw_string in 25 | g.k <- k ; g.v <- v ; g.seeded <- true 26 | 27 | let generate_into ~g buf ~off len = 28 | if not g.seeded then raise Rng.Unseeded_generator ; 29 | let rec go off k v = function 30 | | 0 -> v 31 | | 1 -> 32 | let v = H.hmac_string ~key:k v |> H.to_raw_string in 33 | let len = 34 | let rem = len mod H.digest_size in 35 | if rem = 0 then H.digest_size else rem 36 | in 37 | Bytes.unsafe_blit_string v 0 buf off len; 38 | v 39 | | i -> 40 | let v = H.hmac_string ~key:k v |> H.to_raw_string in 41 | Bytes.unsafe_blit_string v 0 buf off H.digest_size; 42 | go (off + H.digest_size) k v (pred i) 43 | in 44 | let v = go off g.k g.v Mirage_crypto.Uncommon.(len // H.digest_size) in 45 | g.k <- H.hmac_string ~key:g.k (v ^ bx00) |> H.to_raw_string; 46 | g.v <- H.hmac_string ~key:g.k v |> H.to_raw_string 47 | 48 | (* XXX *) 49 | let accumulate ~g:_ = invalid_arg "Implement Hmac_drbg.accumulate..." 50 | 51 | let pools = 0 52 | end 53 | -------------------------------------------------------------------------------- /ec/native/inversion_template.h: -------------------------------------------------------------------------------- 1 | #define MAKE_FN_NAME1(x,y) x ## y 2 | #define MAKE_FN_NAME(x,y) MAKE_FN_NAME1(x,y) 3 | 4 | #define PRECOMP MAKE_FN_NAME(CURVE_DESCRIPTION,_divstep_precomp) 5 | #define MSAT MAKE_FN_NAME(CURVE_DESCRIPTION,_msat) 6 | #define MONE MAKE_FN_NAME(CURVE_DESCRIPTION,_set_one) 7 | #define DIVSTEP MAKE_FN_NAME(CURVE_DESCRIPTION,_divstep) 8 | #define OPP MAKE_FN_NAME(CURVE_DESCRIPTION,_opp) 9 | #define MUL MAKE_FN_NAME(CURVE_DESCRIPTION,_mul) 10 | #define SZNZ MAKE_FN_NAME(CURVE_DESCRIPTION,_selectznz) 11 | 12 | #if LEN_PRIME < 46 13 | #define ITERATIONS (((49 * LEN_PRIME) + 80) / 17) 14 | #else 15 | #define ITERATIONS (((49 * LEN_PRIME) + 57) / 17) 16 | #endif 17 | 18 | #define SAT_LIMBS LIMBS + 1 /* we might need 2 more bits to represent m in twos complement */ 19 | #define BYTES 8 * (((LEN_PRIME - 1) / 64) + 1) 20 | 21 | static void inverse(WORD out[LIMBS], WORD g[SAT_LIMBS]) { 22 | 23 | WORD precomp[LIMBS]; 24 | PRECOMP(precomp); 25 | 26 | WORD d = 1; 27 | WORD f[SAT_LIMBS]; 28 | WORD v[LIMBS]; 29 | WORD r[LIMBS]; 30 | WORD out1; 31 | WORD out2[SAT_LIMBS], out3[SAT_LIMBS], out4[LIMBS], out5[LIMBS]; 32 | 33 | MSAT(f); 34 | MONE(r); 35 | for (int j = 0; j < LIMBS; j++) v[j] = 0; 36 | 37 | for (int i = 0; i < ITERATIONS - (ITERATIONS % 2); i+=2) { 38 | DIVSTEP(&out1,out2,out3,out4,out5,d,f,g,v,r); 39 | DIVSTEP(&d,f,g,v,r,out1,out2,out3,out4,out5); 40 | } 41 | if (ITERATIONS % 2) { 42 | DIVSTEP(&out1,out2,out3,out4,out5,d,f,g,v,r); 43 | for (int k = 0; k < LIMBS; k++) v[k] = out4[k]; 44 | for (int k = 0; k < SAT_LIMBS; k++) f[k] = out2[k]; 45 | } 46 | 47 | WORD h[LIMBS]; 48 | OPP(h, v); 49 | SZNZ(v, f[SAT_LIMBS -1 ] >> (WORDSIZE - 1), v, h); 50 | MUL(out, v, precomp); 51 | 52 | return; 53 | } 54 | 55 | static void inversion (WORD out[LIMBS], const WORD in[LIMBS]) { 56 | WORD in_[SAT_LIMBS]; 57 | for (int i = 0; i < LIMBS; i++) in_[i] = in[i]; 58 | in_[LIMBS] = 0; 59 | inverse(out, in_); 60 | return; 61 | } 62 | -------------------------------------------------------------------------------- /src/native/chacha.c: -------------------------------------------------------------------------------- 1 | /* Based on https://github.com/abeaumont/ocaml-chacha.git */ 2 | 3 | #include "mirage_crypto.h" 4 | 5 | extern void mc_chacha_core_generic(int count, const uint32_t *src, uint32_t *dst); 6 | 7 | #ifdef __mc_ACCELERATE__ 8 | 9 | static inline void mc_chacha_quarterround(uint32_t *x, int a, int b, int c, int d) { 10 | x[a] += x[b]; x[d] = rol32(x[d] ^ x[a], 16); 11 | x[c] += x[d]; x[b] = rol32(x[b] ^ x[c], 12); 12 | x[a] += x[b]; x[d] = rol32(x[d] ^ x[a], 8); 13 | x[c] += x[d]; x[b] = rol32(x[b] ^ x[c], 7); 14 | } 15 | 16 | static void mc_chacha_core(int count, const uint32_t *src, uint32_t *dst) { 17 | uint32_t x[16]; 18 | cpu_to_le32_array(x, src, 16); 19 | for (int i = 0; i < count; i++) { 20 | mc_chacha_quarterround(x, 0, 4, 8, 12); 21 | mc_chacha_quarterround(x, 1, 5, 9, 13); 22 | mc_chacha_quarterround(x, 2, 6, 10, 14); 23 | mc_chacha_quarterround(x, 3, 7, 11, 15); 24 | 25 | mc_chacha_quarterround(x, 0, 5, 10, 15); 26 | mc_chacha_quarterround(x, 1, 6, 11, 12); 27 | mc_chacha_quarterround(x, 2, 7, 8, 13); 28 | mc_chacha_quarterround(x, 3, 4, 9, 14); 29 | } 30 | for (int i = 0; i < 16; i++) { 31 | uint32_t xi = x[i]; 32 | uint32_t hj = cpu_to_le32(src[i]); 33 | dst[i] = le32_to_cpu(xi + hj); 34 | } 35 | } 36 | 37 | CAMLprim value 38 | mc_chacha_round(value count, value src, value dst, value off) 39 | { 40 | _mc_switch_accel(ssse3, 41 | mc_chacha_core_generic(Int_val(count), (const uint32_t *)(String_val(src)), (uint32_t *)(Bytes_val(dst) + Long_val(off))), 42 | mc_chacha_core(Int_val(count), (const uint32_t *)(String_val(src)), (uint32_t *)(Bytes_val(dst) + Long_val(off)))); 43 | return Val_unit; 44 | } 45 | 46 | #else //#ifdef __mc_ACCELERATE__ 47 | 48 | CAMLprim value 49 | mc_chacha_round(value count, value src, value dst, value off) 50 | { 51 | mc_chacha_core_generic(Int_val(count), (const uint32_t *)(String_val(src)), (uint32_t *)(Bytes_val(dst) + Long_val(off))); 52 | return Val_unit; 53 | } 54 | 55 | #endif 56 | -------------------------------------------------------------------------------- /mirage-crypto-ec.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Elliptic Curve Cryptography with primitives taken from Fiat" 3 | description: """ 4 | An implementation of key exchange (ECDH) and digital signature (ECDSA/EdDSA) 5 | algorithms using code from Fiat (). 6 | 7 | The curves P256 (SECP256R1), P384 (SECP384R1), 8 | P521 (SECP521R1), and 25519 (X25519, Ed25519) are implemented by this package. 9 | """ 10 | maintainer: "Hannes Mehnert " 11 | authors: [ 12 | "Hannes Mehnert " 13 | "Nathan Rebours " 14 | "Clément Pascutto " 15 | "Etienne Millon " 16 | "Virgile Robles " 17 | # and from the fiat-crypto AUTHORS file 18 | "Andres Erbsen " 19 | "Google Inc." 20 | "Jade Philipoom " 21 | "Massachusetts Institute of Technology" 22 | "Zoe Paraskevopoulou " 23 | ] 24 | license: "MIT" 25 | homepage: "https://github.com/mirage/mirage-crypto" 26 | doc: "https://mirage.github.io/mirage-crypto/doc" 27 | bug-reports: "https://github.com/mirage/mirage-crypto/issues" 28 | depends: [ 29 | "dune" {>= "2.7"} 30 | "ocaml" {>= "4.13.0"} 31 | "dune-configurator" 32 | "eqaf" {>= "0.7"} 33 | "mirage-crypto-rng" {=version} 34 | "digestif" {>= "1.2.0"} 35 | "alcotest" {with-test & >= "0.8.1"} 36 | "ppx_deriving_yojson" {with-test} 37 | "ppx_deriving" {with-test} 38 | "yojson" {with-test & >= "1.6.0"} 39 | "asn1-combinators" {with-test & >= "0.3.1"} 40 | "ohex" {with-test & >= "0.2.0"} 41 | "ounit2" {with-test} 42 | ] 43 | conflicts: [ 44 | "ocaml-freestanding" 45 | ] 46 | build: [ 47 | ["dune" "subst"] {dev} 48 | ["dune" "build" "-p" name "-j" jobs] 49 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 50 | ] 51 | dev-repo: "git+https://github.com/mirage/mirage-crypto.git" 52 | tags: ["org:mirage"] 53 | x-maintenance-intent: [ "(latest)" ] 54 | -------------------------------------------------------------------------------- /rng/mirage/mirage_crypto_rng_mirage.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Hannes Mehnert 3 | * Copyright (c) 2014 Anil Madhavapeddy 4 | * Copyright (c) 2014-2016 David Kaloper Meršinjak 5 | * All rights reserved. 6 | * 7 | * Redistribution and use in source and binary forms, with or without 8 | * modification, are permitted provided that the following conditions are met: 9 | * 10 | * * Redistributions of source code must retain the above copyright notice, this 11 | * list of conditions and the following disclaimer. 12 | * 13 | * * Redistributions in binary form must reproduce the above copyright notice, 14 | * this list of conditions and the following disclaimer in the documentation 15 | * and/or other materials provided with the distribution. 16 | * 17 | * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | *) 28 | 29 | val initialize : 30 | ?g:'a -> ?sleep:int64 -> 'a Mirage_crypto_rng.generator -> unit Lwt.t 31 | (** [initialize ~g ~sleep generator] sets the default generator to the 32 | [generator] and sets up periodic entropy feeding for that rng. This 33 | function fails ([Lwt.fail]) if it is called a second time. The argument 34 | [~sleep] is measured in ns, and used as sleep between cpu assisted random 35 | number collection. It defaults to one second. *) 36 | -------------------------------------------------------------------------------- /tests/test_common.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let (prf, strf) = Format.(fprintf, asprintf) 4 | let pp_map pp f ppf x = pp ppf (f x) 5 | let pp_diff pp ppf (a, b) = prf ppf "@[want: %a@,have: %a@]" pp a pp b 6 | 7 | let of_hex ?(skip_ws = true) s = 8 | let fold f acc str = 9 | let st = ref acc in 10 | String.iter (fun c -> st := f !st c) str; 11 | !st 12 | and digit c = 13 | match c with 14 | | '0'..'9' -> int_of_char c - 0x30 15 | | 'A'..'F' -> int_of_char c - 0x41 + 10 16 | | 'a'..'f' -> int_of_char c - 0x61 + 10 17 | | _ -> invalid_arg "bad character" 18 | and is_space = function 19 | | ' ' | '\012' | '\n' | '\r' | '\t' -> true 20 | | _ -> false 21 | in 22 | let chars, leftover = 23 | fold (fun (chars, leftover) c -> 24 | if skip_ws && is_space c then 25 | chars, leftover 26 | else 27 | let c = digit c in 28 | match leftover with 29 | | None -> chars, Some (c lsl 4) 30 | | Some c' -> (c' lor c) :: chars, None) 31 | ([], None) s 32 | in 33 | let chars = List.rev chars in 34 | assert (leftover = None); 35 | String.init (List.length chars) (fun i -> char_of_int (List.nth chars i)) 36 | 37 | let rec range a b = 38 | if a > b then [] else a :: range (succ a) b 39 | 40 | let rec times ~n f a = 41 | if n > 0 then ( ignore (f a) ; times ~n:(pred n) f a ) 42 | 43 | let pp_opt pp ppf = Format.(function 44 | | Some x -> fprintf ppf "Some(%a)" pp x 45 | | None -> fprintf ppf "None") 46 | 47 | let eq_opt eq a b = match (a, b) with 48 | | (Some x, Some y) -> eq x y 49 | | _ -> false 50 | 51 | let pp_octets pp = pp (Ohex.pp_hexdump ()) 52 | 53 | let assert_oct_equal ?msg = 54 | assert_equal ~cmp:String.equal ?msg ~pp_diff:(pp_octets pp_diff) 55 | 56 | let iter_list xs f = List.iter f xs 57 | 58 | let cases_of f = 59 | List.map @@ fun params -> test_case (f params) 60 | 61 | let any _ = true 62 | 63 | let vx = Ohex.decode 64 | 65 | let f1_eq ?msg f (a, b) _ = 66 | assert_oct_equal ?msg (f (vx a)) (vx b) 67 | 68 | let f2_eq ?msg f (a, b, c) = f1_eq ?msg (f (vx a)) (b, c) 69 | -------------------------------------------------------------------------------- /tests/wycheproof/wycheproof.mli: -------------------------------------------------------------------------------- 1 | type json 2 | 3 | type hex = string [@@deriving eq] 4 | 5 | val pp_hex : Format.formatter -> hex -> unit 6 | 7 | type test_result = Valid | Acceptable | Invalid [@@deriving show] 8 | 9 | type ecdh_test = { 10 | tcId : int; 11 | comment : string; 12 | curve : json option; 13 | public : hex; 14 | private_ : hex; 15 | shared : hex; 16 | result : test_result; 17 | flags : string list; 18 | } 19 | [@@deriving show] 20 | 21 | val has_ignored_flag : ecdh_test -> ignored_flags:string list -> bool 22 | 23 | type ecdh_test_group = { 24 | curve : string; 25 | tests : ecdh_test list; 26 | encoding : json option; 27 | type_ : json option; 28 | } 29 | [@@deriving show] 30 | 31 | type ecdsa_key = { 32 | curve : string; 33 | keySize : int; 34 | type_ : json; 35 | uncompressed : hex; 36 | wx : hex; 37 | wy : hex; 38 | } 39 | [@@deriving show] 40 | 41 | type dsa_test = { 42 | tcId : int; 43 | comment : string; 44 | msg : hex; 45 | sig_ : hex; 46 | result : test_result; 47 | flags : string list; 48 | } 49 | [@@deriving show] 50 | 51 | type ecdsa_test_group = { 52 | key : ecdsa_key; 53 | keyDer : string; 54 | keyPem : string; 55 | sha : string; 56 | tests : dsa_test list; 57 | type_ : json option; 58 | } 59 | [@@deriving show] 60 | 61 | type eddsa_key = { 62 | curve : string; 63 | keySize : int; 64 | pk : hex; 65 | sk : hex; 66 | type_ : json; [@yojson.key "type"] 67 | } 68 | [@@deriving of_yojson, show] 69 | 70 | type eddsa_test_group = { 71 | jwk : json; 72 | key : eddsa_key; 73 | keyDer : string; 74 | keyPem : string; 75 | type_ : json; [@yojson.key "type"] 76 | tests : dsa_test list; 77 | } 78 | [@@deriving of_yojson, show] 79 | 80 | type test_file = { 81 | algorithm : json; 82 | generatorVersion : json; 83 | header : json; 84 | notes : json; 85 | numberOfTests : json; 86 | schema : json; 87 | testGroups : json list; 88 | } 89 | [@@deriving show] 90 | 91 | val load_file_exn : string -> test_file 92 | 93 | val ecdh_test_group_exn : json -> ecdh_test_group 94 | 95 | val ecdsa_test_group_exn : json -> ecdsa_test_group 96 | 97 | val eddsa_test_group_exn : json -> eddsa_test_group 98 | -------------------------------------------------------------------------------- /src/native/detect_cpu_features.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | #ifdef __mc_detect_features__ 4 | 5 | #ifndef _MSC_VER 6 | # include 7 | #endif 8 | 9 | struct _mc_cpu_features mc_detected_cpu_features = { 0 }; 10 | 11 | #ifdef _MSC_VER 12 | #define bit_PCLMUL ((int)1 << 1) 13 | #define bit_SSSE3 ((int)1 << 9) 14 | #define bit_AES ((int)1 << 25) 15 | #define bit_RDRND ((int)1 << 30) 16 | #define bit_RDSEED ((int)1 << 18) 17 | 18 | CAMLprim value 19 | mc_detect_cpu_features (__unit ()) { 20 | int cpuInfo[4] = {-1}; 21 | int ebx; 22 | int ecx; 23 | 24 | __cpuid(cpuInfo, 0x00000000); 25 | int max = cpuInfo[0]; 26 | if (max < 1) return Val_unit; 27 | 28 | __cpuid(cpuInfo, 0x00000001); 29 | ecx = cpuInfo[2]; 30 | 31 | if (ecx & bit_PCLMUL) 32 | mc_detected_cpu_features.pclmul = 1; 33 | if (ecx & bit_SSSE3) 34 | mc_detected_cpu_features.ssse3 = 1; 35 | if (ecx & bit_AES) 36 | mc_detected_cpu_features.aesni = 1; 37 | if (ecx & bit_RDRND) 38 | mc_detected_cpu_features.rdrand = 1; 39 | 40 | if (max > 7) { 41 | __cpuid(cpuInfo, 0x00000007); 42 | ebx = cpuInfo[1]; 43 | if (ebx & bit_RDSEED) 44 | mc_detected_cpu_features.rdseed = 1; 45 | } 46 | 47 | return Val_unit; 48 | } 49 | 50 | #else 51 | 52 | CAMLprim value 53 | mc_detect_cpu_features (__unit ()) { 54 | unsigned int sig = 0, eax = 0, ebx = 0, ecx = 0, edx = 0; 55 | 56 | int max = __get_cpuid_max(0, &sig); 57 | 58 | if (max < 1) return Val_unit; 59 | 60 | __cpuid(1, eax, ebx, ecx, edx); 61 | if (ecx & bit_PCLMUL) 62 | mc_detected_cpu_features.pclmul = 1; 63 | if (ecx & bit_SSSE3) 64 | mc_detected_cpu_features.ssse3 = 1; 65 | if (ecx & bit_AES) 66 | mc_detected_cpu_features.aesni = 1; 67 | if (ecx & bit_RDRND) 68 | mc_detected_cpu_features.rdrand = 1; 69 | 70 | if (max > 7) { 71 | __cpuid_count(7, 0, eax, ebx, ecx, edx); 72 | if (ebx & bit_RDSEED) 73 | mc_detected_cpu_features.rdseed = 1; 74 | } 75 | 76 | return Val_unit; 77 | } 78 | #endif /* _MSC_VER */ 79 | 80 | #else /* __mc_detect_features__ */ 81 | 82 | CAMLprim value 83 | mc_detect_cpu_features (__unit ()) { 84 | return Val_unit; 85 | } 86 | 87 | #endif /* __mc_detect_features__ */ 88 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_common) 3 | (libraries mirage-crypto ounit2 ohex) 4 | (modules test_common) 5 | (optional)) 6 | 7 | (test 8 | (name test_symmetric_runner) 9 | (libraries test_common mirage-crypto ounit2) 10 | (package mirage-crypto) 11 | (modules test_base test_cipher test_symmetric_runner)) 12 | 13 | (test 14 | (name test_random_runner) 15 | (libraries test_common mirage-crypto mirage-crypto-rng mirage-crypto-rng.unix 16 | randomconv ounit2) 17 | (package mirage-crypto-rng) 18 | (modules test_random_runner)) 19 | 20 | (test 21 | (name test_pk_runner) 22 | (libraries test_common mirage-crypto-pk mirage-crypto-rng.unix randomconv 23 | ounit2) 24 | (package mirage-crypto-pk) 25 | (modules test_numeric test_dh test_dsa test_rsa test_pk_runner)) 26 | 27 | (test 28 | (name test_entropy_collection) 29 | (modules test_entropy_collection) 30 | (package mirage-crypto-rng-mirage) 31 | (libraries mirage-crypto-rng-mirage mirage-unix duration ohex)) 32 | 33 | (test 34 | (name test_entropy) 35 | (modules test_entropy) 36 | (package mirage-crypto-rng) 37 | (libraries mirage-crypto-rng ohex) 38 | (enabled_if (and (<> %{architecture} "arm64") (<> %{architecture} "riscv64")))) 39 | ; see https://github.com/mirage/mirage-crypto/issues/216 40 | 41 | (test 42 | (name test_ec) 43 | (modules test_ec) 44 | (libraries test_common alcotest mirage-crypto-ec mirage-crypto-rng.unix) 45 | (package mirage-crypto-ec)) 46 | 47 | (test 48 | (name test_ec_wycheproof) 49 | (modules test_ec_wycheproof) 50 | (deps ecdh_secp256r1_test.json ecdsa_secp256r1_sha256_test.json 51 | ecdsa_secp256r1_sha512_test.json ecdh_secp384r1_test.json 52 | ecdsa_secp384r1_sha384_test.json ecdsa_secp384r1_sha512_test.json 53 | ecdh_secp521r1_test.json ecdsa_secp521r1_sha512_test.json 54 | x25519_test.json eddsa_test.json) 55 | (libraries alcotest mirage-crypto-ec wycheproof digestif asn1-combinators) 56 | (package mirage-crypto-ec)) 57 | 58 | (tests 59 | (names test_miou_rng test_miou_entropy_collection) 60 | (modules test_miou_rng test_miou_entropy_collection) 61 | (libraries mirage-crypto-rng-miou-unix duration ohex) 62 | (package mirage-crypto-rng-miou-unix) 63 | (enabled_if (<> %{os_type} "Win32"))) 64 | -------------------------------------------------------------------------------- /ec/native/np256_stubs.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | /* Microsoft compiler does not support 128-bit integers. Drop down to 4 | * 32-bit for MSVC. 5 | */ 6 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 7 | #include "np256_64.h" 8 | #define LIMBS 4 9 | #define WORD uint64_t 10 | #define WORDSIZE 64 11 | #else 12 | #include "np256_32.h" 13 | #define LIMBS 8 14 | #define WORD uint32_t 15 | #define WORDSIZE 32 16 | #endif 17 | 18 | #define LEN_PRIME 256 19 | #define CURVE_DESCRIPTION fiat_np256 20 | 21 | #include "inversion_template.h" 22 | 23 | #include 24 | 25 | CAMLprim value mc_np256_inv(value out, value in) 26 | { 27 | CAMLparam2(out, in); 28 | inversion((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 29 | CAMLreturn(Val_unit); 30 | } 31 | 32 | CAMLprim value mc_np256_mul(value out, value a, value b) 33 | { 34 | CAMLparam3(out, a, b); 35 | fiat_np256_mul((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 36 | CAMLreturn(Val_unit); 37 | } 38 | 39 | CAMLprim value mc_np256_add(value out, value a, value b) 40 | { 41 | CAMLparam3(out, a, b); 42 | fiat_np256_add((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 43 | CAMLreturn(Val_unit); 44 | } 45 | 46 | CAMLprim value mc_np256_one(value out) 47 | { 48 | CAMLparam1(out); 49 | fiat_np256_set_one((WORD*)Bytes_val(out)); 50 | CAMLreturn(Val_unit); 51 | } 52 | 53 | CAMLprim value mc_np256_from_bytes(value out, value in) 54 | { 55 | CAMLparam2(out, in); 56 | fiat_np256_from_bytes((WORD*)Bytes_val(out), _st_uint8(in)); 57 | CAMLreturn(Val_unit); 58 | } 59 | 60 | CAMLprim value mc_np256_to_bytes(value out, value in) 61 | { 62 | CAMLparam2(out, in); 63 | fiat_np256_to_bytes(Bytes_val(out), (const WORD*)String_val(in)); 64 | CAMLreturn(Val_unit); 65 | } 66 | 67 | CAMLprim value mc_np256_from_montgomery(value out, value in) 68 | { 69 | CAMLparam2(out, in); 70 | fiat_np256_from_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 71 | CAMLreturn(Val_unit); 72 | } 73 | 74 | CAMLprim value mc_np256_to_montgomery(value out, value in) 75 | { 76 | CAMLparam2(out, in); 77 | fiat_np256_to_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 78 | CAMLreturn(Val_unit); 79 | } 80 | -------------------------------------------------------------------------------- /ec/native/np384_stubs.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | /* Microsoft compiler does not support 128-bit integers. Drop down to 4 | * 32-bit for MSVC. 5 | */ 6 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 7 | #include "np384_64.h" 8 | #define LIMBS 6 9 | #define WORD uint64_t 10 | #define WORDSIZE 64 11 | #else 12 | #include "np384_32.h" 13 | #define LIMBS 12 14 | #define WORD uint32_t 15 | #define WORDSIZE 32 16 | #endif 17 | 18 | #define LEN_PRIME 384 19 | #define CURVE_DESCRIPTION fiat_np384 20 | 21 | #include "inversion_template.h" 22 | 23 | #include 24 | 25 | CAMLprim value mc_np384_inv(value out, value in) 26 | { 27 | CAMLparam2(out, in); 28 | inversion((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 29 | CAMLreturn(Val_unit); 30 | } 31 | 32 | CAMLprim value mc_np384_mul(value out, value a, value b) 33 | { 34 | CAMLparam3(out, a, b); 35 | fiat_np384_mul((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 36 | CAMLreturn(Val_unit); 37 | } 38 | 39 | CAMLprim value mc_np384_add(value out, value a, value b) 40 | { 41 | CAMLparam3(out, a, b); 42 | fiat_np384_add((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 43 | CAMLreturn(Val_unit); 44 | } 45 | 46 | CAMLprim value mc_np384_one(value out) 47 | { 48 | CAMLparam1(out); 49 | fiat_np384_set_one((WORD*)Bytes_val(out)); 50 | CAMLreturn(Val_unit); 51 | } 52 | 53 | CAMLprim value mc_np384_from_bytes(value out, value in) 54 | { 55 | CAMLparam2(out, in); 56 | fiat_np384_from_bytes((WORD*)Bytes_val(out), _st_uint8(in)); 57 | CAMLreturn(Val_unit); 58 | } 59 | 60 | CAMLprim value mc_np384_to_bytes(value out, value in) 61 | { 62 | CAMLparam2(out, in); 63 | fiat_np384_to_bytes(Bytes_val(out), (const WORD*)String_val(in)); 64 | CAMLreturn(Val_unit); 65 | } 66 | 67 | CAMLprim value mc_np384_from_montgomery(value out, value in) 68 | { 69 | CAMLparam2(out, in); 70 | fiat_np384_from_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 71 | CAMLreturn(Val_unit); 72 | } 73 | 74 | CAMLprim value mc_np384_to_montgomery(value out, value in) 75 | { 76 | CAMLparam2(out, in); 77 | fiat_np384_to_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 78 | CAMLreturn(Val_unit); 79 | } 80 | -------------------------------------------------------------------------------- /ec/native/np521_stubs.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | /* Microsoft compiler does not support 128-bit integers. Drop down to 4 | * 32-bit for MSVC. 5 | */ 6 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 7 | #include "np521_64.h" 8 | #define LIMBS 9 9 | #define WORD uint64_t 10 | #define WORDSIZE 64 11 | #else 12 | #include "np521_32.h" 13 | #define LIMBS 17 14 | #define WORD uint32_t 15 | #define WORDSIZE 32 16 | #endif 17 | 18 | #define LEN_PRIME 521 19 | #define CURVE_DESCRIPTION fiat_np521 20 | 21 | #include "inversion_template.h" 22 | 23 | #include 24 | 25 | CAMLprim value mc_np521_inv(value out, value in) 26 | { 27 | CAMLparam2(out, in); 28 | inversion((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 29 | CAMLreturn(Val_unit); 30 | } 31 | 32 | CAMLprim value mc_np521_mul(value out, value a, value b) 33 | { 34 | CAMLparam3(out, a, b); 35 | fiat_np521_mul((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 36 | CAMLreturn(Val_unit); 37 | } 38 | 39 | CAMLprim value mc_np521_add(value out, value a, value b) 40 | { 41 | CAMLparam3(out, a, b); 42 | fiat_np521_add((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 43 | CAMLreturn(Val_unit); 44 | } 45 | 46 | CAMLprim value mc_np521_one(value out) 47 | { 48 | CAMLparam1(out); 49 | fiat_np521_set_one((WORD*)Bytes_val(out)); 50 | CAMLreturn(Val_unit); 51 | } 52 | 53 | CAMLprim value mc_np521_from_bytes(value out, value in) 54 | { 55 | CAMLparam2(out, in); 56 | fiat_np521_from_bytes((WORD*)Bytes_val(out), _st_uint8(in)); 57 | CAMLreturn(Val_unit); 58 | } 59 | 60 | CAMLprim value mc_np521_to_bytes(value out, value in) 61 | { 62 | CAMLparam2(out, in); 63 | fiat_np521_to_bytes(Bytes_val(out), (const WORD*)String_val(in)); 64 | CAMLreturn(Val_unit); 65 | } 66 | 67 | CAMLprim value mc_np521_from_montgomery(value out, value in) 68 | { 69 | CAMLparam2(out, in); 70 | fiat_np521_from_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 71 | CAMLreturn(Val_unit); 72 | } 73 | 74 | CAMLprim value mc_np521_to_montgomery(value out, value in) 75 | { 76 | CAMLparam2(out, in); 77 | fiat_np521_to_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 78 | CAMLreturn(Val_unit); 79 | } 80 | 81 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Crypto 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | tests: 7 | name: Tests 8 | 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | ocaml-version: ["4.14.2"] 13 | operating-system: [macos-latest, ubuntu-latest] 14 | 15 | runs-on: ${{ matrix.operating-system }} 16 | 17 | steps: 18 | - name: Checkout code 19 | uses: actions/checkout@v4 20 | 21 | - name: Use OCaml ${{ matrix.ocaml-version }} 22 | uses: ocaml/setup-ocaml@v3 23 | with: 24 | opam-local-packages: | 25 | *.opam 26 | !mirage-crypto-rng-miou-unix.opam 27 | ocaml-compiler: ${{ matrix.ocaml-version }} 28 | 29 | - name: Install dependencies 30 | run: opam install --deps-only -t mirage-crypto mirage-crypto-rng mirage-crypto-rng-mirage mirage-crypto-pk mirage-crypto-ec 31 | 32 | - name: Build 33 | run: opam exec -- dune build -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-mirage,mirage-crypto-pk,mirage-crypto-ec 34 | 35 | - name: Test 36 | run: opam exec -- dune runtest -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-mirage,mirage-crypto-pk,mirage-crypto-ec 37 | 38 | build-test-ocaml-5: 39 | name : Tests with OCaml 5 40 | 41 | strategy: 42 | fail-fast: false 43 | matrix: 44 | ocaml-version: ["5.2.1"] 45 | operating-system: [macos-latest, ubuntu-latest] 46 | 47 | runs-on: ${{ matrix.operating-system }} 48 | 49 | steps: 50 | - name: Checkout code 51 | uses: actions/checkout@v4 52 | 53 | - name: Use OCaml ${{ matrix.ocaml-version }} 54 | uses: ocaml/setup-ocaml@v3 55 | with: 56 | opam-local-packages: | 57 | mirage-crypto.opam 58 | mirage-crypto-rng.opam 59 | mirage-crypto-rng-miou-unix.opam 60 | ocaml-compiler: ${{ matrix.ocaml-version }} 61 | 62 | - name: Install dependencies 63 | run: opam install --deps-only -t mirage-crypto mirage-crypto-rng mirage-crypto-rng-miou-unix 64 | 65 | - name: Build 66 | run: opam exec -- dune build -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-miou-unix 67 | 68 | - name: Test 69 | run: opam exec -- dune runtest -p mirage-crypto,mirage-crypto-rng,mirage-crypto-rng-miou-unix 70 | -------------------------------------------------------------------------------- /rng/miou/mirage_crypto_rng_miou_unix.mli: -------------------------------------------------------------------------------- 1 | (** {b RNG} seeding on {b Miou_unix}. 2 | 3 | This module initializes a RNG with [getrandom()], and CPU RNG. On BSD system 4 | (FreeBSD, OpenBSD, MacOS) [getentropy()] is used instead of [getrandom()]. 5 | On Windows 10 or higher, [BCryptGenRandom()] is used with the default RNG. 6 | Windows 8 or lower are not supported by this library. 7 | *) 8 | 9 | module Pfortuna : Mirage_crypto_rng.Generator 10 | (** {b Pfortuna}, a {b domain-safe} CSPRNG 11 | {{: https://www.schneier.com/fortuna.html} proposed} by Schneier. *) 12 | 13 | type rng 14 | (** Type of tasks seeding the RNG. *) 15 | 16 | val initialize : ?g:'a -> ?sleep:int64 -> 'a Mirage_crypto_rng.generator -> rng 17 | (** [initialize ?g ?sleep (module Generator)] will allow the RNG to operate in a 18 | returned task. This task periodically launches sub-tasks that seed the 19 | engine (using [getrandom()], [getentropy()] or [BCryptGenRandom()] depending 20 | on the system). These sub-tasks must be cleaned periodically (in seconds) 21 | according to the [sleep] parameter given (defaults to 1 second). 22 | 23 | The user must then {!val:kill} the returned task at the end of the program 24 | to be sure to clean everything. Otherwise, Miou will complain with the 25 | exception [Still_has_children]. 26 | 27 | We strongly recommend using {!module:Pfortuna} as an RNG engine rather than 28 | {!module:Mirage_crypto_rng.Fortuna}. The engine is launched in parallel with 29 | the other tasks if at least one domain is available. To ensure that there is 30 | no compromise in the values generated by a {i data-race}, [Pfortuna] is an 31 | {b domain-safe} implementation of Fortuna. 32 | 33 | The user cannot make any subsequent calls to [initialize]. In other words, 34 | you can only initialise a single {!type:rng} task. You must {!val:kill} the 35 | returned {!type:rng} if you want to re-initialise the RNG. 36 | 37 | A basic usage of [mirage-crypto-rng-miou-unix] is: 38 | {[ 39 | let () = Miou_unix.run @@ fun () -> 40 | let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in 41 | let str = Mirage_crypto_rng.generate 16 in 42 | Format.printf "random: %S\n%!" str; 43 | Mirage_crypto_rng_miou_unix.kill rng 44 | ]} *) 45 | 46 | val kill : rng -> unit 47 | (** [kill rng] terminates the {i background} task which seeds the RNG. *) 48 | -------------------------------------------------------------------------------- /src/native/poly1305-donna.c: -------------------------------------------------------------------------------- 1 | // from https://github.com/floodyberry/poly1305-donna.git 2 | 3 | #include "mirage_crypto.h" 4 | 5 | typedef struct poly1305_context { 6 | size_t aligner; 7 | unsigned char opaque[136]; 8 | } poly1305_context; 9 | 10 | /* 64-bit Windows sets ARCH_64BIT but poly1305-donna-64 requires 128-bit integers 11 | * that are not supported by the Microsoft compiler. Drop down to 32-bit for MSVC. 12 | */ 13 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 14 | #include "poly1305-donna-64.h" 15 | #else 16 | #include "poly1305-donna-32.h" 17 | #endif 18 | 19 | static void 20 | poly1305_update(poly1305_context *ctx, const unsigned char *m, size_t bytes) { 21 | poly1305_state_internal_t *st = (poly1305_state_internal_t *)ctx; 22 | size_t i; 23 | 24 | /* handle leftover */ 25 | if (st->leftover) { 26 | size_t want = (poly1305_block_size - st->leftover); 27 | if (want > bytes) 28 | want = bytes; 29 | for (i = 0; i < want; i++) 30 | st->buffer[st->leftover + i] = m[i]; 31 | bytes -= want; 32 | m += want; 33 | st->leftover += want; 34 | if (st->leftover < poly1305_block_size) 35 | return; 36 | poly1305_blocks(st, st->buffer, poly1305_block_size); 37 | st->leftover = 0; 38 | } 39 | 40 | /* process full blocks */ 41 | if (bytes >= poly1305_block_size) { 42 | size_t want = (bytes & ~(poly1305_block_size - 1)); 43 | poly1305_blocks(st, m, want); 44 | m += want; 45 | bytes -= want; 46 | } 47 | 48 | /* store leftover */ 49 | if (bytes) { 50 | for (i = 0; i < bytes; i++) 51 | st->buffer[st->leftover + i] = m[i]; 52 | st->leftover += bytes; 53 | } 54 | } 55 | 56 | //stubs for OCaml 57 | CAMLprim value mc_poly1305_init (value ctx, value key) { 58 | poly1305_init ((poly1305_context *) Bytes_val(ctx), _st_uint8(key)); 59 | return Val_unit; 60 | } 61 | 62 | CAMLprim value mc_poly1305_update (value ctx, value buf, value off, value len) { 63 | poly1305_update ((poly1305_context *) Bytes_val(ctx), _st_uint8_off(buf, off), Int_val(len)); 64 | return Val_unit; 65 | } 66 | 67 | CAMLprim value mc_poly1305_finalize (value ctx, value mac, value off) { 68 | poly1305_finish ((poly1305_context *) Bytes_val(ctx), _bp_uint8_off(mac, off)); 69 | return Val_unit; 70 | } 71 | 72 | CAMLprim value mc_poly1305_ctx_size (__unit ()) { 73 | return Val_int(sizeof(poly1305_context)); 74 | } 75 | 76 | CAMLprim value mc_poly1305_mac_size (__unit ()) { 77 | return Val_int(16); 78 | } 79 | -------------------------------------------------------------------------------- /src/poly1305.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type 'a iter = 'a Uncommon.iter 3 | 4 | type t 5 | val mac_size : int 6 | 7 | val empty : key:string -> t 8 | val feed : t -> string -> t 9 | val feedi : t -> string iter -> t 10 | val get : t -> string 11 | 12 | val mac : key:string -> string -> string 13 | val maci : key:string -> string iter -> string 14 | val mac_into : key:string -> (string * int * int) list -> bytes -> dst_off:int -> unit 15 | val unsafe_mac_into : key:string -> (string * int * int) list -> bytes -> dst_off:int -> unit 16 | end 17 | 18 | module It : S = struct 19 | type 'a iter = 'a Uncommon.iter 20 | 21 | module P = Native.Poly1305 22 | let mac_size = P.mac_size () 23 | 24 | type t = bytes 25 | 26 | let dup = Bytes.copy 27 | 28 | let empty ~key = 29 | let ctx = Bytes.create (P.ctx_size ()) in 30 | if String.length key <> 32 then invalid_arg "Poly1305 key must be 32 bytes" ; 31 | P.init ctx key ; 32 | ctx 33 | 34 | let update ctx data = 35 | P.update ctx data 0 (String.length data) 36 | 37 | let feed ctx cs = 38 | let t = dup ctx in 39 | update t cs ; 40 | t 41 | 42 | let feedi ctx iter = 43 | let t = dup ctx in 44 | iter (update t) ; 45 | t 46 | 47 | let final ctx = 48 | let res = Bytes.create mac_size in 49 | P.finalize ctx res 0; 50 | Bytes.unsafe_to_string res 51 | 52 | let get ctx = final (dup ctx) 53 | 54 | let mac ~key data = feed (empty ~key) data |> final 55 | 56 | let maci ~key iter = feedi (empty ~key) iter |> final 57 | 58 | let unsafe_mac_into ~key datas dst ~dst_off = 59 | let ctx = empty ~key in 60 | List.iter (fun (d, off, len) -> P.update ctx d off len) datas; 61 | P.finalize ctx dst dst_off 62 | 63 | let mac_into ~key datas dst ~dst_off = 64 | if Bytes.length dst - dst_off < mac_size then 65 | Uncommon.invalid_arg "Poly1305: dst length %u - off %u < len %u" 66 | (Bytes.length dst) dst_off mac_size; 67 | if dst_off < 0 then 68 | Uncommon.invalid_arg "Poly1305: dst_off %u < 0" dst_off; 69 | let ctx = empty ~key in 70 | List.iter (fun (d, off, len) -> 71 | if off < 0 then 72 | Uncommon.invalid_arg "Poly1305: d off %u < 0" off; 73 | if String.length d - off < len then 74 | Uncommon.invalid_arg "Poly1305: d length %u - off %u < len %u" 75 | (String.length d) off len; 76 | P.update ctx d off len) 77 | datas; 78 | P.finalize ctx dst dst_off 79 | end 80 | -------------------------------------------------------------------------------- /src/native/misc_sse.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | #ifdef __mc_ACCELERATE__ 4 | 5 | static inline void xor_into (const uint8_t *src, uint8_t *dst, size_t n) { 6 | /* see issue #70 #81 for alignment considerations (memcpy used below) */ 7 | #ifdef ARCH_64BIT 8 | __m128i r; 9 | for (; n >= 16; n -= 16, src += 16, dst += 16) 10 | _mm_storeu_si128 ( 11 | (__m128i*) dst, 12 | _mm_xor_si128 ( 13 | _mm_loadu_si128 ((__m128i*) memcpy(&r, src, 16)), 14 | _mm_loadu_si128 ((__m128i*) dst))); 15 | 16 | uint64_t s; 17 | for (; n >= 8; n -= 8, src += 8, dst += 8) 18 | *(uint64_t*) dst ^= *(uint64_t*) memcpy(&s, src, 8); 19 | #endif 20 | 21 | uint32_t t; 22 | for (; n >= 4; n -= 4, src += 4, dst += 4) 23 | *(uint32_t*) dst ^= *(uint32_t*)memcpy(&t, src, 4); 24 | 25 | for (; n --; ++ src, ++ dst) *dst = *src ^ *dst; 26 | } 27 | 28 | /* The GCM counter. Counts on the last 32 bits, ignoring carry. */ 29 | static inline void _mc_count_16_be_4 (uint64_t *init, uint64_t *dst, size_t blocks) { 30 | 31 | __m128i ctr, c1 = _mm_set_epi32 (1, 0, 0, 0), 32 | mask = _mm_set_epi64x (0x0c0d0e0f0b0a0908, 0x0706050403020100); 33 | ctr = _mm_shuffle_epi8 (_mm_loadu_si128 ((__m128i *) init), mask); 34 | for (; blocks --; dst += 2) { 35 | _mm_storeu_si128 ((__m128i *) dst, _mm_shuffle_epi8 (ctr, mask)); 36 | ctr = _mm_add_epi32 (ctr, c1); 37 | } 38 | } 39 | 40 | #endif /* __mc_ACCELERATE__ */ 41 | 42 | CAMLprim value 43 | mc_xor_into_bytes (value b1, value off1, value b2, value off2, value n) { 44 | _mc_switch_accel(ssse3, 45 | mc_xor_into_bytes_generic(b1, off1, b2, off2, n), 46 | xor_into (_st_uint8_off (b1, off1), _bp_uint8_off (b2, off2), Int_val (n))) 47 | return Val_unit; 48 | } 49 | 50 | #define __export_counter(name, f) \ 51 | CAMLprim value name (value ctr, value dst, value off, value blocks) { \ 52 | _mc_switch_accel(ssse3, \ 53 | name##_generic (ctr, dst, off, blocks), \ 54 | f ( (uint64_t*) Bp_val (ctr), \ 55 | (uint64_t*) _bp_uint8_off (dst, off), Long_val (blocks) )) \ 56 | return Val_unit; \ 57 | } 58 | 59 | __export_counter(mc_count_16_be_4, _mc_count_16_be_4) 60 | 61 | CAMLprim value mc_misc_mode (__unit ()) { 62 | value enabled = 0; 63 | _mc_switch_accel(ssse3, 64 | enabled = 0, 65 | enabled = 1) 66 | return Val_int (enabled); 67 | } 68 | -------------------------------------------------------------------------------- /src/native/misc.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | static inline void xor_into (const uint8_t *src, uint8_t *dst, size_t n) { 4 | /* see issue #70 #81 for alignment considerations (memcpy used below) */ 5 | #ifdef ARCH_64BIT 6 | uint64_t s; 7 | for (; n >= 8; n -= 8, src += 8, dst += 8) 8 | *(uint64_t*) dst ^= *(uint64_t*)memcpy(&s, src, 8); 9 | #endif 10 | 11 | uint32_t t; 12 | for (; n >= 4; n -= 4, src += 4, dst += 4) 13 | *(uint32_t*) dst ^= *(uint32_t*)memcpy(&t, src, 4); 14 | 15 | for (; n --; ++ src, ++ dst) *dst = *src ^ *dst; 16 | } 17 | 18 | static inline void _mc_count_8_be (uint64_t *init, uint64_t *dst, size_t blocks) { 19 | uint64_t qw = be64_to_cpu (*init); 20 | while (blocks --) *(dst ++) = cpu_to_be64 (qw ++); 21 | } 22 | 23 | /* XXX 24 | * 25 | * Counters are garbage. ;_; 26 | * Calling this incurs about a 15% hit in AES-CTR. 27 | * 28 | * What slows things down: 29 | * - Naive __uint128_t. 30 | * - Loop unrolling. 31 | * - SSE carry bit handling. 32 | */ 33 | static inline void _mc_count_16_be (uint64_t *init, uint64_t *dst, size_t blocks) { 34 | uint64_t qw1 = init[0], 35 | qw2 = be64_to_cpu (init[1]); 36 | for (; blocks --; dst += 2) { 37 | dst[0] = qw1; 38 | dst[1] = cpu_to_be64 (qw2); 39 | if ((++ qw2) == 0) qw1 = cpu_to_be64 (be64_to_cpu (qw1) + 1); 40 | } 41 | } 42 | 43 | /* The GCM counter. Counts on the last 32 bits, ignoring carry. */ 44 | static inline void _mc_count_16_be_4 (uint64_t *init, uint64_t *dst, size_t blocks) { 45 | 46 | uint64_t qw1 = init[0]; 47 | uint32_t dw3 = ((uint32_t*) init)[2], 48 | dw4 = be32_to_cpu (((uint32_t*) init)[3]); 49 | for (; blocks --; dst += 2) { 50 | dst[0] = qw1; 51 | ((uint32_t*) dst)[2] = dw3; 52 | ((uint32_t*) dst)[3] = cpu_to_be32 (dw4 ++); 53 | } 54 | } 55 | 56 | CAMLprim value 57 | mc_xor_into_bytes_generic (value b1, value off1, value b2, value off2, value n) { 58 | xor_into (_st_uint8_off (b1, off1), _bp_uint8_off (b2, off2), Int_val (n)); 59 | return Val_unit; 60 | } 61 | 62 | #define __export_counter(name, f) \ 63 | CAMLprim value name (value ctr, value dst, value off, value blocks) { \ 64 | f ( (uint64_t*) Bp_val (ctr), \ 65 | (uint64_t*) _bp_uint8_off (dst, off), Long_val (blocks) ); \ 66 | return Val_unit; \ 67 | } 68 | 69 | __export_counter (mc_count_8_be, _mc_count_8_be) 70 | __export_counter (mc_count_16_be, _mc_count_16_be) 71 | __export_counter (mc_count_16_be_4_generic, _mc_count_16_be_4) 72 | -------------------------------------------------------------------------------- /LICENSE.md.mirage-crypto-ec: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2019 Etienne Millon, 2021 Hannes Mehnert 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | 23 | 24 | C stubs in `*_32.h` and `*_64.h` were generated using 25 | Fiat (https://github.com/mit-plv/fiat-crypto) and thus these files are 26 | licensed under the MIT license with the following copyright : 27 | ---------------------------- 28 | Copyright (c) 2015-2020 Andres Erbsen 29 | Google Inc. 30 | Jade Philipoom 31 | Massachusetts Institute of Technology 32 | Zoe Paraskevopoulou 33 | 34 | The code in curve25519_stubs.c and point_operations.h are from BoringSSL with 35 | the following license: 36 | 37 | Copyright (c) 2020, Google Inc. 38 | 39 | Permission to use, copy, modify, and/or distribute this software for any 40 | purpose with or without fee is hereby granted, provided that the above 41 | copyright notice and this permission notice appear in all copies. 42 | 43 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 44 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 45 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 46 | SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 47 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION 48 | OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN 49 | CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 50 | -------------------------------------------------------------------------------- /src/native.ml: -------------------------------------------------------------------------------- 1 | 2 | module AES = struct 3 | external enc : string -> int -> bytes -> int -> string -> int -> int -> unit = "mc_aes_enc_bc" "mc_aes_enc" [@@noalloc] 4 | external dec : string -> int -> bytes -> int -> string -> int -> int -> unit = "mc_aes_dec_bc" "mc_aes_dec" [@@noalloc] 5 | external derive_e : string -> bytes -> int -> unit = "mc_aes_derive_e_key" [@@noalloc] 6 | external derive_d : string -> bytes -> int -> string option -> unit = "mc_aes_derive_d_key" [@@noalloc] 7 | external rk_s : int -> int = "mc_aes_rk_size" [@@noalloc] 8 | external mode : unit -> int = "mc_aes_mode" [@@noalloc] 9 | end 10 | 11 | module DES = struct 12 | external ddes : string -> int -> bytes -> int -> int -> string -> unit = "mc_des_ddes_bc" "mc_des_ddes" [@@noalloc] 13 | external des3key : bytes -> int -> bytes -> unit = "mc_des_des3key" [@@noalloc] 14 | external k_s : unit -> int = "mc_des_key_size" [@@noalloc] 15 | end 16 | 17 | module Chacha = struct 18 | external round : int -> bytes -> bytes -> int -> unit = "mc_chacha_round" [@@noalloc] 19 | end 20 | 21 | module Poly1305 = struct 22 | external init : bytes -> string -> unit = "mc_poly1305_init" [@@noalloc] 23 | external update : bytes -> string -> int -> int -> unit = "mc_poly1305_update" [@@noalloc] 24 | external finalize : bytes -> bytes -> int -> unit = "mc_poly1305_finalize" [@@noalloc] 25 | external ctx_size : unit -> int = "mc_poly1305_ctx_size" [@@noalloc] 26 | external mac_size : unit -> int = "mc_poly1305_mac_size" [@@noalloc] 27 | end 28 | 29 | module GHASH = struct 30 | external keysize : unit -> int = "mc_ghash_key_size" [@@noalloc] 31 | external keyinit : string -> bytes -> unit = "mc_ghash_init_key" [@@noalloc] 32 | external ghash : string -> bytes -> string -> int -> int -> unit = "mc_ghash" [@@noalloc] 33 | external mode : unit -> int = "mc_ghash_mode" [@@noalloc] 34 | end 35 | 36 | (* XXX TODO 37 | * Unsolved: bounds-checked XORs are slowing things down considerably... *) 38 | external xor_into_bytes : string -> int -> bytes -> int -> int -> unit = "mc_xor_into_bytes" [@@noalloc] 39 | 40 | external count8be : ctr:bytes -> bytes -> off:int -> blocks:int -> unit = "mc_count_8_be" [@@noalloc] 41 | external count16be : ctr:bytes -> bytes -> off:int -> blocks:int -> unit = "mc_count_16_be" [@@noalloc] 42 | external count16be4 : ctr:bytes -> bytes -> off:int -> blocks:int -> unit = "mc_count_16_be_4" [@@noalloc] 43 | 44 | external misc_mode : unit -> int = "mc_misc_mode" [@@noalloc] 45 | 46 | external _detect_cpu_features : unit -> unit = "mc_detect_cpu_features" [@@noalloc] 47 | external _detect_entropy : unit -> unit = "mc_entropy_detect" 48 | 49 | let () = 50 | _detect_cpu_features (); 51 | _detect_entropy () 52 | -------------------------------------------------------------------------------- /bench/miou.ml: -------------------------------------------------------------------------------- 1 | open Mirage_crypto 2 | 3 | module Time = struct 4 | 5 | let time ~n f a = 6 | let t1 = Sys.time () in 7 | for _ = 1 to n do ignore (f a) done ; 8 | let t2 = Sys.time () in 9 | (t2 -. t1) 10 | 11 | let warmup () = 12 | let x = ref 0 in 13 | let rec go start = 14 | if Sys.time () -. start < 1. then begin 15 | for i = 0 to 10000 do x := !x + i done ; 16 | go start 17 | end in 18 | go (Sys.time ()) 19 | 20 | end 21 | 22 | let burn_period = 2.0 23 | 24 | let sizes = [16; 64; 256; 1024; 8192] 25 | (* let sizes = [16] *) 26 | 27 | let burn f n = 28 | let buf = Mirage_crypto_rng.generate n in 29 | let (t1, i1) = 30 | let rec loop it = 31 | let t = Time.time ~n:it f buf in 32 | if t > 0.2 then (t, it) else loop (it * 10) in 33 | loop 10 in 34 | let iters = int_of_float (float i1 *. burn_period /. t1) in 35 | let time = Time.time ~n:iters f buf in 36 | (iters, time, float (n * iters) /. time) 37 | 38 | let mb = 1024. *. 1024. 39 | 40 | let throughput title f = 41 | Printf.printf "\n* [%s]\n%!" title ; 42 | sizes |> List.iter @@ fun size -> 43 | Gc.full_major () ; 44 | let (iters, time, bw) = burn f size in 45 | Printf.printf " % 5d: %04f MB/s (%d iters in %.03f s)\n%!" 46 | size (bw /. mb) iters time 47 | 48 | let bm name f = (name, fun () -> f name) 49 | 50 | let benchmarks = [ 51 | bm "pfortuna" (fun name -> 52 | let open Mirage_crypto_rng_miou_unix.Pfortuna in 53 | Miou_unix.run ~domains:2 @@ fun () -> 54 | let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in 55 | let g = create () in 56 | reseed ~g "abcd" ; 57 | throughput name (fun buf -> 58 | let buf = Bytes.unsafe_of_string buf in 59 | generate_into ~g buf ~off:0 (Bytes.length buf)); 60 | Mirage_crypto_rng_miou_unix.kill rng) ; 61 | ] 62 | 63 | let help () = 64 | Printf.printf "available benchmarks:\n "; 65 | List.iter (fun (n, _) -> Printf.printf "%s " n) benchmarks ; 66 | Printf.printf "\n%!" 67 | 68 | let runv fs = 69 | Format.printf "accel: %a\n%!" 70 | (fun ppf -> List.iter @@ fun x -> 71 | Format.fprintf ppf "%s " @@ 72 | match x with `XOR -> "XOR" | `AES -> "AES" | `GHASH -> "GHASH") 73 | accelerated; 74 | Time.warmup () ; 75 | List.iter (fun f -> f ()) fs 76 | 77 | 78 | let () = 79 | let seed = "abcd" in 80 | let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in 81 | Mirage_crypto_rng.set_default_generator g; 82 | match Array.to_list Sys.argv with 83 | | _::(_::_ as args) -> begin 84 | try 85 | let fs = 86 | args |> List.map @@ fun n -> 87 | snd (benchmarks |> List.find @@ fun (n1, _) -> n = n1) in 88 | runv fs 89 | with Not_found -> help () 90 | end 91 | | _ -> help () 92 | -------------------------------------------------------------------------------- /config/cfg.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let c = Configurator.V1.create "mirage-crypto" in 3 | let ccomp_type_opt = Configurator.V1.ocaml_config_var c "ccomp_type" in 4 | let arch = 5 | let defines = 6 | Configurator.V1.C_define.import 7 | c 8 | ~includes:[] 9 | [("__x86_64__", Switch); ("__i386__", Switch); ("__powerpc64__", Switch); 10 | ("__s390x__", Switch); ("__aarch64__", Switch); 11 | ("_WIN64", Switch); ("_WIN32", Switch)] 12 | in 13 | match defines with 14 | | (_, Switch true) :: _ -> `x86_64 15 | | _ :: (_, Switch true) :: _ -> `x86 16 | | _ :: _ :: (_, Switch true) :: _ -> `ppc64 17 | | _ :: _ :: _ :: (_, Switch true) :: _ -> `s390x 18 | | _ :: _ :: _ :: _ :: (_, Switch true) :: _ -> `arm64 19 | | _ :: _ :: _ :: _ :: _ :: (_, Switch true) :: _ -> `x86_64 20 | | _ :: _ :: _ :: _ :: _ :: _ :: (_, Switch true) :: _ -> `x86 21 | | _ -> `unknown 22 | in 23 | let os = 24 | let defines = 25 | Configurator.V1.C_define.import 26 | c 27 | ~includes:[] 28 | [("__APPLE__", Switch)] 29 | in 30 | match defines with 31 | | (_, Switch true) :: _ -> `macos 32 | | _ -> `unknown 33 | in 34 | let accelerate_flags = 35 | match arch, ccomp_type_opt with 36 | | `x86_64, Some "msvc" -> [ "-DACCELERATE" ] 37 | | `x86_64, _ -> [ "-DACCELERATE"; "-mssse3"; "-maes"; "-mpclmul" ] 38 | | _ -> [] 39 | in 40 | let ent_flags = 41 | match arch, ccomp_type_opt with 42 | | (`x86_64 | `x86), Some "msvc" -> [ "-DENTROPY" ] 43 | | (`x86_64 | `x86), _ -> [ "-DENTROPY"; "-mrdrnd"; "-mrdseed" ] 44 | | _ -> [] 45 | in 46 | let std_flags = 47 | match ccomp_type_opt with 48 | | Some "msvc" -> ["/Wall"] 49 | | _ -> ["--std=c11"; "-Wall"; "-Wextra"; "-Wpedantic"; "-O3"] 50 | in 51 | let warn_flags = 52 | (* See #178, there may be false positives on ppc&s390 with no-stringop-overflow *) 53 | match arch, ccomp_type_opt with 54 | | _, Some "msvc" -> [ "/WX" ] 55 | | (`ppc64, _) | (`s390x, _) -> [ "-Wno-stringop-overflow"; "-Werror" ] 56 | | _ -> [ "-Werror" ] 57 | in 58 | let no_instcombine_on_macos = match arch, os with 59 | | `arm64, `macos -> 60 | let res = Configurator.V1.Process.run c "cc" ["-dumpversion"] in 61 | if String.trim res.stdout = "14.0.3" then 62 | ["-mllvm"; "--instcombine-max-iterations=0"] 63 | (* macOS instcombine miscompilation with clang 14.0.3 *) 64 | else 65 | [] 66 | | _ -> [] 67 | in 68 | let flags = std_flags @ no_instcombine_on_macos @ ent_flags in 69 | let opt_flags = flags @ accelerate_flags in 70 | Configurator.V1.Flags.write_sexp "cflags_optimized.sexp" opt_flags; 71 | Configurator.V1.Flags.write_sexp "cflags.sexp" flags; 72 | Configurator.V1.Flags.write_sexp "cflags_warn.sexp" warn_flags 73 | -------------------------------------------------------------------------------- /rng/unix/mc_getrandom_stubs.c: -------------------------------------------------------------------------------- 1 | #ifndef _MSC_VER 2 | # include 3 | #endif 4 | 5 | #include "mirage_crypto.h" 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #if defined(__ANDROID_API__) && __ANDROID_API__ < 28 13 | // on Android 27 and earlier, we use Google's recommended arc4random_buf 14 | # include 15 | 16 | void raw_getrandom (uint8_t *data, size_t len) { 17 | arc4random_buf(data, len); 18 | } 19 | #elif defined(__linux) || defined(__GNU__) 20 | # include 21 | // on Linux and GNU/Hurd, we use getrandom and loop 22 | 23 | # if __GLIBC__ && __GLIBC__ <= 2 && __GLIBC_MINOR__ < 25 24 | # include 25 | # define getrandom(buf, len, flags) syscall(SYS_getrandom, (buf), (len), (flags)) 26 | # else 27 | # include 28 | # define getrandom(buf, len, flags) getrandom((buf), (len), (flags)) 29 | # endif 30 | 31 | void raw_getrandom (uint8_t *data, size_t len) { 32 | size_t off = 0; 33 | ssize_t r = 0; 34 | while (off < len) { 35 | r = getrandom(data + off, len - off, 0); 36 | if (r == -1) { 37 | if (errno == EINTR) continue; 38 | else uerror("getrandom", Nothing); 39 | } 40 | off += (size_t)r; 41 | } 42 | } 43 | #elif (defined(__FreeBSD__) || defined(__FreeBSD_kernel__) || defined(__DragonFly__) || defined(__OpenBSD__) || defined(__APPLE__)) || defined(__NetBSD__) 44 | // on BSD and macOS, loop (in pieces of 256) getentropy 45 | #if defined(__APPLE__) 46 | // on macOS, getentropy is defined in sys/random.h (on BSD in unistd.h) 47 | #include 48 | #endif 49 | #include 50 | 51 | void raw_getrandom (uint8_t *data, size_t len) { 52 | size_t rlen = 0; 53 | for (size_t i = 0; i <= len; i += 256) { 54 | rlen = MIN(256, len - i); 55 | if (getentropy(data + i, rlen) == -1) uerror("getentropy", Nothing); 56 | } 57 | } 58 | #elif (defined(_WIN32)) 59 | /* There is a choice between using RtlGenRandom and BCryptGenRandom 60 | * here, and Microsoft does not make the choice obvious. It appears 61 | * that RtlGenRandom is best used when older Windows compatibility 62 | * is of concern, but requires some gymnastics around binding it 63 | * with the right calling convention. 64 | * 65 | * Therefore (https://github.com/mirage/mirage-crypto/pull/39) we 66 | * have decided to go with the more modern Windows API with bcrypt, 67 | * and make Windows 10 our minimum supported version of mirage-crypto. 68 | */ 69 | #include 70 | #include 71 | #include 72 | 73 | void raw_getrandom(uint8_t *data, size_t len) { 74 | NTSTATUS Status; 75 | Status = BCryptGenRandom(NULL, data, len, BCRYPT_USE_SYSTEM_PREFERRED_RNG); 76 | if (Status != STATUS_SUCCESS) 77 | uerror("BCryptGenRandom", Nothing); 78 | } 79 | 80 | #else 81 | #error "Retrieving random data not supported on this platform" 82 | #endif 83 | 84 | CAMLprim value mc_getrandom (value buf, value off, value len) { 85 | raw_getrandom(_bp_uint8_off(buf, off), Long_val(len)); 86 | return Val_unit; 87 | } 88 | -------------------------------------------------------------------------------- /rng/mirage/mirage_crypto_rng_mirage.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Hannes Mehnert 3 | * Copyright (c) 2014 Anil Madhavapeddy 4 | * Copyright (c) 2014-2016 David Kaloper Meršinjak 5 | * Copyright (c) 2015 Citrix Systems Inc 6 | * All rights reserved. 7 | * 8 | * Redistribution and use in source and binary forms, with or without 9 | * modification, are permitted provided that the following conditions are met: 10 | * 11 | * * Redistributions of source code must retain the above copyright notice, this 12 | * list of conditions and the following disclaimer. 13 | * 14 | * * Redistributions in binary form must reproduce the above copyright notice, 15 | * this list of conditions and the following disclaimer in the documentation 16 | * and/or other materials provided with the distribution. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | *) 29 | 30 | let src = Logs.Src.create "mirage-crypto-rng-mirage" ~doc:"Mirage crypto RNG mirage" 31 | module Log = (val Logs.src_log src : Logs.LOG) 32 | 33 | open Mirage_crypto_rng 34 | 35 | let rdrand_task delta = 36 | match Entropy.cpu_rng with 37 | | Error `Not_supported -> () 38 | | Ok cpu_rng -> 39 | let open Lwt.Infix in 40 | let rdrand = cpu_rng None in 41 | Lwt.async (fun () -> 42 | let rec one () = 43 | rdrand (); 44 | Mirage_sleep.ns delta >>= 45 | one 46 | in 47 | one ()) 48 | 49 | let bootstrap_functions () = 50 | Entropy.[ bootstrap ; bootstrap ; whirlwind_bootstrap ; bootstrap ] 51 | 52 | let running = ref false 53 | 54 | let initialize (type a) ?g ?(sleep = Duration.of_sec 1) (rng : a generator) = 55 | if !running then 56 | Lwt.fail_with "entropy collection already running" 57 | else begin 58 | (try 59 | let _ = default_generator () in 60 | Log.warn (fun m -> m "Mirage_crypto_rng.default_generator has already \ 61 | been set, check that this call is intentional"); 62 | with 63 | No_default_generator -> ()); 64 | running := true; 65 | let seed = 66 | List.mapi (fun i f -> f i) (bootstrap_functions ()) |> String.concat "" 67 | in 68 | let rng = create ?g ~seed ~time:Mirage_mtime.elapsed_ns rng in 69 | set_default_generator rng; 70 | rdrand_task sleep; 71 | Mirage_runtime.at_enter_iter (Entropy.timer_accumulator None); 72 | Lwt.return_unit 73 | end 74 | -------------------------------------------------------------------------------- /tests/test_dh.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | open Mirage_crypto_pk 4 | 5 | open Test_common 6 | 7 | let dh_selftest ~bits n = 8 | "selftest" >:: times ~n @@ fun _ -> 9 | let p = Dh.gen_group ~bits () in 10 | let (s1, m1) = Dh.gen_key p 11 | and (s2, m2) = Dh.gen_key p in 12 | let sh1 = Dh.shared s1 m2 13 | and sh2 = Dh.shared s2 m1 in 14 | assert_equal sh1 sh2 15 | ~cmp:(eq_opt String.equal) 16 | ~pp_diff:(pp_diff (fun ppf -> function 17 | | None -> Format.fprintf ppf "None" 18 | | Some a -> Format.fprintf ppf "Some(%a)" (Ohex.pp_hexdump ()) a)) 19 | ~msg:"shared secret" 20 | 21 | let dh_shared_0 = 22 | "shared_0" >:: fun _ -> 23 | let gy = vx 24 | "14 ac e2 c0 9c c0 0c 25 89 71 b2 d0 1c 94 58 21 25 | 02 23 b7 23 ec 3e 24 e5 a3 c2 fd 16 cc 49 f0 e2 26 | 87 62 a5 a0 73 f5 de 5b 9b eb c3 60 0b a4 03 38 27 | 0f e1 8c f2 80 b3 64 16 f2 af ab 2e ec 25 81 2c 28 | 84 ae 92 0a 0f 15 9b f3 d9 1f dc 08 7d 8d 27 3a 29 | 91 7d a5 89 dc 94 d6 bc 3f 9d 6d b3 f8 8e f2 37 30 | 86 54 ec 85 ea 4c a0 4c b1 f6 49 83 1c 62 a7 79 31 | 2b 8b 9c e7 fa 47 3e 34 6c c5 ae 12 a3 4e d5 ce 32 | 4b da ea 72 7a 8d c6 67 ef 7e f2 00 24 d7 21 42 33 | a5 23 69 38 7e ec b5 fc 4b 89 42 c4 32 fa e5 58 34 | 6f 39 5d a7 4e cd b5 da dc 1e 52 fe a4 33 72 c1 35 | 82 48 8a 5b c1 44 bc 60 9b 38 5b 80 5f 44 14 93" 36 | and s = vx 37 | "f9 47 87 95 d2 a1 6d d1 7c c8 a9 c0 71 28 a2 82 38 | 71 95 7e 79 87 0b fc 34 a2 42 ec 42 ac cc 42 81 39 | 7b f6 c4 f5 80 a9 70 e3 35 93 9b a3 21 81 a4 e3 40 | 6b 65 3f 1c 5c ab 87 23 86 eb 76 29 66 26 5b e9 41 | c4 d0 26 05 3f de 6c 2f a6 14 f6 bf 77 74 a0 e8 42 | ef e7 12 62 a3 83 e5 66 d8 6c e5 c6 58 67 2a 61 43 | f5 7b 7c 15 15 63 22 55 96 92 9e bd cc b3 bc 2b 44 | 5e e1 ac 5f 75 23 ca 2f 19 5a f1 18 6e 17 f8 c2 45 | f7 11 c7 14 1d 81 bd be 02 31 3f 49 62 7d 02 11 46 | 29 22 63 6e bb 1a 7f 93 bd 98 db 20 94 f8 f0 2e 47 | db ce 9d 79 db b9 a7 41 5f e5 29 a2 31 f8 e2 c3 48 | 30 6a 09 f2 16 a7 30 8c 2f 36 7b 71 99 1e 28 54" 49 | and shared = vx 50 | "a7 40 0d eb f0 4b 2b ec cb 90 3c 55 2d 3c 17 63 51 | b2 4b 4e 1a ff 1e a0 24 c6 56 e3 5e 44 7b d0 01 52 | ef b3 6b 57 20 0e 15 95 b1 53 1a 83 16 3a b1 61 53 | 06 65 f1 7e 64 63 6f 23 86 22 34 c3 fe a9 60 87 54 | 3f 18 c6 5d 44 3e ac e3 85 34 86 6f db aa 31 3b 55 | 4b 4d 68 f7 19 d7 91 a3 12 27 d6 5a ce 29 c8 1b 56 | 5a 59 74 10 8c ff 98 4e 4f 37 ef 5b 43 e8 e2 ad 57 | a8 49 c9 7e c3 c5 3d 35 40 30 8e a4 41 69 1d 16 58 | 34 ba 9a 7e f3 ab d1 0e bb f2 81 15 e9 04 63 ee 59 | 1b bf cc 24 6d cb 41 c4 06 b2 f3 01 1b 31 3a 1e 60 | dc e3 3b c7 cc 1d 19 95 d9 fe 6a 5c a7 57 46 dd 61 | 84 69 0c 45 37 2e 1f 52 96 05 d7 e5 01 9a c8" 62 | in 63 | let grp = Dh.Group.oakley_5 in 64 | match Dh.(shared (fst (key_of_secret grp ~s)) gy) with 65 | | None -> assert_failure "degenerate shared secret" 66 | | Some shared' -> 67 | assert_oct_equal ~msg:"shared secret" shared shared' 68 | 69 | let suite = [ 70 | dh_selftest ~bits:16 1000 ; 71 | dh_selftest ~bits:128 100 ; 72 | dh_shared_0 73 | ] 74 | -------------------------------------------------------------------------------- /ec/gen_tables/gen_tables.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | let print_header name = 4 | printf 5 | {| 6 | /* 7 | Pre-computed %d-bit multiples of the generator point G for the curve %s, 8 | used for speeding up its scalar multiplication in point_operations.h. 9 | 10 | Generated by %s 11 | */|} 12 | Sys.word_size name Sys.argv.(0) 13 | 14 | let pp_array elem_fmt fmt arr = 15 | let fout = fprintf fmt in 16 | let len = Array.length arr in 17 | fout "@[<2>{@\n"; 18 | for i = 0 to len - 1 do 19 | elem_fmt fmt arr.(i); 20 | if i < len - 1 then printf ",@ " else printf "" 21 | done; 22 | fout "@]@,}" 23 | 24 | let div_round_up a b = (a / b) + if a mod b = 0 then 0 else 1 25 | 26 | let pp_string_words ~wordsize fmt str = 27 | assert (String.length str * 8 mod wordsize = 0); 28 | let limbs = String.length str * 8 / wordsize in 29 | (* Truncate at the beginning (little-endian) *) 30 | let bytes = Bytes.unsafe_of_string str in 31 | (* let bytes = rev_str_bytes str in *) 32 | fprintf fmt "@[<2>{@\n"; 33 | for i = 0 to limbs - 1 do 34 | let index = i * (wordsize / 8) in 35 | (if wordsize = 64 then 36 | let w = Bytes.get_int64_le bytes index in 37 | fprintf fmt "%#016Lx" w 38 | else 39 | let w = Bytes.get_int32_le bytes index in 40 | fprintf fmt "%#08lx" w); 41 | if i < limbs - 1 then printf ",@ " else printf "" 42 | done; 43 | fprintf fmt "@]@,}" 44 | 45 | let check_shape tables = 46 | let fe_len = String.length tables.(0).(0).(0) in 47 | let table_len = fe_len * 2 in 48 | assert (Array.length tables = table_len); 49 | Array.iter 50 | (fun x -> 51 | assert (Array.length x = 15); 52 | Array.iter 53 | (fun x -> 54 | assert (Array.length x = 3); 55 | Array.iter (fun x -> assert (String.length x = fe_len)) x) 56 | x) 57 | tables 58 | 59 | let print_tables tables ~wordsize = 60 | let fe_len = String.length tables.(0).(0).(0) in 61 | printf "@[<2>static WORD generator_table[%d][15][3][LIMBS] = @," (fe_len * 2); 62 | pp_array 63 | (pp_array (pp_array (pp_string_words ~wordsize))) 64 | std_formatter tables; 65 | printf "@];@," 66 | 67 | let print_toplevel name wordsize (module P : Mirage_crypto_ec.Dh_dsa) = 68 | let tables = P.Dsa.Precompute.generator_tables () in 69 | assert (wordsize = Sys.word_size); 70 | check_shape tables; 71 | print_header name; 72 | if wordsize = 64 then 73 | printf 74 | "@[#ifndef ARCH_64BIT@,\ 75 | #error \"Cannot use 64-bit tables on a 32-bit architecture\"@,\ 76 | #endif@,\ 77 | @]" 78 | else 79 | printf 80 | "@[#ifdef ARCH_64BIT@,\ 81 | #error \"Cannot use 32-bit tables on a 64-bit architecture\"@,\ 82 | #endif@,\ 83 | @]"; 84 | print_tables ~wordsize tables 85 | 86 | let curves = 87 | Mirage_crypto_ec. 88 | [ 89 | ("p256", (module P256 : Dh_dsa)); 90 | ("p384", (module P384)); 91 | ("p521", (module P521)); 92 | ] 93 | 94 | let usage () = 95 | printf "Usage: gen_tables [%a] [64 | 32]@." 96 | (pp_print_list 97 | ~pp_sep:(fun fmt () -> pp_print_string fmt " | ") 98 | pp_print_string) 99 | (List.map fst curves) 100 | 101 | let go = 102 | let name, curve, wordsize = 103 | try 104 | let name, curve = 105 | List.find (fun (name, _) -> name = Sys.argv.(1)) curves 106 | in 107 | (name, curve, int_of_string Sys.argv.(2)) 108 | with _ -> 109 | usage (); 110 | exit 1 111 | in 112 | print_toplevel name wordsize curve 113 | -------------------------------------------------------------------------------- /ec/implementation.mld: -------------------------------------------------------------------------------- 1 | {1 Implementation } 2 | 3 | The goal of this document is to describe how the library is implemented. 4 | 5 | {2 Field operations} 6 | 7 | These are implemented in [Field_element], which is a binding over 8 | [p256_{32,64}.h]. These are files extracted from Coq code in 9 | {{:https://github.com/mit-plv/fiat-crypto}this repository}. 10 | 11 | This module uses 12 | {{:https://en.wikipedia.org/wiki/Montgomery_modular_multiplication} Montgomery 13 | Modular Multiplication}. Instead of storing a number [a], operations are done 14 | on [aR] where R = 2{^256}. 15 | 16 | It is possible to check that these files correspond to the extracted ones in 17 | the upstream repository by running [dune build @check_vendors]. 18 | 19 | These files are part of the trusted computing base. That is, using this package 20 | relies on the fact that they implemented the correct algorithms. To go further, 21 | one can re-run the extraction process from Coq sources, see 22 | {{:https://github.com/mirage/fiat/issues/41}#41}. 23 | 24 | {2 Point operations} 25 | 26 | Points (see the [Point] module) are stored using projective coordinates (X : Y 27 | : Z): 28 | 29 | - Z=0 corresponds to the point at infinity 30 | - for Z≠0, this corresponds to a point with affine coordinates (X/Z{^2}, 31 | Y/Z{^3}) 32 | 33 | Doubling and addition are implemented as C stubs in [p256_stubs.c] using code 34 | that comes from BoringSSL, Google's fork of OpenSSL. Fiat code has been design 35 | in part to be included in BoringSSL, so this does not require any particular 36 | glue code. 37 | 38 | Some operations are implemented manually, in particular: 39 | 40 | - conversion to affine coordinates, as described above. This relies on a field 41 | inversion primitive from BoringSSL, that is exposed in [Field_element]. 42 | - point verification (bound checking and making sure that the equation is 43 | satisfied). 44 | 45 | There is no automated way to check that the BoringSSL part is identical to that 46 | in the upstream repository (nor to update it). 47 | 48 | {2 Scalar multiplication} 49 | 50 | Implemented by hand using the 51 | {{:https://cr.yp.to/bib/2003/joye-ladder.pdf}Montgomery Powering Ladder}. 52 | 53 | Instead of branching based on key bits, constant-time selection (as defined in 54 | fiat code) is used. 55 | 56 | The following references discuss this algorithm: 57 | 58 | - {{:https://cryptojedi.org/peter/data/eccss-20130911b.pdf}Scalar-multiplication algorithms, Peter Schwabe, ECC 2013 Summer School} 59 | - {{:https://eprint.iacr.org/2017/293.pdf}Montgomery curves and the Montgomery 60 | ladder, Daniel J. Bernstein and Tanja Lange} 61 | 62 | For the special case of base scalar multiplication (where the generator point of 63 | the curve specifically is multiplied by a scalar), instead an algorithm 64 | (implemented by hand in C) using pre-computed tables of point doubling is used 65 | (tables are in `native/p*_tables_32|64.c`). 66 | 67 | The key for this algorithm being constant-time is the function selecting values 68 | from the tables, which conceals what value it selects by exploring the whole 69 | table in the same order no matter the input, using const-time selection (as 70 | defined in fiat code). See `native/point_operations.h`. 71 | 72 | {2 Key exchange} 73 | 74 | Key exchange consists in 75 | 76 | - validating the public key as described in 77 | {{:https://tools.ietf.org/html/rfc8446#section-4.2.8.2}RFC 8446 §4.2.8.2}; 78 | - computing scalar multiplication; 79 | - returning the encoded x coordinate of the result. 80 | 81 | This is implemented by hand and checked against common errors using test 82 | vectors from {{:https://github.com/google/wycheproof}project Wycheproof}. 83 | -------------------------------------------------------------------------------- /rng/miou/mirage_crypto_rng_miou_unix.ml: -------------------------------------------------------------------------------- 1 | open Mirage_crypto_rng 2 | 3 | module Pfortuna = Pfortuna 4 | 5 | type _ Effect.t += Spawn : (unit -> unit) -> unit Effect.t 6 | external reraise : exn -> 'a = "%reraise" 7 | 8 | let periodic fn delta = 9 | let rec one () = 10 | fn (); 11 | Miou_unix.sleep (Duration.to_f delta); 12 | one () in 13 | Effect.perform (Spawn one) 14 | 15 | let getrandom delta source = 16 | let fn () = 17 | let per_pool = 8 in 18 | let size = per_pool * pools None in 19 | let random = Mirage_crypto_rng_unix.getrandom size in 20 | let idx = ref 0 in 21 | let fn () = 22 | incr idx; 23 | Ok (String.sub random (per_pool * (pred !idx)) per_pool) 24 | in 25 | Entropy.feed_pools None source fn in 26 | periodic fn delta 27 | 28 | let getrandom_init i = 29 | let data = Mirage_crypto_rng_unix.getrandom 128 in 30 | Entropy.header i data 31 | 32 | let rdrand delta = 33 | match Entropy.cpu_rng with 34 | | Error `Not_supported -> () 35 | | Ok cpu_rng -> periodic (cpu_rng None) delta 36 | 37 | let running = Atomic.make false 38 | 39 | let switch fn = 40 | let orphans = Miou.orphans () in 41 | let open Effect.Deep in 42 | let retc = Fun.id in 43 | let exnc = reraise in 44 | let effc : type c. c Effect.t -> ((c, 'r) continuation -> 'r) option 45 | = function 46 | | Spawn fn -> 47 | ignore (Miou.async ~orphans fn); 48 | Some (fun k -> continue k ()) 49 | | _ -> None in 50 | match_with fn orphans { retc; exnc; effc } 51 | 52 | let default_generator_already_set = 53 | "Mirage_crypto_rng.default_generator has already \ 54 | been set (but not via Mirage_crypto_rng_miou). Please check \ 55 | that this is intentional" 56 | 57 | let miou_generator_already_launched = 58 | "Mirage_crypto_rng_miou.initialize has already been launched \ 59 | and a task is already seeding the RNG." 60 | 61 | type rng = unit Miou.t 62 | 63 | let rec compare_and_set ?(backoff= Miou_backoff.default) t a b = 64 | if Atomic.compare_and_set t a b = false 65 | then compare_and_set ~backoff:(Miou_backoff.once backoff) t a b 66 | 67 | let rec clean_up sleep orphans = match Miou.care orphans with 68 | | Some None | None -> Miou_unix.sleep (Duration.to_f sleep); clean_up sleep orphans 69 | | Some (Some prm) -> Miou.await_exn prm; clean_up sleep orphans 70 | 71 | let call_if_domain_available fn = 72 | let available = Miou.Domain.available () in 73 | let current = (Stdlib.Domain.self () :> int) in 74 | if current = 0 && available > 0 75 | || current <> 0 && available > 1 76 | then Miou.call fn 77 | else Miou.async fn 78 | 79 | let initialize (type a) ?g ?(sleep= Duration.of_sec 1) (rng : a generator) = 80 | if Atomic.compare_and_set running false true 81 | then begin 82 | let seed = 83 | let init = Entropy.[ bootstrap; whirlwind_bootstrap; bootstrap; getrandom_init ] in 84 | List.mapi (fun i fn -> fn i) init |> String.concat "" in 85 | let () = 86 | try let _ = default_generator () in 87 | Logs.warn (fun m -> m "%s" default_generator_already_set) 88 | with No_default_generator -> () in 89 | let rng = create ?g ~seed ~time:Mtime_clock.elapsed_ns rng in 90 | set_default_generator rng; 91 | call_if_domain_available @@ fun () -> switch @@ fun orphans -> 92 | rdrand sleep; 93 | let source = Entropy.register_source "getrandom" in 94 | getrandom (Int64.mul sleep 10L) source; 95 | clean_up sleep orphans 96 | end else invalid_arg miou_generator_already_launched 97 | 98 | let kill prm = 99 | Miou.cancel prm; 100 | compare_and_set running true false; 101 | unset_default_generator () 102 | -------------------------------------------------------------------------------- /rng/rng.ml: -------------------------------------------------------------------------------- 1 | type source = int * string 2 | 3 | exception Unseeded_generator 4 | 5 | exception No_default_generator 6 | 7 | let setup_rng = 8 | "\nPlease setup your default random number generator. On Unix, the best \ 9 | path is to call [Mirage_crypto_rng_unix.use_default ()].\ 10 | \nBut you can use Fortuna (or any other RNG) and setup the seeding \ 11 | (done by default in MirageOS): \ 12 | \n\ 13 | \nTo initialize the RNG with a default generator, and set up entropy \ 14 | collection and periodic reseeding as a background task, do the \ 15 | following:\ 16 | \n If you are using MirageOS, use the random device in config.ml: \ 17 | `let main = Mirage.main \"Unikernel.Main\" (random @-> job)`, \ 18 | and `let () = register \"my_unikernel\" [main $ default_random]`. \ 19 | \n If you are using miou, execute \ 20 | `Mirage_crypto_rng_miou_unix.initialize (module Mirage_crypto_rng.Fortuna)` \ 21 | at startup." 22 | 23 | let () = Printexc.register_printer (function 24 | | Unseeded_generator -> 25 | Some ("The RNG has not been seeded." ^ setup_rng) 26 | | No_default_generator -> 27 | Some ("The default generator is not yet initialized. " ^ setup_rng) 28 | | _ -> None) 29 | 30 | module type Generator = sig 31 | type g 32 | val block : int 33 | val create : ?time:(unit -> int64) -> unit -> g 34 | val generate_into : g:g -> bytes -> off:int -> int -> unit 35 | [@@alert unsafe "Does not do bounds checks. Use Mirage_crypto_rng.generate_into instead."] 36 | val reseed : g:g -> string -> unit 37 | val accumulate : g:g -> source -> [`Acc of string -> unit] 38 | val seeded : g:g -> bool 39 | val pools : int 40 | end 41 | 42 | type 'a generator = (module Generator with type g = 'a) 43 | type g = Generator : ('a * bool * 'a generator) -> g 44 | 45 | let create (type a) ?g ?seed ?(strict=false) ?time (m : a generator) = 46 | let module M = (val m) in 47 | let g = Option.value g ~default:(M.create ?time ()) in 48 | Option.iter (M.reseed ~g) seed; 49 | Generator (g, strict, m) 50 | 51 | let _default_generator = Atomic.make None 52 | 53 | let set_default_generator g = Atomic.set _default_generator (Some g) 54 | 55 | let unset_default_generator () = Atomic.set _default_generator None 56 | 57 | let default_generator () = 58 | match Atomic.get _default_generator with 59 | | None -> raise No_default_generator 60 | | Some g -> g 61 | 62 | let get = function Some g -> g | None -> default_generator () 63 | 64 | let generate_into ?(g = default_generator ()) b ?(off = 0) n = 65 | let Generator (g, _, m) = g in 66 | let module M = (val m) in 67 | if off < 0 || n < 0 then 68 | invalid_arg ("negative offset " ^ string_of_int off ^ " or length " ^ 69 | string_of_int n); 70 | if Bytes.length b - off < n then 71 | invalid_arg "buffer too short"; 72 | begin[@alert "-unsafe"] 73 | M.generate_into ~g b ~off n 74 | end 75 | 76 | let generate ?g n = 77 | let data = Bytes.create n in 78 | generate_into ?g data ~off:0 n; 79 | Bytes.unsafe_to_string data 80 | 81 | let reseed ?(g = default_generator ()) cs = 82 | let Generator (g, _, m) = g in let module M = (val m) in M.reseed ~g cs 83 | 84 | let accumulate g source = 85 | let Generator (g, _, m) = get g in 86 | let module M = (val m) in 87 | M.accumulate ~g source 88 | 89 | let seeded g = 90 | let Generator (g, _, m) = get g in let module M = (val m) in M.seeded ~g 91 | 92 | let block g = 93 | let Generator (_, _, m) = get g in let module M = (val m) in M.block 94 | 95 | let pools g = 96 | let Generator (_, _, m) = get g in let module M = (val m) in M.pools 97 | 98 | let strict g = 99 | let Generator (_, s, _) = get g in s 100 | -------------------------------------------------------------------------------- /src/native/ghash_generic.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. */ 3 | 4 | #include "mirage_crypto.h" 5 | #include 6 | 7 | /* Generic table-driven GHASH. 8 | * 9 | * References: 10 | * - The Galois/Counter Mode of Operation. David A. McGrew and John Viega. 11 | * - NIST SP 800-38D. Recommendation for Block Cipher Modes of Operation: 12 | * Galois/Counter Mode (GCM) and GMAC. 13 | */ 14 | 15 | /* LARGE_TABLES -> 65K per key 16 | * !LARGE_TABLES -> 8K per key, ~3x slower. */ 17 | #define __MC_GHASH_LARGE_TABLES 18 | 19 | /* 64-bit Windows sets ARCH_64BIT but 128-bit integers are not supported 20 | * by the Microsoft compiler. Drop down to 32-bit for MSVC; 21 | * ghash_ctmul.c will implement ghash for MSVC. 22 | */ 23 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 24 | 25 | #define __set_uint128_t(w1, w0) (((__uint128_t) w1 << 64) | w0) 26 | 27 | static const __uint128_t r = __set_uint128_t (0xe100000000000000, 0); 28 | 29 | static inline __uint128_t __load_128_t (const uint64_t s[2]) { 30 | return __set_uint128_t (be64_to_cpu (s[0]), be64_to_cpu (s[1])); 31 | } 32 | 33 | static inline __uint128_t __load_128_t_with_padding (const uint8_t *src, size_t n) { 34 | uint64_t buf[2] = { 0 }; 35 | memcpy (buf, src, n); 36 | return __load_128_t (buf); 37 | } 38 | 39 | static inline void __store_128_t (uint64_t s[2], __uint128_t x) { 40 | s[0] = cpu_to_be64 (x >> 64); 41 | s[1] = cpu_to_be64 (x); 42 | } 43 | 44 | #if defined (__MC_GHASH_LARGE_TABLES) 45 | #define __t_width 8 // coefficient window 46 | #define __t_tables 16 // 128 / t_width 47 | #define __t_size 4096 // 2^t_width * t_tables 48 | #else 49 | #define __t_width 4 50 | #define __t_tables 32 51 | #define __t_size 512 52 | #endif 53 | 54 | static inline __uint128_t __gfmul (__uint128_t a, __uint128_t b) { 55 | __uint128_t z = 0, 56 | v = a; 57 | for (int i = 0; i < 128; i ++) { 58 | if ((uint64_t) (b >> (127 - i)) & 1) 59 | z = z ^ v; 60 | v = (uint64_t) v & 1 ? (v >> 1) ^ r : v >> 1; 61 | } 62 | return z; 63 | } 64 | 65 | // NB Exponents are reversed. 66 | // TODO: Fast table derivation. 67 | static inline void __derive (uint64_t key[2], __uint128_t m[__t_size]) { 68 | __uint128_t e = 1 << (__t_width - 1), 69 | h = __load_128_t (key); 70 | for (int i = 0; i < __t_tables; i ++, e <<= __t_width) { 71 | __uint128_t exph = __gfmul (h, e); 72 | for (int j = 0; j < (1 << __t_width); j ++) 73 | m[(i << __t_width) | j] = __gfmul (exph, (__uint128_t) j << (128 - __t_width)); 74 | } 75 | } 76 | 77 | #define __t_mask ((1 << __t_width) - 1) 78 | static inline __uint128_t __gfmul_tab (__uint128_t m[__t_size], __uint128_t x) { 79 | __uint128_t r = 0; 80 | for (int i = 0; i < __t_tables; i ++) 81 | r ^= m[(i << __t_width) | ((uint8_t) (x >> (i * __t_width)) & __t_mask)]; 82 | return r; 83 | } 84 | 85 | static inline void __ghash (__uint128_t m[__t_size], uint64_t hash[2], const uint8_t *src, size_t n) { 86 | __uint128_t acc = __load_128_t (hash); 87 | for (; n >= 16; src += 16, n -= 16) 88 | acc = __gfmul_tab (m, acc ^ __load_128_t ((uint64_t *) src)); 89 | if (n > 0) 90 | acc = __gfmul_tab (m, acc ^ __load_128_t_with_padding (src, n)); 91 | __store_128_t (hash, acc); 92 | } 93 | 94 | CAMLprim value mc_ghash_key_size_generic (__unit ()) { 95 | return Val_int (sizeof (__uint128_t) * __t_size); 96 | } 97 | 98 | CAMLprim value mc_ghash_init_key_generic (value key, value m) { 99 | __derive ((uint64_t *) _st_uint8 (key), (__uint128_t *) Bp_val (m)); 100 | return Val_unit; 101 | } 102 | 103 | CAMLprim value 104 | mc_ghash_generic (value m, value hash, value src, value off, value len) { 105 | __ghash ((__uint128_t *) Bp_val (m), (uint64_t *) Bp_val (hash), 106 | _st_uint8_off (src, off), Int_val (len) ); 107 | return Val_unit; 108 | } 109 | 110 | #endif /* ARCH_64BIT */ 111 | -------------------------------------------------------------------------------- /src/native/mirage_crypto.h: -------------------------------------------------------------------------------- 1 | #if !defined (H__MIRAGE_CRYPTO) 2 | #define H__MIRAGE_CRYPTO 3 | 4 | #include 5 | #include 6 | #include "bitfn.h" 7 | 8 | #include 9 | 10 | #ifdef ACCELERATE 11 | # ifdef _MSC_VER 12 | # include 13 | # else 14 | # include 15 | # endif 16 | #define __mc_ACCELERATE__ 17 | #define __mc_detect_features__ 18 | #endif 19 | 20 | #ifdef ENTROPY 21 | #define __mc_ENTROPY__ 22 | #define __mc_detect_features__ 23 | #endif 24 | 25 | #ifdef __mc_detect_features__ 26 | 27 | struct _mc_cpu_features { 28 | int aesni; 29 | int pclmul; 30 | int ssse3; 31 | int rdrand; 32 | int rdseed; 33 | }; 34 | 35 | /* Supported accelerations */ 36 | extern struct _mc_cpu_features mc_detected_cpu_features; 37 | 38 | #endif /* __mc_detect_features__ */ 39 | 40 | #ifdef __mc_ACCELERATE__ 41 | 42 | #define _mc_switch_accel(FEATURE, GENERIC_CALL, ACCELERATED_CALL) \ 43 | if (!(mc_detected_cpu_features.FEATURE)) { GENERIC_CALL; } \ 44 | else { ACCELERATED_CALL; } 45 | 46 | #else /* __mc_ACCELERATE__ */ 47 | 48 | #define _mc_switch_accel(_FEATURE, GENERIC_CALL, _ACCELERATED_CALL) \ 49 | GENERIC_CALL; 50 | 51 | #endif /* __mc_ACCELERATE__ */ 52 | 53 | #if defined (__x86_64__) || defined (__aarch64__) || defined (__powerpc64__) || defined (__ppc64__) || (64 == __riscv_xlen) || defined (__s390x__) || (defined (__mips__) && _MIPS_SIM==_ABI64) || defined (__loongarch_lp64) || (1 == _WIN64) 54 | #define ARCH_64BIT 55 | #elif defined (__i386__) || defined (__arm__) || (32 == __riscv_xlen) || (defined (__mips__) && _MIPS_SIM==_ABIO32) || defined (__ppc__) || (1 == _WIN32) 56 | #define ARCH_32BIT 57 | #else 58 | #error "unsupported platform" 59 | #endif 60 | 61 | #ifndef __unused 62 | # if defined(_MSC_VER) && _MSC_VER >= 1500 63 | # define __unused(x) __pragma( warning (push) ) \ 64 | __pragma( warning (disable:4189 ) ) \ 65 | x \ 66 | __pragma( warning (pop)) 67 | # else 68 | # define __unused(x) x __attribute__((unused)) 69 | # endif 70 | #endif 71 | #define __unit() value __unused(_) 72 | 73 | #define _st_uint8(v) ((const uint8_t*) (String_val(v))) 74 | #define _st_uint32(v) ((const uint32_t*) (String_val(v))) 75 | #define _st_uint8_off(v, off) ((const uint8_t*)(String_val(v) + Long_val(off))) 76 | 77 | #define _bp_uint8_off(bp, off) ((uint8_t *) Bp_val (bp) + Long_val (off)) 78 | #define _bp_uint8(bp) ((uint8_t *) Bp_val (bp)) 79 | #define _bp_uint32(bp) ((uint32_t *) Bp_val (bp)) 80 | 81 | #define __define_bc_6(f) \ 82 | CAMLprim value f ## _bc (value *v, int __unused(c) ) { return f(v[0], v[1], v[2], v[3], v[4], v[5]); } 83 | 84 | #define __define_bc_7(f) \ 85 | CAMLprim value f ## _bc (value *v, int __unused(c) ) { return f(v[0], v[1], v[2], v[3], v[4], v[5], v[6]); } 86 | 87 | /* Signature of generic functions */ 88 | 89 | CAMLprim value mc_aes_rk_size_generic (value rounds); 90 | 91 | CAMLprim value 92 | mc_aes_derive_e_key_generic (value key, value rk, value rounds); 93 | 94 | CAMLprim value 95 | mc_aes_derive_d_key_generic (value key, value kr, value rounds, value __unused (rk)); 96 | 97 | CAMLprim value 98 | mc_aes_enc_generic (value src, value off1, value dst, value off2, value rk, value rounds, value blocks); 99 | 100 | CAMLprim value 101 | mc_aes_dec_generic (value src, value off1, value dst, value off2, value rk, value rounds, value blocks); 102 | 103 | CAMLprim value mc_ghash_key_size_generic (__unit ()); 104 | 105 | CAMLprim value mc_ghash_init_key_generic (value key, value m); 106 | 107 | CAMLprim value 108 | mc_ghash_generic (value m, value hash, value src, value off, value len); 109 | 110 | CAMLprim value 111 | mc_xor_into_generic (value b1, value off1, value b2, value off2, value n); 112 | 113 | CAMLprim value 114 | mc_xor_into_bytes_generic (value b1, value off1, value b2, value off2, value n); 115 | 116 | CAMLprim value 117 | mc_count_16_be_4_generic (value ctr, value dst, value off, value blocks); 118 | 119 | #endif /* H__MIRAGE_CRYPTO */ 120 | -------------------------------------------------------------------------------- /rng/fortuna.ml: -------------------------------------------------------------------------------- 1 | (* NOTE: when modifying this file, please also check whether 2 | rng/miou/pfortuna.ml needs to be updated. *) 3 | 4 | open Mirage_crypto 5 | open Mirage_crypto.Uncommon 6 | 7 | module SHAd256 = struct 8 | open Digestif 9 | type t = SHA256.t 10 | type ctx = SHA256.ctx 11 | let empty = SHA256.empty 12 | let get t = SHA256.(get t |> to_raw_string |> digest_string |> to_raw_string) 13 | let digest x = SHA256.(digest_string x |> to_raw_string |> digest_string |> to_raw_string) 14 | let digesti i = SHA256.(digesti_string i |> to_raw_string |> digest_string |> to_raw_string) 15 | let feedi = SHA256.feedi_string 16 | end 17 | 18 | let block = 16 19 | 20 | (* the minimal amount of bytes in a pool to trigger a reseed *) 21 | let min_pool_size = 64 22 | (* the minimal duration between two reseeds *) 23 | let min_time_duration = 1_000_000_000L 24 | (* number of pools *) 25 | let pools = 32 26 | 27 | (* XXX Locking!! *) 28 | type g = 29 | { mutable ctr : AES.CTR.ctr 30 | ; mutable secret : string 31 | ; mutable key : AES.CTR.key 32 | ; pools : SHAd256.ctx array 33 | ; mutable pool0_size : int 34 | ; mutable reseed_count : int 35 | ; mutable last_reseed : int64 36 | ; time : (unit -> int64) option 37 | } 38 | 39 | let create ?time () = 40 | let k = String.make 32 '\x00' in 41 | { ctr = (0L, 0L) 42 | ; secret = k 43 | ; key = AES.CTR.of_secret k 44 | ; pools = Array.make pools SHAd256.empty 45 | ; pool0_size = 0 46 | ; reseed_count = 0 47 | ; last_reseed = 0L 48 | ; time 49 | } 50 | 51 | let seeded ~g = 52 | let lo, hi = g.ctr in 53 | not (Int64.equal lo 0L && Int64.equal hi 0L) 54 | 55 | (* XXX We might want to erase the old key. *) 56 | let set_key ~g sec = 57 | g.secret <- sec ; 58 | g.key <- AES.CTR.of_secret sec 59 | 60 | let reseedi ~g iter = 61 | set_key ~g @@ SHAd256.digesti (fun f -> f g.secret; iter f); 62 | g.ctr <- AES.CTR.add_ctr g.ctr 1L 63 | 64 | let iter1 a f = f a 65 | 66 | let reseed ~g cs = reseedi ~g (iter1 cs) 67 | 68 | let generate_rekey ~g buf ~off len = 69 | let b = len // block + 2 in 70 | let n = b * block in 71 | let r = AES.CTR.stream ~key:g.key ~ctr:g.ctr n in 72 | Bytes.unsafe_blit_string r 0 buf off len; 73 | let r2 = String.sub r (n - 32) 32 in 74 | set_key ~g r2 ; 75 | g.ctr <- AES.CTR.add_ctr g.ctr (Int64.of_int b) 76 | 77 | let add_pool_entropy g = 78 | if g.pool0_size > min_pool_size then 79 | let should_reseed, now = 80 | match g.time with 81 | | None -> true, 0L 82 | | Some f -> 83 | let now = f () in 84 | Int64.(sub now g.last_reseed > min_time_duration), now 85 | in 86 | if should_reseed then begin 87 | g.reseed_count <- g.reseed_count + 1; 88 | g.last_reseed <- now; 89 | g.pool0_size <- 0; 90 | reseedi ~g @@ fun add -> 91 | for i = 0 to pools - 1 do 92 | if g.reseed_count land ((1 lsl i) - 1) = 0 then 93 | (SHAd256.get g.pools.(i) |> add; g.pools.(i) <- SHAd256.empty) 94 | done 95 | end 96 | 97 | let generate_into ~g buf ~off len = 98 | add_pool_entropy g; 99 | if not (seeded ~g) then raise Rng.Unseeded_generator ; 100 | let rec chunk off = function 101 | | i when i <= 0 -> () 102 | | n -> 103 | let n' = imin n 0x10000 in 104 | generate_rekey ~g buf ~off n'; 105 | chunk (off + n') (n - n') 106 | in 107 | chunk off len 108 | 109 | let add ~g (source, _) ~pool data = 110 | let buf = Bytes.create 2 111 | and pool = pool land (pools - 1) 112 | and source = source land 0xff in 113 | Bytes.set_uint8 buf 0 source; 114 | Bytes.set_uint8 buf 1 (String.length data); 115 | g.pools.(pool) <- SHAd256.feedi g.pools.(pool) (iter2 (Bytes.unsafe_to_string buf) data); 116 | if pool = 0 then g.pool0_size <- g.pool0_size + String.length data 117 | 118 | (* XXX 119 | * Schneier recommends against using generator-imposed pool-seeding schedule 120 | * but it just makes for a horrid api. 121 | *) 122 | let accumulate ~g source = 123 | let pool = ref 0 in 124 | `Acc (fun buf -> 125 | add ~g source ~pool:!pool buf ; 126 | incr pool) 127 | -------------------------------------------------------------------------------- /tests/wycheproof/wycheproof.ml: -------------------------------------------------------------------------------- 1 | type json = Yojson.Safe.t [@@deriving of_yojson] 2 | 3 | let pp_json = Yojson.Safe.pretty_print 4 | 5 | type hex = string [@@deriving eq] 6 | 7 | let pp_hex fmt buf = 8 | let n = String.length buf in 9 | let bbuf = Bytes.unsafe_of_string buf in 10 | for i = n - 1 downto 0 do 11 | let byte = Bytes.get_uint8 bbuf i in 12 | Format.fprintf fmt "%02x" byte 13 | done 14 | 15 | let hex_of_string s = 16 | let fold f acc str = 17 | let st = ref acc in 18 | String.iter (fun c -> st := f !st c) str; 19 | !st 20 | and digit c = 21 | match c with 22 | | '0'..'9' -> int_of_char c - 0x30 23 | | 'A'..'F' -> int_of_char c - 0x41 + 10 24 | | 'a'..'f' -> int_of_char c - 0x61 + 10 25 | | _ -> invalid_arg "bad character" 26 | in 27 | let out = Bytes.create (String.length s / 2) in 28 | let _idx, leftover = 29 | fold (fun (idx, leftover) c -> 30 | let c = digit c in 31 | match leftover with 32 | | None -> idx, Some (c lsl 4) 33 | | Some c' -> 34 | Bytes.set_uint8 out idx (c' lor c); 35 | succ idx, None) 36 | (0, None) s 37 | in 38 | assert (leftover = None); 39 | Bytes.unsafe_to_string out 40 | 41 | let hex_of_yojson json = 42 | let padded s = if String.length s mod 2 = 0 then s else "0" ^ s in 43 | match [%of_yojson: string] json with 44 | | Ok s -> Ok (hex_of_string (padded s)) 45 | | Error _ as e -> e 46 | 47 | type test_result = Valid | Acceptable | Invalid [@@deriving show] 48 | 49 | let test_result_of_yojson = function 50 | | `String "valid" -> Ok Valid 51 | | `String "acceptable" -> Ok Acceptable 52 | | `String "invalid" -> Ok Invalid 53 | | _ -> Error "test_result" 54 | 55 | type ecdh_test = { 56 | tcId : int; 57 | comment : string; 58 | curve : json option; [@yojson.default None] 59 | public : hex; 60 | private_ : hex; [@yojson.key "private"] 61 | shared : hex; 62 | result : test_result; 63 | flags : string list; 64 | } 65 | [@@deriving of_yojson, show] 66 | 67 | let has_ignored_flag test ~ignored_flags = 68 | List.exists 69 | (fun ignored_flag -> List.mem ignored_flag test.flags) 70 | ignored_flags 71 | 72 | type ecdh_test_group = { 73 | curve : string; 74 | tests : ecdh_test list; 75 | encoding : json option; [@yojson.default None] 76 | type_ : json option; [@yojson.default None] [@yojson.key "type"] 77 | } 78 | [@@deriving of_yojson, show] 79 | 80 | type ecdsa_key = { 81 | curve : string; 82 | keySize : int; 83 | type_ : json; [@yojson.key "type"] 84 | uncompressed : hex; 85 | wx : hex; 86 | wy : hex; 87 | } 88 | [@@deriving of_yojson, show] 89 | 90 | type dsa_test = { 91 | tcId : int; 92 | comment : string; 93 | msg : hex; 94 | sig_ : hex; [@yojson.key "sig"] 95 | result : test_result; 96 | flags : string list; 97 | } 98 | [@@deriving of_yojson, show] 99 | 100 | type ecdsa_test_group = { 101 | key : ecdsa_key; 102 | keyDer : string; 103 | keyPem : string; 104 | sha : string; 105 | tests : dsa_test list; 106 | type_ : json option; [@yojson.default None] [@yojson.key "type"] 107 | } 108 | [@@deriving of_yojson, show] 109 | 110 | type eddsa_key = { 111 | curve : string; 112 | keySize : int; 113 | pk : hex; 114 | sk : hex; 115 | type_ : json; [@yojson.key "type"] 116 | } 117 | [@@deriving of_yojson, show] 118 | 119 | type eddsa_test_group = { 120 | jwk : json; 121 | key : eddsa_key; 122 | keyDer : string; 123 | keyPem : string; 124 | type_ : json; [@yojson.key "type"] 125 | tests : dsa_test list; 126 | } 127 | [@@deriving of_yojson, show] 128 | 129 | type test_file = { 130 | algorithm : json; 131 | generatorVersion : json; 132 | header : json; 133 | notes : json; 134 | numberOfTests : json; 135 | schema : json; 136 | testGroups : json list; 137 | } 138 | [@@deriving of_yojson, show] 139 | 140 | let get_json = function Ok x -> x | Error s -> failwith s 141 | 142 | let load_file_exn path = 143 | Yojson.Safe.from_file path |> [%of_yojson: test_file] |> get_json 144 | 145 | let ecdh_test_group_exn json = [%of_yojson: ecdh_test_group] json |> get_json 146 | 147 | let ecdsa_test_group_exn json = [%of_yojson: ecdsa_test_group] json |> get_json 148 | 149 | let eddsa_test_group_exn json = [%of_yojson: eddsa_test_group] json |> get_json 150 | -------------------------------------------------------------------------------- /tests/misc_pk.ml: -------------------------------------------------------------------------------- 1 | 2 | let mem f = 3 | let t = Hashtbl.create 100 in 4 | fun x -> 5 | try Hashtbl.find t x with 6 | | Not_found -> 7 | let r = f x in ( Hashtbl.add t x r ; r ) 8 | 9 | 10 | (* An [admittedly primitive] implementation of Pollards p-1 factoring method. *) 11 | 12 | module Pollard = struct 13 | 14 | let primes_to n = 15 | let rec scan = function 16 | | p when p > n -> [] 17 | | p -> p :: scan Z.(nextprime p) in 18 | scan (Z.of_int 2) 19 | 20 | let max_pow limit x = 21 | let rec expand lower upper = 22 | if Z.(pow x upper) > limit then (lower, upper) 23 | else expand upper (upper * 2) 24 | and narrow lower upper = 25 | if upper - lower = 1 then lower else 26 | let mid = (lower + upper) / 2 in 27 | if Z.(pow x mid) > limit then 28 | narrow lower mid 29 | else narrow mid upper 30 | in 31 | let (l, u) = expand 1 2 in 32 | narrow l u 33 | 34 | let ppowers_to n = 35 | let rec scan = function 36 | | p when p > n -> [] 37 | | p -> 38 | let pp = Z.pow p (max_pow n p) in 39 | pp :: scan Z.(nextprime p) in 40 | scan (Z.of_int 2) 41 | 42 | let note ~msg f = 43 | Printf.printf "[%s] ->\n%!" msg ; 44 | let r = f () in 45 | Printf.printf "[%s] <-\n%!" msg ; 46 | r 47 | 48 | let prime_pows_to_prod = mem @@ fun n -> 49 | let rec scan acc = function 50 | | p when p > n -> acc 51 | | p -> scan Z.(acc * (pow p (max_pow n p))) 52 | Z.(nextprime p) in 53 | note ~msg:"powers" @@ fun () -> 54 | scan Z.one Z.(of_int 2) 55 | 56 | let split ~limit n = 57 | let a = Nums.Z.gen n in 58 | match Z.gcd n a with 59 | | d when d > Z.one -> a 60 | | d -> 61 | let rec scan a m = 62 | let x = Z.(powm a (m * n) n) in 63 | if Z.(x = one) then 64 | if Z.(m mod of_int 2 = zero) then 65 | scan a Z.(m / of_int 2) 66 | else raise Not_found 67 | else 68 | let d = Z.(gcd (x - one) n) in 69 | if Z.(d > one) then d else raise Not_found 70 | in 71 | scan a (prime_pows_to_prod limit) 72 | 73 | end 74 | 75 | module RSA_misc = struct 76 | 77 | let slack = 8 78 | 79 | (* Rivest's p-minus strong prime generator. *) 80 | 81 | let rec pm_strong_prime ?g ~bits = 82 | let a_lim = Z.(pow z_two slack - one) 83 | in 84 | let rec mul_seq p = function 85 | | a when a > a_lim -> 86 | Printf.printf "++ mul seq: falling off the cliff.\n%!"; 87 | None 88 | | a -> 89 | let p' = Z.(a * p + one) in 90 | match Z.probab_prime p' 25 with 91 | | 0 -> 92 | Printf.printf "+ mul seq: climb.\n%!"; 93 | mul_seq p Z.(a + z_two) 94 | | _ -> 95 | Printf.printf "** mul seq: prime with %s\n%!" Z.(to_string a); 96 | Some p' 97 | in 98 | let pmm = prime ?g ~bits in 99 | match mul_seq pmm z_two with 100 | | None -> pm_strong_prime ?g ~bits 101 | | Some pm -> 102 | match mul_seq pm z_two with 103 | | None -> pm_strong_prime ?g ~bits 104 | | Some p -> (pmm, pm, p) 105 | 106 | let slim = Z.(pow z_two 8) 107 | 108 | (* Williams/Schmid strong prime generator. *) 109 | 110 | let rec p_strong_prime1 ?g ~bits = 111 | let (bits1, bits2) = (bits / 2, bits - bits / 2) 112 | in 113 | let pmm = prime ?g ~bits:bits1 114 | and pp = prime ?g ~bits:bits2 in 115 | let r = Z.(pp - invert pmm pp) 116 | in 117 | let rec find_a = function 118 | | a when a >= slim -> 119 | Printf.printf "off the cliff...\n%!" ; 120 | p_strong_prime1 ?g ~bits 121 | | a -> 122 | let pm = Z.(z_two * a * pmm * pp + z_two * r * pmm + one) in 123 | match Z.probab_prime pm 25 with 124 | | 0 -> find_a Z.(a + one) 125 | | _ -> 126 | let p = Z.(z_two * pm + one) in 127 | match Z.probab_prime p 25 with 128 | | 0 -> find_a Z.(a + one) 129 | | _ -> 130 | Printf.printf "found pm, p with %s\n%!" Z.(to_string a); 131 | (pmm, pm, pp, p) 132 | in 133 | find_a z_two 134 | 135 | end 136 | -------------------------------------------------------------------------------- /ec/native/p384_stubs.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | /* Microsoft compiler does not support 128-bit integers. Drop down to 4 | * 32-bit for MSVC. 5 | */ 6 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 7 | #include "p384_64.h" 8 | #define LIMBS 6 9 | #define WORD uint64_t 10 | #define WORDSIZE 64 11 | #include "p384_tables_64.h" 12 | #else 13 | #include "p384_32.h" 14 | #define LIMBS 12 15 | #define WORD uint32_t 16 | #define WORDSIZE 32 17 | #include "p384_tables_32.h" 18 | #endif 19 | 20 | #define LEN_PRIME 384 21 | #define CURVE_DESCRIPTION fiat_p384 22 | 23 | #include "inversion_template.h" 24 | #include "point_operations.h" 25 | 26 | #include 27 | 28 | CAMLprim value mc_p384_sub(value out, value a, value b) 29 | { 30 | CAMLparam3(out, a, b); 31 | fiat_p384_sub((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 32 | CAMLreturn(Val_unit); 33 | } 34 | 35 | CAMLprim value mc_p384_add(value out, value a, value b) 36 | { 37 | CAMLparam3(out, a, b); 38 | fiat_p384_add((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 39 | CAMLreturn(Val_unit); 40 | } 41 | 42 | CAMLprim value mc_p384_mul(value out, value a, value b) 43 | { 44 | CAMLparam3(out, a, b); 45 | fiat_p384_mul((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 46 | CAMLreturn(Val_unit); 47 | } 48 | 49 | CAMLprim value mc_p384_from_bytes(value out, value in) 50 | { 51 | CAMLparam2(out, in); 52 | fiat_p384_from_bytes((WORD*)Bytes_val(out), _st_uint8(in)); 53 | CAMLreturn(Val_unit); 54 | } 55 | 56 | CAMLprim value mc_p384_to_bytes(value out, value in) 57 | { 58 | CAMLparam2(out, in); 59 | fiat_p384_to_bytes(Bytes_val(out), (const WORD*)String_val(in)); 60 | CAMLreturn(Val_unit); 61 | } 62 | 63 | CAMLprim value mc_p384_sqr(value out, value in) 64 | { 65 | CAMLparam2(out, in); 66 | fiat_p384_square((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 67 | CAMLreturn(Val_unit); 68 | } 69 | 70 | CAMLprim value mc_p384_from_montgomery(value out, value in) 71 | { 72 | CAMLparam2(out, in); 73 | fiat_p384_from_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 74 | CAMLreturn(Val_unit); 75 | } 76 | 77 | CAMLprim value mc_p384_to_montgomery(value out, value in) 78 | { 79 | CAMLparam2(out, in); 80 | fiat_p384_to_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 81 | CAMLreturn(Val_unit); 82 | } 83 | 84 | CAMLprim value mc_p384_nz(value x) 85 | { 86 | CAMLparam1(x); 87 | CAMLreturn(Val_bool(fe_nz((const WORD*)String_val(x)))); 88 | } 89 | 90 | CAMLprim value mc_p384_set_one(value x) 91 | { 92 | CAMLparam1(x); 93 | fiat_p384_set_one((WORD*)Bytes_val(x)); 94 | CAMLreturn(Val_unit); 95 | } 96 | 97 | CAMLprim value mc_p384_inv(value out, value in) 98 | { 99 | CAMLparam2(out, in); 100 | inversion((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 101 | CAMLreturn(Val_unit); 102 | } 103 | 104 | CAMLprim value mc_p384_point_double(value out, value in) 105 | { 106 | CAMLparam2(out, in); 107 | point_double( 108 | (WORD*)Bytes_val(Field(out, 0)), 109 | (WORD*)Bytes_val(Field(out, 1)), 110 | (WORD*)Bytes_val(Field(out, 2)), 111 | (const WORD*)String_val(Field(in, 0)), 112 | (const WORD*)String_val(Field(in, 1)), 113 | (const WORD*)String_val(Field(in, 2)) 114 | ); 115 | CAMLreturn(Val_unit); 116 | } 117 | 118 | CAMLprim value mc_p384_point_add(value out, value p, value q) 119 | { 120 | CAMLparam3(out, p, q); 121 | point_add( 122 | (WORD*)Bytes_val(Field(out, 0)), 123 | (WORD*)Bytes_val(Field(out, 1)), 124 | (WORD*)Bytes_val(Field(out, 2)), 125 | (const WORD*)String_val(Field(p, 0)), 126 | (const WORD*)String_val(Field(p, 1)), 127 | (const WORD*)String_val(Field(p, 2)), 128 | 0, 129 | (const WORD*)String_val(Field(q, 0)), 130 | (const WORD*)String_val(Field(q, 1)), 131 | (const WORD*)String_val(Field(q, 2)) 132 | ); 133 | CAMLreturn(Val_unit); 134 | } 135 | 136 | CAMLprim value mc_p384_select(value out, value bit, value t, value f) 137 | { 138 | CAMLparam4(out, bit, t, f); 139 | fe_cmovznz( 140 | (WORD*)Bytes_val(out), 141 | Bool_val(bit), 142 | (const WORD*)String_val(f), 143 | (const WORD*)String_val(t) 144 | ); 145 | CAMLreturn(Val_unit); 146 | } 147 | 148 | CAMLprim value mc_p384_scalar_mult_base(value out, value s) 149 | { 150 | CAMLparam2(out, s); 151 | scalar_mult_base( 152 | (WORD *) Bytes_val(Field(out, 0)), 153 | (WORD *) Bytes_val(Field(out, 1)), 154 | (WORD *) Bytes_val(Field(out, 2)), 155 | _st_uint8(s), 156 | caml_string_length(s) 157 | ); 158 | CAMLreturn(Val_unit); 159 | } 160 | -------------------------------------------------------------------------------- /ec/native/p521_stubs.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | /* Microsoft compiler does not support 128-bit integers. Drop down to 4 | * 32-bit for MSVC. 5 | */ 6 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 7 | #include "p521_64.h" 8 | #define LIMBS 9 9 | #define WORD uint64_t 10 | #define WORDSIZE 64 11 | #include "p521_tables_64.h" 12 | #else 13 | #include "p521_32.h" 14 | #define LIMBS 17 15 | #define WORD uint32_t 16 | #define WORDSIZE 32 17 | #include "p521_tables_32.h" 18 | #endif 19 | 20 | #define LEN_PRIME 521 21 | #define CURVE_DESCRIPTION fiat_p521 22 | 23 | #include "inversion_template.h" 24 | #include "point_operations.h" 25 | 26 | #include 27 | 28 | CAMLprim value mc_p521_sub(value out, value a, value b) 29 | { 30 | CAMLparam3(out, a, b); 31 | fiat_p521_sub((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 32 | CAMLreturn(Val_unit); 33 | } 34 | 35 | CAMLprim value mc_p521_add(value out, value a, value b) 36 | { 37 | CAMLparam3(out, a, b); 38 | fiat_p521_add((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 39 | CAMLreturn(Val_unit); 40 | } 41 | 42 | CAMLprim value mc_p521_mul(value out, value a, value b) 43 | { 44 | CAMLparam3(out, a, b); 45 | fiat_p521_mul((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 46 | CAMLreturn(Val_unit); 47 | } 48 | 49 | CAMLprim value mc_p521_from_bytes(value out, value in) 50 | { 51 | CAMLparam2(out, in); 52 | fiat_p521_from_bytes((WORD*)Bytes_val(out), _st_uint8(in)); 53 | CAMLreturn(Val_unit); 54 | } 55 | 56 | CAMLprim value mc_p521_to_bytes(value out, value in) 57 | { 58 | CAMLparam2(out, in); 59 | fiat_p521_to_bytes(Bytes_val(out), (const WORD*)String_val(in)); 60 | CAMLreturn(Val_unit); 61 | } 62 | 63 | CAMLprim value mc_p521_sqr(value out, value in) 64 | { 65 | CAMLparam2(out, in); 66 | fiat_p521_square((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 67 | CAMLreturn(Val_unit); 68 | } 69 | 70 | CAMLprim value mc_p521_from_montgomery(value out, value in) 71 | { 72 | CAMLparam2(out, in); 73 | fiat_p521_from_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 74 | CAMLreturn(Val_unit); 75 | } 76 | 77 | CAMLprim value mc_p521_to_montgomery(value out, value in) 78 | { 79 | CAMLparam2(out, in); 80 | fiat_p521_to_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 81 | CAMLreturn(Val_unit); 82 | } 83 | 84 | CAMLprim value mc_p521_nz(value x) 85 | { 86 | CAMLparam1(x); 87 | CAMLreturn(Val_bool(fe_nz((const WORD*)String_val(x)))); 88 | } 89 | 90 | CAMLprim value mc_p521_set_one(value x) 91 | { 92 | CAMLparam1(x); 93 | fiat_p521_set_one((WORD*)Bytes_val(x)); 94 | CAMLreturn(Val_unit); 95 | } 96 | 97 | CAMLprim value mc_p521_inv(value out, value in) 98 | { 99 | CAMLparam2(out, in); 100 | inversion((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 101 | CAMLreturn(Val_unit); 102 | } 103 | 104 | CAMLprim value mc_p521_point_double(value out, value in) 105 | { 106 | CAMLparam2(out, in); 107 | point_double( 108 | (WORD*)Bytes_val(Field(out, 0)), 109 | (WORD*)Bytes_val(Field(out, 1)), 110 | (WORD*)Bytes_val(Field(out, 2)), 111 | (const WORD*)String_val(Field(in, 0)), 112 | (const WORD*)String_val(Field(in, 1)), 113 | (const WORD*)String_val(Field(in, 2)) 114 | ); 115 | CAMLreturn(Val_unit); 116 | } 117 | 118 | CAMLprim value mc_p521_point_add(value out, value p, value q) 119 | { 120 | CAMLparam3(out, p, q); 121 | point_add( 122 | (WORD*)Bytes_val(Field(out, 0)), 123 | (WORD*)Bytes_val(Field(out, 1)), 124 | (WORD*)Bytes_val(Field(out, 2)), 125 | (const WORD*)String_val(Field(p, 0)), 126 | (const WORD*)String_val(Field(p, 1)), 127 | (const WORD*)String_val(Field(p, 2)), 128 | 0, 129 | (const WORD*)String_val(Field(q, 0)), 130 | (const WORD*)String_val(Field(q, 1)), 131 | (const WORD*)String_val(Field(q, 2)) 132 | ); 133 | CAMLreturn(Val_unit); 134 | } 135 | 136 | CAMLprim value mc_p521_select(value out, value bit, value t, value f) 137 | { 138 | CAMLparam4(out, bit, t, f); 139 | fe_cmovznz( 140 | (WORD*)Bytes_val(out), 141 | Bool_val(bit), 142 | (const WORD*)String_val(f), 143 | (const WORD*)String_val(t) 144 | ); 145 | CAMLreturn(Val_unit); 146 | } 147 | 148 | CAMLprim value mc_p521_scalar_mult_base(value out, value s) 149 | { 150 | CAMLparam2(out, s); 151 | scalar_mult_base( 152 | (WORD *) Bytes_val(Field(out, 0)), 153 | (WORD *) Bytes_val(Field(out, 1)), 154 | (WORD *) Bytes_val(Field(out, 2)), 155 | _st_uint8(s), 156 | caml_string_length(s) 157 | ); 158 | CAMLreturn(Val_unit); 159 | } 160 | -------------------------------------------------------------------------------- /ec/native/p256_stubs.c: -------------------------------------------------------------------------------- 1 | #include "mirage_crypto.h" 2 | 3 | /* Microsoft compiler does not support 128-bit integers. Drop down to 4 | * 32-bit for MSVC. 5 | */ 6 | #if defined(ARCH_64BIT) && !defined(_MSC_VER) 7 | #include "p256_64.h" 8 | #define LIMBS 4 9 | #define WORD uint64_t 10 | #define WORDSIZE 64 11 | #include "p256_tables_64.h" 12 | #else 13 | #include "p256_32.h" 14 | #define LIMBS 8 15 | #define WORD uint32_t 16 | #define WORDSIZE 32 17 | #include "p256_tables_32.h" 18 | #endif 19 | 20 | #define LEN_PRIME 256 21 | #define CURVE_DESCRIPTION fiat_p256 22 | 23 | #include "inversion_template.h" 24 | #include "point_operations.h" 25 | 26 | #include 27 | 28 | CAMLprim value mc_p256_sub(value out, value a, value b) 29 | { 30 | CAMLparam3(out, a, b); 31 | fiat_p256_sub((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 32 | CAMLreturn(Val_unit); 33 | } 34 | 35 | CAMLprim value mc_p256_add(value out, value a, value b) 36 | { 37 | CAMLparam3(out, a, b); 38 | fiat_p256_add((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 39 | CAMLreturn(Val_unit); 40 | } 41 | 42 | CAMLprim value mc_p256_mul(value out, value a, value b) 43 | { 44 | CAMLparam3(out, a, b); 45 | fiat_p256_mul((WORD*)Bytes_val(out), (const WORD*)String_val(a), (const WORD*)String_val(b)); 46 | CAMLreturn(Val_unit); 47 | } 48 | 49 | CAMLprim value mc_p256_from_bytes(value out, value in) 50 | { 51 | CAMLparam2(out, in); 52 | fiat_p256_from_bytes((WORD*)Bytes_val(out), _st_uint8(in)); 53 | CAMLreturn(Val_unit); 54 | } 55 | 56 | CAMLprim value mc_p256_to_bytes(value out, value in) 57 | { 58 | CAMLparam2(out, in); 59 | fiat_p256_to_bytes(Bytes_val(out), (const WORD*)String_val(in)); 60 | CAMLreturn(Val_unit); 61 | } 62 | 63 | CAMLprim value mc_p256_sqr(value out, value in) 64 | { 65 | CAMLparam2(out, in); 66 | fiat_p256_square((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 67 | CAMLreturn(Val_unit); 68 | } 69 | 70 | CAMLprim value mc_p256_from_montgomery(value out, value in) 71 | { 72 | CAMLparam2(out, in); 73 | fiat_p256_from_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 74 | CAMLreturn(Val_unit); 75 | } 76 | 77 | CAMLprim value mc_p256_to_montgomery(value out, value in) 78 | { 79 | CAMLparam2(out, in); 80 | fiat_p256_to_montgomery((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 81 | CAMLreturn(Val_unit); 82 | } 83 | 84 | CAMLprim value mc_p256_nz(value x) 85 | { 86 | CAMLparam1(x); 87 | CAMLreturn(Val_bool(fe_nz((const WORD*)String_val(x)))); 88 | } 89 | 90 | CAMLprim value mc_p256_set_one(value x) 91 | { 92 | CAMLparam1(x); 93 | fiat_p256_set_one((WORD*)Bytes_val(x)); 94 | CAMLreturn(Val_unit); 95 | } 96 | 97 | CAMLprim value mc_p256_inv(value out, value in) 98 | { 99 | CAMLparam2(out, in); 100 | inversion((WORD*)Bytes_val(out), (const WORD*)String_val(in)); 101 | CAMLreturn(Val_unit); 102 | } 103 | 104 | CAMLprim value mc_p256_point_double(value out, value in) 105 | { 106 | CAMLparam2(out, in); 107 | point_double( 108 | (WORD*)Bytes_val(Field(out, 0)), 109 | (WORD*)Bytes_val(Field(out, 1)), 110 | (WORD*)Bytes_val(Field(out, 2)), 111 | (const WORD*)String_val(Field(in, 0)), 112 | (const WORD*)String_val(Field(in, 1)), 113 | (const WORD*)String_val(Field(in, 2)) 114 | ); 115 | CAMLreturn(Val_unit); 116 | } 117 | 118 | CAMLprim value mc_p256_point_add(value out, value p, value q) 119 | { 120 | CAMLparam3(out, p, q); 121 | point_add( 122 | (WORD*)Bytes_val(Field(out, 0)), 123 | (WORD*)Bytes_val(Field(out, 1)), 124 | (WORD*)Bytes_val(Field(out, 2)), 125 | (const WORD*)String_val(Field(p, 0)), 126 | (const WORD*)String_val(Field(p, 1)), 127 | (const WORD*)String_val(Field(p, 2)), 128 | 0, 129 | (const WORD*)String_val(Field(q, 0)), 130 | (const WORD*)String_val(Field(q, 1)), 131 | (const WORD*)String_val(Field(q, 2)) 132 | ); 133 | CAMLreturn(Val_unit); 134 | } 135 | 136 | CAMLprim value mc_p256_select(value out, value bit, value t, value f) 137 | { 138 | CAMLparam4(out, bit, t, f); 139 | fe_cmovznz( 140 | (WORD*)Bytes_val(out), 141 | Bool_val(bit), 142 | (const WORD*)String_val(f), 143 | (const WORD*)String_val(t) 144 | ); 145 | CAMLreturn(Val_unit); 146 | } 147 | 148 | 149 | CAMLprim value mc_p256_scalar_mult_base(value out, value s) 150 | { 151 | CAMLparam2(out, s); 152 | scalar_mult_base( 153 | (WORD *) Bytes_val(Field(out, 0)), 154 | (WORD *) Bytes_val(Field(out, 1)), 155 | (WORD *) Bytes_val(Field(out, 2)), 156 | _st_uint8(s), 157 | caml_string_length(s) 158 | ); 159 | CAMLreturn(Val_unit); 160 | } 161 | -------------------------------------------------------------------------------- /tests/test_random_runner.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | open Mirage_crypto 4 | 5 | open Test_common 6 | 7 | let sample arr = 8 | let ix = 9 | Randomconv.int ~bound:(Array.length arr) Mirage_crypto_rng.generate 10 | in 11 | arr.(ix) 12 | 13 | (* randomized selfies *) 14 | 15 | let ecb_selftest (m : (module Block.ECB)) n = 16 | let module C = ( val m ) in 17 | "selftest" >:: times ~n @@ fun _ -> 18 | let data = Mirage_crypto_rng.generate (C.block_size * 8) 19 | and key = C.of_secret @@ Mirage_crypto_rng.generate (sample C.key_sizes) in 20 | let data' = 21 | C.( data |> encrypt ~key |> encrypt ~key 22 | |> decrypt ~key |> decrypt ~key ) in 23 | assert_oct_equal ~msg:"ecb mismatch" data data' 24 | 25 | let cbc_selftest (m : (module Block.CBC)) n = 26 | let module C = ( val m ) in 27 | "selftest" >:: times ~n @@ fun _ -> 28 | let data = Mirage_crypto_rng.generate (C.block_size * 8) 29 | and iv = Mirage_crypto_rng.generate C.block_size 30 | and key = C.of_secret @@ Mirage_crypto_rng.generate (sample C.key_sizes) in 31 | assert_oct_equal ~msg:"CBC e->e->d->d" data 32 | C.( data |> encrypt ~key ~iv |> encrypt ~key ~iv 33 | |> decrypt ~key ~iv |> decrypt ~key ~iv ); 34 | let (d1, d2) = 35 | String.sub data 0 (C.block_size * 4), 36 | String.sub data (C.block_size * 4) (String.length data - C.block_size * 4) 37 | in 38 | assert_oct_equal ~msg:"CBC chain" 39 | C.(encrypt ~key ~iv data) 40 | C.( let e1 = encrypt ~key ~iv d1 in 41 | e1 ^ encrypt ~key ~iv:(next_iv ~iv e1) d2) 42 | 43 | let ctr_selftest (m : (module Block.CTR)) n = 44 | let module M = (val m) in 45 | let bs = M.block_size in 46 | "selftest" >:: times ~n @@ fun _ -> 47 | let key = M.of_secret @@ Mirage_crypto_rng.generate (sample M.key_sizes) 48 | and ctr = Mirage_crypto_rng.generate bs |> M.ctr_of_octets 49 | and data = Mirage_crypto_rng.(generate @@ bs + Randomconv.int ~bound:(20 * bs) Mirage_crypto_rng.generate) in 50 | let enc = M.encrypt ~key ~ctr data in 51 | let dec = M.decrypt ~key ~ctr enc in 52 | assert_oct_equal ~msg:"CTR e->d" data dec; 53 | let (d1, d2) = 54 | let s = bs * Randomconv.int ~bound:(String.length data / bs) Mirage_crypto_rng.generate in 55 | String.sub data 0 s, String.sub data s (String.length data - s) 56 | in 57 | assert_oct_equal ~msg:"CTR chain" enc @@ 58 | M.encrypt ~key ~ctr d1 ^ M.encrypt ~key ~ctr:(M.next_ctr ~ctr d1) d2 59 | 60 | let ctr_offsets (type c) ~zero (m : (module Block.CTR with type ctr = c)) n = 61 | let module M = (val m) in 62 | "offsets" >:: fun _ -> 63 | let key = M.of_secret @@ Mirage_crypto_rng.generate M.key_sizes.(0) in 64 | for i = 0 to n - 1 do 65 | let ctr = match i with 66 | | 0 -> M.add_ctr zero (-1L) 67 | | _ -> Mirage_crypto_rng.generate M.block_size |> M.ctr_of_octets 68 | and gap = Randomconv.int ~bound:64 Mirage_crypto_rng.generate in 69 | let s1 = M.stream ~key ~ctr ((gap + 1) * M.block_size) 70 | and s2 = M.stream ~key ~ctr:(M.add_ctr ctr (Int64.of_int gap)) M.block_size in 71 | assert_oct_equal ~msg:"shifted stream" 72 | String.(sub s1 (gap * M.block_size) M.block_size) s2 73 | done 74 | 75 | let xor_selftest n = 76 | "selftest" >:: times ~n @@ fun _ -> 77 | 78 | let n = Randomconv.int ~bound:30 Mirage_crypto_rng.generate in 79 | let (x, y, z) = Mirage_crypto_rng.(generate n, generate n, generate n) in 80 | 81 | let xyz = Uncommon.(xor (xor x y) z) 82 | and xyz' = Uncommon.(xor x (xor y z)) in 83 | let x1 = Uncommon.(xor xyz (xor y z)) 84 | and x2 = Uncommon.(xor (xor z y) xyz) in 85 | 86 | assert_oct_equal ~msg:"assoc" xyz xyz' ; 87 | assert_oct_equal ~msg:"invert" x x1 ; 88 | assert_oct_equal ~msg:"commut" x1 x2 89 | 90 | let suite = 91 | "All" >::: [ 92 | "XOR" >::: [ xor_selftest 300 ] ; 93 | "3DES-ECB" >::: [ ecb_selftest (module DES.ECB) 100 ] ; 94 | 95 | "3DES-CBC" >::: [ cbc_selftest (module DES.CBC) 100 ] ; 96 | 97 | "3DES-CTR" >::: [ ctr_selftest (module DES.CTR) 100; 98 | ctr_offsets (module DES.CTR) 100 ~zero:0L; ] ; 99 | 100 | "AES-ECB" >::: [ ecb_selftest (module AES.ECB) 100 ] ; 101 | "AES-CBC" >::: [ cbc_selftest (module AES.CBC) 100 ] ; 102 | "AES-CTR" >::: [ ctr_selftest (module AES.CTR) 100; 103 | ctr_offsets (module AES.CTR) 100 ~zero:(0L, 0L) ] ; 104 | 105 | ] 106 | 107 | let () = 108 | Mirage_crypto_rng_unix.use_default (); 109 | run_test_tt_main suite 110 | -------------------------------------------------------------------------------- /ec/native/GNUmakefile: -------------------------------------------------------------------------------- 1 | # This file is part of mirage-crypto-ec, and used to generate C files 2 | # As a prerequisite, fiat-crypto (https://github.com/mit-plv/fiat-crypto) 3 | # needs to be cloned and "make standalone-ocaml" invoked 4 | # The lowest bound of fiat-crypto is git commit 5 | # dabaf4b3132e8bb4a3f5fcd8366eec6ac9bb4232 (July 16th 2021) 6 | # Generated on FreeBSD 12.2p2 with coq 8.13.1 (OCaml 4.12.0) 7 | # with fiat-crypto 2a07751f37af74edeac47b19bd51810bc99b91a1 (May 29th 2022) 8 | 9 | WBW_MONT ?= ../../../fiat-crypto/src/ExtractionOCaml/word_by_word_montgomery --static --use-value-barrier --inline-internal 10 | UNSAT_SOLINAS ?= ../../../fiat-crypto/src/ExtractionOCaml/unsaturated_solinas --static --use-value-barrier --inline-internal 11 | N_FUNCS=mul add opp from_montgomery to_montgomery one msat divstep_precomp divstep to_bytes from_bytes selectznz 12 | 13 | GEN_TABLE=../../_build/default/ec/gen_tables/gen_tables.exe 14 | 15 | # The NIST curve P-256 (AKA SECP256R1) 16 | P256="2^256 - 2^224 + 2^192 + 2^96 - 1" 17 | 18 | .PHONY: p256_64.h 19 | p256_64.h: 20 | $(WBW_MONT) p256 64 $(P256) > $@ 21 | 22 | .PHONY: p256_32.h 23 | p256_32.h: 24 | $(WBW_MONT) p256 32 $(P256) > $@ 25 | 26 | # The group order N of P-256 27 | P256N="0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551" 28 | 29 | .PHONY: np256_64.h 30 | np256_64.h: 31 | $(WBW_MONT) np256 64 $(P256N) $(N_FUNCS) > $@ 32 | 33 | .PHONY: np256_32.h 34 | np256_32.h: 35 | $(WBW_MONT) np256 32 $(P256N) $(N_FUNCS) > $@ 36 | 37 | .PHONY: p256_tables_64.h 38 | p256_tables_64.h: 39 | $(GEN_TABLE) p256 64 > $@ 40 | 41 | .PHONY: p256_tables_32.h 42 | p256_tables_32.h: 43 | $(GEN_TABLE) p256 32 > $@ 44 | 45 | .PHONY: p256 46 | p256: p256_64.h p256_32.h np256_64.h np256_32.h 47 | 48 | p256_tables: p256_tables_64.h p256_tables_32.h 49 | 50 | # The NIST curve P-384 (AKA SECP384R1) 51 | P384="2^384 - 2^128 - 2^96 + 2^32 - 1" 52 | 53 | .PHONY: p384_64.h 54 | p384_64.h: 55 | $(WBW_MONT) p384 64 $(P384) > $@ 56 | 57 | .PHONY: p384_32.h 58 | p384_32.h: 59 | $(WBW_MONT) p384 32 $(P384) > $@ 60 | 61 | # The group order N of P-384 62 | P384N="0xffffffffffffffffffffffffffffffffffffffffffffffffc7634d81f4372ddf581a0db248b0a77aecec196accc52973" 63 | 64 | .PHONY: np384_64.h 65 | np384_64.h: 66 | $(WBW_MONT) np384 64 $(P384N) $(N_FUNCS) > $@ 67 | 68 | .PHONY: np384_32.h 69 | np384_32.h: 70 | $(WBW_MONT) np384 32 $(P384N) $(N_FUNCS) > $@ 71 | 72 | .PHONY: p384_tables_64.h 73 | p384_tables_64.h: 74 | $(GEN_TABLE) p384 64 > $@ 75 | 76 | .PHONY: p384_tables_32.h 77 | p384_tables_32.h: 78 | $(GEN_TABLE) p384 32 > $@ 79 | 80 | .PHONY: p384 81 | p384: p384_64.h p384_32.h np384_64.h np384_32.h 82 | 83 | p384_tables: p384_tables_64.h p384_tables_32.h 84 | 85 | # The NIST curve P-521 (AKA SECP521R1) 86 | P521="2^521 - 1" 87 | 88 | .PHONY: p521_64.h 89 | p521_64.h: 90 | $(WBW_MONT) p521 64 $(P521) > $@ 91 | 92 | .PHONY: p521_32.h 93 | p521_32.h: 94 | $(WBW_MONT) p521 32 $(P521) > $@ 95 | 96 | # The group order N of P-521 97 | P521N="0x01FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFA51868783BF2F966B7FCC0148F709A5D03BB5C9B8899C47AEBB6FB71E91386409" 98 | 99 | .PHONY: np521_64.h 100 | np521_64.h: 101 | $(WBW_MONT) np521 64 $(P521N) $(N_FUNCS) > $@ 102 | 103 | .PHONY: np521_32.h 104 | np521_32.h: 105 | $(WBW_MONT) np521 32 $(P521N) $(N_FUNCS) > $@ 106 | 107 | .PHONY: p521_tables_64.h 108 | p521_tables_64.h: 109 | $(GEN_TABLE) p521 64 > $@ 110 | 111 | .PHONY: p521_tables_32.h 112 | p521_tables_32.h: 113 | $(GEN_TABLE) p521 32 > $@ 114 | 115 | .PHONY: p521 116 | p521: p521_64.h p521_32.h np521_64.h np521_32.h 117 | 118 | p521_tables: p521_tables_64.h p521_tables_32.h 119 | 120 | # 25519 121 | 25519="2^255 - 19" 122 | 25519_FUNS=carry_mul carry_square carry add sub opp selectznz to_bytes from_bytes carry_scmul121666 123 | 124 | .PHONY: curve25519_64.h 125 | curve25519_64.h: 126 | $(UNSAT_SOLINAS) 25519 64 '(auto)' $(25519) $(25519_FUNS) > $@ 127 | 128 | .PHONY: curve25519_32.h 129 | curve25519_32.h: 130 | $(UNSAT_SOLINAS) 25519 32 '(auto)' $(25519) $(25519_FUNS) > $@ 131 | 132 | .PHONY: curve25519 133 | curve25519: curve25519_64.h curve25519_32.h 134 | 135 | .PHONY: tables 136 | tables: p256_tables p384_tables p521_tables 137 | 138 | .PHONY: clean 139 | clean: 140 | $(RM) p256_32.h p256_64.h np256_32.h np256_64.h 141 | $(RM) p384_32.h p384_64.h np384_32.h np384_64.h 142 | $(RM) p521_32.h p521_64.h np521_32.h np521_64.h 143 | $(RM) curve25519_32.h curve25519_64.h 144 | 145 | .PHONY: clean_tables 146 | clean_tables: 147 | $(RM) p256_tables_32.h p256_tables_64.h 148 | $(RM) p384_tables_32.h p384_tables_64.h 149 | $(RM) p521_tables_32.h p521_tables_64.h 150 | 151 | .PHONY: all 152 | all: p256 p384 p521 curve25519 153 | -------------------------------------------------------------------------------- /pk/z_extra.ml: -------------------------------------------------------------------------------- 1 | open Mirage_crypto.Uncommon 2 | 3 | let bit_bound z = Z.size z * 64 4 | 5 | let of_octets_be ?bits buf = 6 | let rec loop acc i = function 7 | | b when b >= 64 -> 8 | let x = String.get_int64_be buf i in 9 | let x = Z.of_int64_unsigned Int64.(shift_right_logical x 8) in 10 | loop Z.(x + acc lsl 56) (i + 7) (b - 56) 11 | | b when b >= 32 -> 12 | let x = String.get_int32_be buf i in 13 | let x = Z.of_int32_unsigned Int32.(shift_right_logical x 8) in 14 | loop Z.(x + acc lsl 24) (i + 3) (b - 24) 15 | | b when b >= 16 -> 16 | let x = Z.of_int (String.get_uint16_be buf i) in 17 | loop Z.(x + acc lsl 16) (i + 2) (b - 16) 18 | | b when b >= 8 -> 19 | let x = Z.of_int (String.get_uint8 buf i) in 20 | loop Z.(x + acc lsl 8 ) (i + 1) (b - 8 ) 21 | | b when b > 0 -> 22 | let x = String.get_uint8 buf i and b' = 8 - b in 23 | Z.(of_int x asr b' + acc lsl b) 24 | | _ -> acc in 25 | loop Z.zero 0 @@ match bits with 26 | | None -> String.length buf * 8 27 | | Some b -> imin b (String.length buf * 8) 28 | 29 | let byte1 = Z.of_int64 0xffL 30 | and byte2 = Z.of_int64 0xffffL 31 | and byte3 = Z.of_int64 0xffffffL 32 | and byte7 = Z.of_int64 0xffffffffffffffL 33 | 34 | let into_octets_be n buf = 35 | let rec write n = function 36 | | i when i >= 7 -> 37 | Bytes.set_int64_be buf (i - 7) Z.(to_int64_unsigned (n land byte7)) ; 38 | write Z.(n asr 56) (i - 7) 39 | | i when i >= 3 -> 40 | Bytes.set_int32_be buf (i - 3) Z.(to_int32_unsigned (n land byte3)) ; 41 | write Z.(n asr 24) (i - 3) 42 | | i when i >= 1 -> 43 | Bytes.set_uint16_be buf (i - 1) Z.(to_int (n land byte2)) ; 44 | write Z.(n asr 16) (i - 2) 45 | | 0 -> Bytes.set_uint8 buf 0 Z.(to_int (n land byte1)) ; 46 | | _ -> () 47 | in 48 | write n (Bytes.length buf - 1) 49 | 50 | let to_octets_be ?size n = 51 | let buf = Bytes.create @@ match size with 52 | | Some s -> imax 0 s 53 | | None -> Z.numbits n // 8 in 54 | into_octets_be n buf; 55 | Bytes.unsafe_to_string buf 56 | 57 | (* Handbook of Applied Cryptography, Table 4.4: 58 | * Miller-Rabin rounds for composite probability <= 1/2^80. *) 59 | let pseudoprime z = 60 | let i = match Z.numbits z with 61 | | i when i >= 1300 -> 2 62 | | i when i >= 850 -> 3 63 | | i when i >= 650 -> 4 64 | | i when i >= 350 -> 8 65 | | i when i >= 250 -> 12 66 | | i when i >= 150 -> 18 67 | | _ -> 27 in 68 | Z.probab_prime z i <> 0 69 | 70 | (* strip_factor ~f x = (s, t), where x = f^s t *) 71 | let strip_factor ~f x = 72 | let rec go n x = 73 | let (x1, r) = Z.div_rem x f in 74 | if r = Z.zero then go (succ n) x1 else Ok (n, x) 75 | in 76 | if Z.(~$2) <= f then 77 | go 0 x 78 | else 79 | Error (`Msg ("factor_count: f: " ^ Z.to_string f)) 80 | 81 | let gen ?g n = 82 | if n < Z.one then invalid_arg "Rng.gen: non-positive: %a" Z.pp_print n; 83 | let bs = Mirage_crypto_rng.block g in 84 | let bits = Z.(numbits (pred n)) in 85 | let octets = bits // 8 in 86 | let batch = 87 | if Mirage_crypto_rng.strict g then octets else 2 * octets // bs * bs 88 | in 89 | let rec attempt buf = 90 | if String.length buf >= octets then 91 | let x = of_octets_be ~bits buf in 92 | if x < n then x else attempt (String.sub buf octets (String.length buf - octets)) 93 | else attempt (Mirage_crypto_rng.generate ?g batch) in 94 | attempt (Mirage_crypto_rng.generate ?g batch) 95 | 96 | let rec gen_r ?g a b = 97 | if Mirage_crypto_rng.strict g then 98 | let x = gen ?g b in if x < a then gen_r ?g a b else x 99 | else Z.(a + gen ?g (b - a)) 100 | 101 | 102 | let set_msb bits buf = 103 | if bits > 0 then 104 | let n = Bytes.length buf in 105 | let rec go width = function 106 | | i when i = n -> () 107 | | i when width < 8 -> 108 | Bytes.set_uint8 buf i (Bytes.get_uint8 buf i lor (0xff lsl (8 - width))) 109 | | i -> 110 | Bytes.set_uint8 buf i 0xff ; 111 | go (width - 8) (succ i) 112 | in 113 | go bits 0 114 | 115 | let gen_bits ?g ?(msb = 0) bits = 116 | let bytelen = bits // 8 in 117 | let buf = Bytes.create bytelen in 118 | Mirage_crypto_rng.generate_into ?g buf ~off:0 bytelen; 119 | set_msb msb buf ; 120 | of_octets_be ~bits (Bytes.unsafe_to_string buf) 121 | 122 | (* Invalid combinations of ~bits and ~msb will loop forever, but there is no 123 | * way to quickly determine upfront whether there are any primes in the 124 | * interval. 125 | * XXX Probability is distributed as inter-prime gaps. So? 126 | *) 127 | let rec prime ?g ?(msb = 1) bits = 128 | let p = Z.(nextprime @@ gen_bits ?g ~msb bits) in 129 | if p < Z.(one lsl bits) then p else prime ?g ~msb bits 130 | 131 | (* XXX Add ~msb param for p? *) 132 | let rec safe_prime ?g bits = 133 | let q = prime ?g ~msb:1 (bits - 1) in 134 | let p = Z.(q * ~$2 + ~$1) in 135 | if pseudoprime p then (q, p) else safe_prime ?g bits 136 | -------------------------------------------------------------------------------- /rng/miou/pfortuna.ml: -------------------------------------------------------------------------------- 1 | (* Pfortuna is a re-implementation of Fortuna with a mutex. The goal of this 2 | module is to provide a global and domain-safe RNG. The implementation use 3 | [Miou.Mutex] instead of [Mutex] - [Pfortuna] is only available as part of 4 | the [mirage-crypto-rng-miou-unix] package. Thus, in the context of Miou, 5 | [Pfortuna] can be used and recommended in place of [Fortuna], so that the 6 | user can generate random numbers in parallel in several domains. 7 | 8 | {[ 9 | let () = Miou_unix.run @@ fun () -> 10 | let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in 11 | ... 12 | Mirage_crypto_rng_miou_unix.kill rng 13 | ]} 14 | 15 | NOTE: when modifying this file, please also check whether rng/fortuna.ml 16 | needs to be updated. *) 17 | 18 | open Mirage_crypto 19 | open Mirage_crypto.Uncommon 20 | 21 | module SHAd256 = struct 22 | open Digestif 23 | type ctx = SHA256.ctx 24 | let empty = SHA256.empty 25 | let get t = SHA256.(get t |> to_raw_string |> digest_string |> to_raw_string) 26 | let digesti i = SHA256.(digesti_string i |> to_raw_string |> digest_string |> to_raw_string) 27 | let feedi = SHA256.feedi_string 28 | end 29 | 30 | let block = 16 31 | 32 | (* the minimal amount of bytes in a pool to trigger a reseed *) 33 | let min_pool_size = 64 34 | (* the minimal duration between two reseeds *) 35 | let min_time_duration = 1_000_000_000L 36 | (* number of pools *) 37 | let pools = 32 38 | 39 | type t = 40 | { ctr : AES.CTR.ctr 41 | ; secret : string 42 | ; key : AES.CTR.key 43 | ; pools : SHAd256.ctx array 44 | ; pool0_size : int 45 | ; reseed_count : int 46 | ; last_reseed : int64 47 | ; time : (unit -> int64) option 48 | } 49 | 50 | type g = Miou.Mutex.t * t ref 51 | 52 | let update (m, g) fn = Miou.Mutex.protect m @@ fun () -> g := fn !g 53 | let get (m, g) fn = Miou.Mutex.protect m @@ fun () -> fn !g 54 | 55 | let create ?time () = 56 | let secret = String.make 32 '\000' in 57 | let m = Miou.Mutex.create () in 58 | let t = 59 | { ctr= (0L, 0L); secret; key= AES.CTR.of_secret secret 60 | ; pools= Array.make pools SHAd256.empty 61 | ; pool0_size= 0 62 | ; reseed_count= 0 63 | ; last_reseed= 0L 64 | ; time } in 65 | (m, { contents= t }) 66 | 67 | let seeded ~t = 68 | let lo, hi = t.ctr in 69 | not (Int64.equal lo 0L && Int64.equal hi 0L) 70 | 71 | let set_key ~t secret = 72 | { t with secret; key= AES.CTR.of_secret secret } 73 | 74 | let reseedi ~t iter = 75 | let t = set_key ~t (SHAd256.digesti (fun fn -> fn t.secret; iter fn)) in 76 | { t with ctr= AES.CTR.add_ctr t.ctr 1L } 77 | 78 | let iter1 a f = f a 79 | let reseed ~t cs = reseedi ~t (iter1 cs) 80 | 81 | let generate_rekey ~t buf ~off len = 82 | let b = len // block* 2 in 83 | let n = b * block in 84 | let r = AES.CTR.stream ~key:t.key ~ctr:t.ctr n in 85 | Bytes.unsafe_blit_string r 0 buf off len; 86 | let r2 = String.sub r (n - 32) 32 in 87 | let t = set_key ~t r2 in 88 | { t with ctr= AES.CTR.add_ctr t.ctr (Int64.of_int b) } 89 | 90 | let add_pool_entropy t = 91 | if t.pool0_size > min_pool_size then 92 | let should_reseed, now = match t.time with 93 | | None -> true, 0L 94 | | Some fn -> 95 | let now = fn () in 96 | Int64.(sub now t.last_reseed > min_time_duration), now in 97 | if should_reseed then begin 98 | let t = { t with reseed_count= t.reseed_count + 1 99 | ; last_reseed= now 100 | ; pool0_size= 0 } in 101 | reseedi ~t @@ fun add -> 102 | for i = 0 to pools - 1 do 103 | if t.reseed_count land ((1 lsl i) - 1) = 0 104 | then (SHAd256.get t.pools.(i) |> add; t.pools.(i) <- SHAd256.empty) 105 | done 106 | end else t else t 107 | 108 | let generate_into ~t buf ~off len = 109 | let t = add_pool_entropy t in 110 | if not (seeded ~t) then raise Mirage_crypto_rng.Unseeded_generator; 111 | let rec chunk t off = function 112 | | i when i <= 0 -> t 113 | | n -> 114 | let n' = imin n 0x10000 in 115 | let t = generate_rekey ~t buf ~off n' in 116 | chunk t (off + n') (n - n') in 117 | chunk t off len 118 | 119 | let add ~t source ~pool data = 120 | let buf = Bytes.create 2 121 | and pool = pool land (pools - 1) 122 | and source = Mirage_crypto_rng.Entropy.id source land 0xff in 123 | Bytes.set_uint8 buf 0 source; 124 | Bytes.set_uint8 buf 1 (String.length data); 125 | t.pools.(pool) <- SHAd256.feedi t.pools.(pool) (iter2 (Bytes.unsafe_to_string buf) data); 126 | if pool = 0 then { t with pool0_size= t.pool0_size + String.length data } else t 127 | 128 | let accumulate ~g source = 129 | let pool = ref 0 in 130 | `Acc (fun buf -> 131 | update g @@ fun t -> 132 | let t = add ~t source ~pool:!pool buf in 133 | incr pool; t) 134 | 135 | let reseed ~g cs = update g @@ fun t -> reseed ~t cs 136 | let generate_into ~g buf ~off len = update g @@ fun t -> generate_into ~t buf ~off len 137 | let seeded ~g = get g @@ fun t -> seeded ~t 138 | -------------------------------------------------------------------------------- /src/ccm.ml: -------------------------------------------------------------------------------- 1 | open Uncommon 2 | 3 | let block_size = 16 4 | 5 | let flags bit6 len1 len2 = 6 | bit6 lsl 6 + len1 lsl 3 + len2 7 | 8 | let encode_len buf ~off size value = 9 | let rec ass num = function 10 | | 0 -> Bytes.set_uint8 buf off num 11 | | m -> 12 | Bytes.set_uint8 buf (off + m) (num land 0xff); 13 | (ass [@tailcall]) (num lsr 8) (pred m) 14 | in 15 | ass value (pred size) 16 | 17 | let set_format buf ?(off = 0) nonce flag_val value = 18 | let n = String.length nonce in 19 | let small_q = 15 - n in 20 | (* first octet block: 21 | 0 : flags 22 | 1..15 - q : N 23 | 16 - q..15 : Q *) 24 | Bytes.set_uint8 buf off flag_val; 25 | Bytes.unsafe_blit_string nonce 0 buf (off + 1) n; 26 | encode_len buf ~off:(off + n + 1) small_q value 27 | 28 | let gen_adata a = 29 | let llen, set_llen = 30 | match String.length a with 31 | | x when x < (1 lsl 16 - 1 lsl 8) -> 32 | 2, (fun buf off -> Bytes.set_uint16_be buf off x) 33 | | x when Sys.int_size < 32 || x < (1 lsl 32) -> 34 | 6, (fun buf off -> 35 | Bytes.set_uint16_be buf off 0xfffe; 36 | Bytes.set_int32_be buf (off + 2) (Int32.of_int x)) 37 | | x -> 38 | 10, (fun buf off -> 39 | Bytes.set_uint16_be buf off 0xffff; 40 | Bytes.set_int64_be buf (off + 2) (Int64.of_int x)) 41 | in 42 | let to_pad = 43 | let leftover = (llen + String.length a) mod block_size in 44 | block_size - leftover 45 | in 46 | llen + String.length a + to_pad, 47 | fun buf off -> 48 | set_llen buf off; 49 | Bytes.unsafe_blit_string a 0 buf (off + llen) (String.length a); 50 | Bytes.unsafe_fill buf (off + llen + String.length a) to_pad '\000' 51 | 52 | let gen_ctr nonce i = 53 | let n = String.length nonce in 54 | let small_q = 15 - n in 55 | let flag_val = flags 0 0 (small_q - 1) in 56 | let buf = Bytes.create 16 in 57 | set_format buf nonce flag_val i; 58 | buf 59 | 60 | let prepare_header nonce adata plen tlen = 61 | let small_q = 15 - String.length nonce in 62 | let b6 = if String.length adata = 0 then 0 else 1 in 63 | let flag_val = flags b6 ((tlen - 2) / 2) (small_q - 1) in 64 | if String.length adata = 0 then 65 | let hdr = Bytes.create 16 in 66 | set_format hdr nonce flag_val plen; 67 | hdr 68 | else 69 | let len, set = gen_adata adata in 70 | let buf = Bytes.create (16 + len) in 71 | set_format buf nonce flag_val plen; 72 | set buf 16; 73 | buf 74 | 75 | type mode = Encrypt | Decrypt 76 | 77 | let crypto_core_into ~cipher ~mode ~key ~nonce ~adata src ~src_off dst ~dst_off len = 78 | let cbcheader = prepare_header nonce adata len block_size in 79 | 80 | let small_q = 15 - String.length nonce in 81 | let ctr_flag_val = flags 0 0 (small_q - 1) in 82 | let ctrblock i block dst_off = 83 | Bytes.set_uint8 block dst_off ctr_flag_val; 84 | Bytes.unsafe_blit_string nonce 0 block (dst_off + 1) (String.length nonce); 85 | encode_len block ~off:(dst_off + String.length nonce + 1) small_q i; 86 | cipher ~key (Bytes.unsafe_to_string block) ~src_off:dst_off block ~dst_off 87 | in 88 | 89 | let cbc iv src_off block dst_off = 90 | unsafe_xor_into iv ~src_off block ~dst_off block_size ; 91 | cipher ~key (Bytes.unsafe_to_string block) ~src_off:dst_off block ~dst_off 92 | in 93 | 94 | let iv = 95 | let rec doit iv iv_off block block_off = 96 | match Bytes.length block - block_off with 97 | | 0 -> Bytes.sub iv iv_off block_size 98 | | _ -> 99 | cbc (Bytes.unsafe_to_string iv) iv_off block block_off; 100 | (doit [@tailcall]) block block_off block (block_off + block_size) 101 | in 102 | doit (Bytes.make block_size '\x00') 0 cbcheader 0 103 | in 104 | 105 | let rec loop ctr src src_off dst dst_off len = 106 | let cbcblock, cbc_off = 107 | match mode with 108 | | Encrypt -> src, src_off 109 | | Decrypt -> Bytes.unsafe_to_string dst, dst_off 110 | in 111 | if len = 0 then 112 | () 113 | else if len < block_size then begin 114 | let buf = Bytes.make block_size '\x00' in 115 | Bytes.unsafe_blit dst dst_off buf 0 len ; 116 | ctrblock ctr buf 0 ; 117 | Bytes.unsafe_blit buf 0 dst dst_off len ; 118 | unsafe_xor_into src ~src_off dst ~dst_off len ; 119 | Bytes.unsafe_blit_string cbcblock cbc_off buf 0 len ; 120 | Bytes.unsafe_fill buf len (block_size - len) '\x00'; 121 | cbc (Bytes.unsafe_to_string buf) 0 iv 0 122 | end else begin 123 | ctrblock ctr dst dst_off ; 124 | unsafe_xor_into src ~src_off dst ~dst_off block_size ; 125 | cbc cbcblock cbc_off iv 0 ; 126 | (loop [@tailcall]) (succ ctr) src (src_off + block_size) dst (dst_off + block_size) (len - block_size) 127 | end 128 | in 129 | loop 1 src src_off dst dst_off len; 130 | iv 131 | 132 | let crypto_core ~cipher ~mode ~key ~nonce ~adata data = 133 | let datalen = String.length data in 134 | let dst = Bytes.create datalen in 135 | let t = crypto_core_into ~cipher ~mode ~key ~nonce ~adata data ~src_off:0 dst ~dst_off:0 datalen in 136 | dst, t 137 | 138 | let crypto_t t nonce cipher key = 139 | let ctr = gen_ctr nonce 0 in 140 | cipher ~key (Bytes.unsafe_to_string ctr) ~src_off:0 ctr ~dst_off:0 ; 141 | unsafe_xor_into (Bytes.unsafe_to_string ctr) ~src_off:0 t ~dst_off:0 (Bytes.length t) 142 | 143 | let unsafe_generation_encryption_into ~cipher ~key ~nonce ~adata src ~src_off dst ~dst_off ~tag_off len = 144 | let t = crypto_core_into ~cipher ~mode:Encrypt ~key ~nonce ~adata src ~src_off dst ~dst_off len in 145 | crypto_t t nonce cipher key ; 146 | Bytes.unsafe_blit t 0 dst tag_off block_size 147 | 148 | let unsafe_decryption_verification_into ~cipher ~key ~nonce ~adata src ~src_off ~tag_off dst ~dst_off len = 149 | let tag = String.sub src tag_off block_size in 150 | let t = crypto_core_into ~cipher ~mode:Decrypt ~key ~nonce ~adata src ~src_off dst ~dst_off len in 151 | crypto_t t nonce cipher key ; 152 | Eqaf.equal tag (Bytes.unsafe_to_string t) 153 | -------------------------------------------------------------------------------- /src/native/bitfn.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2006-2009 Vincent Hanquez 3 | * 4 | * Redistribution and use in source and binary forms, with or without 5 | * modification, are permitted provided that the following conditions 6 | * are met: 7 | * 1. Redistributions of source code must retain the above copyright 8 | * notice, this list of conditions and the following disclaimer. 9 | * 2. Redistributions in binary form must reproduce the above copyright 10 | * notice, this list of conditions and the following disclaimer in the 11 | * documentation and/or other materials provided with the distribution. 12 | * 13 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 14 | * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 15 | * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 16 | * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 17 | * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 18 | * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 19 | * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 20 | * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 22 | * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | */ 24 | 25 | #ifndef BITFN_H 26 | #define BITFN_H 27 | #include 28 | 29 | # if (defined(__i386__)) 30 | # define ARCH_HAS_SWAP32 31 | static inline uint32_t bitfn_swap32(uint32_t a) 32 | { 33 | __asm__ ("bswap %0" : "=r" (a) : "0" (a)); 34 | return a; 35 | } 36 | /**********************************************************/ 37 | # elif (defined(__arm__)) 38 | # define ARCH_HAS_SWAP32 39 | static inline uint32_t bitfn_swap32(uint32_t a) 40 | { 41 | uint32_t tmp = a; 42 | __asm__ volatile ("eor %1, %0, %0, ror #16\n" 43 | "bic %1, %1, #0xff0000\n" 44 | "mov %0, %0, ror #8\n" 45 | "eor %0, %0, %1, lsr #8\n" 46 | : "=r" (a), "=r" (tmp) : "0" (a), "1" (tmp)); 47 | return a; 48 | } 49 | /**********************************************************/ 50 | # elif defined(__x86_64__) 51 | # define ARCH_HAS_SWAP32 52 | # define ARCH_HAS_SWAP64 53 | static inline uint32_t bitfn_swap32(uint32_t a) 54 | { 55 | __asm__ ("bswap %0" : "=r" (a) : "0" (a)); 56 | return a; 57 | } 58 | 59 | static inline uint64_t bitfn_swap64(uint64_t a) 60 | { 61 | __asm__ ("bswap %0" : "=r" (a) : "0" (a)); 62 | return a; 63 | } 64 | 65 | # endif 66 | 67 | #ifndef ARCH_HAS_SWAP32 68 | static inline uint32_t bitfn_swap32(uint32_t a) 69 | { 70 | return (a << 24) | ((a & 0xff00) << 8) | ((a >> 8) & 0xff00) | (a >> 24); 71 | } 72 | #endif 73 | 74 | #ifndef ARCH_HAS_SWAP64 75 | static inline uint64_t bitfn_swap64(uint64_t a) 76 | { 77 | return ((uint64_t) bitfn_swap32((uint32_t) (a >> 32))) | 78 | (((uint64_t) bitfn_swap32((uint32_t) a)) << 32); 79 | } 80 | #endif 81 | 82 | static inline uint32_t rol32(uint32_t word, uint32_t shift) 83 | { 84 | return (word << shift) | (word >> (32 - shift)); 85 | } 86 | 87 | static inline uint32_t ror32(uint32_t word, uint32_t shift) 88 | { 89 | return (word >> shift) | (word << (32 - shift)); 90 | } 91 | 92 | static inline uint64_t rol64(uint64_t word, uint32_t shift) 93 | { 94 | return (word << shift) | (word >> (64 - shift)); 95 | } 96 | 97 | static inline uint64_t ror64(uint64_t word, uint32_t shift) 98 | { 99 | return (word >> shift) | (word << (64 - shift)); 100 | } 101 | 102 | static inline void array_swap32(uint32_t *d, const uint32_t *s, uint32_t nb) 103 | { 104 | while (nb--) 105 | *d++ = bitfn_swap32(*s++); 106 | } 107 | 108 | static inline void array_swap64(uint64_t *d, const uint64_t *s, uint32_t nb) 109 | { 110 | while (nb--) 111 | *d++ = bitfn_swap64(*s++); 112 | } 113 | 114 | static inline void array_copy32(uint32_t *d, const uint32_t *s, uint32_t nb) 115 | { 116 | while (nb--) *d++ = *s++; 117 | } 118 | 119 | static inline void array_copy64(uint64_t *d, const uint64_t *s, uint32_t nb) 120 | { 121 | while (nb--) *d++ = *s++; 122 | } 123 | 124 | #if defined(_MSC_VER) || defined(__BYTE_ORDER__) 125 | #if defined(_MSC_VER) || (__ORDER_LITTLE_ENDIAN__ == __BYTE_ORDER__) 126 | 127 | # define be32_to_cpu(a) bitfn_swap32(a) 128 | # define cpu_to_be32(a) bitfn_swap32(a) 129 | # define le32_to_cpu(a) (a) 130 | # define cpu_to_le32(a) (a) 131 | # define be64_to_cpu(a) bitfn_swap64(a) 132 | # define cpu_to_be64(a) bitfn_swap64(a) 133 | # define le64_to_cpu(a) (a) 134 | # define cpu_to_le64(a) (a) 135 | 136 | # define cpu_to_le32_array(d, s, l) array_copy32(d, s, l) 137 | # define le32_to_cpu_array(d, s, l) array_copy32(d, s, l) 138 | # define cpu_to_be32_array(d, s, l) array_swap32(d, s, l) 139 | # define be32_to_cpu_array(d, s, l) array_swap32(d, s, l) 140 | 141 | # define cpu_to_le64_array(d, s, l) array_copy64(d, s, l) 142 | # define le64_to_cpu_array(d, s, l) array_copy64(d, s, l) 143 | # define cpu_to_be64_array(d, s, l) array_swap64(d, s, l) 144 | # define be64_to_cpu_array(d, s, l) array_swap64(d, s, l) 145 | 146 | # define ARCH_IS_LITTLE_ENDIAN 147 | 148 | #elif __ORDER_BIG_ENDIAN__ == __BYTE_ORDER__ 149 | 150 | # define be32_to_cpu(a) (a) 151 | # define cpu_to_be32(a) (a) 152 | # define le32_to_cpu(a) bitfn_swap32(a) 153 | # define cpu_to_le32(a) bitfn_swap32(a) 154 | # define be64_to_cpu(a) (a) 155 | # define cpu_to_be64(a) (a) 156 | # define le64_to_cpu(a) bitfn_swap64(a) 157 | # define cpu_to_le64(a) bitfn_swap64(a) 158 | 159 | # define cpu_to_le32_array(d, s, l) array_swap32(d, s, l) 160 | # define le32_to_cpu_array(d, s, l) array_swap32(d, s, l) 161 | # define cpu_to_be32_array(d, s, l) array_copy32(d, s, l) 162 | # define be32_to_cpu_array(d, s, l) array_copy32(d, s, l) 163 | 164 | # define cpu_to_le64_array(d, s, l) array_swap64(d, s, l) 165 | # define le64_to_cpu_array(d, s, l) array_swap64(d, s, l) 166 | # define cpu_to_be64_array(d, s, l) array_copy64(d, s, l) 167 | # define be64_to_cpu_array(d, s, l) array_copy64(d, s, l) 168 | 169 | # define ARCH_IS_BIG_ENDIAN 170 | 171 | #else 172 | # error "endian is neither big nor little endian" 173 | #endif 174 | 175 | #else 176 | # error "__BYTE_ORDER__ is not defined" 177 | #endif 178 | 179 | #endif /* !BITFN_H */ 180 | -------------------------------------------------------------------------------- /src/native/poly1305-donna-64.h: -------------------------------------------------------------------------------- 1 | // from https://github.com/floodyberry/poly1305-donna.git 2 | 3 | /* 4 | poly1305 implementation using 64 bit * 64 bit = 128 bit multiplication and 128 bit addition 5 | */ 6 | 7 | #define uint128_t __uint128_t 8 | #define MUL(out, x, y) out = ((uint128_t)x * y) 9 | #define ADD(out, in) out += in 10 | #define ADDLO(out, in) out += in 11 | #define SHR(in, shift) (unsigned long long)(in >> (shift)) 12 | #define LO(in) (unsigned long long)(in) 13 | 14 | #define POLY1305_NOINLINE __attribute__((noinline)) 15 | 16 | #define poly1305_block_size 16 17 | 18 | /* 17 + sizeof(size_t) + 8*sizeof(unsigned long long) */ 19 | typedef struct poly1305_state_internal_t { 20 | unsigned long long r[3]; 21 | unsigned long long h[3]; 22 | unsigned long long pad[2]; 23 | size_t leftover; 24 | unsigned char buffer[poly1305_block_size]; 25 | unsigned char final; 26 | } poly1305_state_internal_t; 27 | 28 | /* interpret eight 8 bit unsigned integers as a 64 bit unsigned integer in little endian */ 29 | static unsigned long long 30 | U8TO64(const unsigned char *p) { 31 | return 32 | (((unsigned long long)(p[0] & 0xff) ) | 33 | ((unsigned long long)(p[1] & 0xff) << 8) | 34 | ((unsigned long long)(p[2] & 0xff) << 16) | 35 | ((unsigned long long)(p[3] & 0xff) << 24) | 36 | ((unsigned long long)(p[4] & 0xff) << 32) | 37 | ((unsigned long long)(p[5] & 0xff) << 40) | 38 | ((unsigned long long)(p[6] & 0xff) << 48) | 39 | ((unsigned long long)(p[7] & 0xff) << 56)); 40 | } 41 | 42 | /* store a 64 bit unsigned integer as eight 8 bit unsigned integers in little endian */ 43 | static void 44 | U64TO8(unsigned char *p, unsigned long long v) { 45 | p[0] = (v ) & 0xff; 46 | p[1] = (v >> 8) & 0xff; 47 | p[2] = (v >> 16) & 0xff; 48 | p[3] = (v >> 24) & 0xff; 49 | p[4] = (v >> 32) & 0xff; 50 | p[5] = (v >> 40) & 0xff; 51 | p[6] = (v >> 48) & 0xff; 52 | p[7] = (v >> 56) & 0xff; 53 | } 54 | 55 | static void 56 | poly1305_init(poly1305_context *ctx, const unsigned char key[32]) { 57 | poly1305_state_internal_t *st = (poly1305_state_internal_t *)ctx; 58 | unsigned long long t0,t1; 59 | 60 | /* r &= 0xffffffc0ffffffc0ffffffc0fffffff */ 61 | t0 = U8TO64(&key[0]); 62 | t1 = U8TO64(&key[8]); 63 | 64 | st->r[0] = ( t0 ) & 0xffc0fffffff; 65 | st->r[1] = ((t0 >> 44) | (t1 << 20)) & 0xfffffc0ffff; 66 | st->r[2] = ((t1 >> 24) ) & 0x00ffffffc0f; 67 | 68 | /* h = 0 */ 69 | st->h[0] = 0; 70 | st->h[1] = 0; 71 | st->h[2] = 0; 72 | 73 | /* save pad for later */ 74 | st->pad[0] = U8TO64(&key[16]); 75 | st->pad[1] = U8TO64(&key[24]); 76 | 77 | st->leftover = 0; 78 | st->final = 0; 79 | } 80 | 81 | static void 82 | poly1305_blocks(poly1305_state_internal_t *st, const unsigned char *m, size_t bytes) { 83 | const unsigned long long hibit = (st->final) ? 0 : ((unsigned long long)1 << 40); /* 1 << 128 */ 84 | unsigned long long r0,r1,r2; 85 | unsigned long long s1,s2; 86 | unsigned long long h0,h1,h2; 87 | unsigned long long c; 88 | uint128_t d0,d1,d2,d; 89 | 90 | r0 = st->r[0]; 91 | r1 = st->r[1]; 92 | r2 = st->r[2]; 93 | 94 | h0 = st->h[0]; 95 | h1 = st->h[1]; 96 | h2 = st->h[2]; 97 | 98 | s1 = r1 * (5 << 2); 99 | s2 = r2 * (5 << 2); 100 | 101 | while (bytes >= poly1305_block_size) { 102 | unsigned long long t0,t1; 103 | 104 | /* h += m[i] */ 105 | t0 = U8TO64(&m[0]); 106 | t1 = U8TO64(&m[8]); 107 | 108 | h0 += (( t0 ) & 0xfffffffffff); 109 | h1 += (((t0 >> 44) | (t1 << 20)) & 0xfffffffffff); 110 | h2 += (((t1 >> 24) ) & 0x3ffffffffff) | hibit; 111 | 112 | /* h *= r */ 113 | MUL(d0, h0, r0); MUL(d, h1, s2); ADD(d0, d); MUL(d, h2, s1); ADD(d0, d); 114 | MUL(d1, h0, r1); MUL(d, h1, r0); ADD(d1, d); MUL(d, h2, s2); ADD(d1, d); 115 | MUL(d2, h0, r2); MUL(d, h1, r1); ADD(d2, d); MUL(d, h2, r0); ADD(d2, d); 116 | 117 | /* (partial) h %= p */ 118 | c = SHR(d0, 44); h0 = LO(d0) & 0xfffffffffff; 119 | ADDLO(d1, c); c = SHR(d1, 44); h1 = LO(d1) & 0xfffffffffff; 120 | ADDLO(d2, c); c = SHR(d2, 42); h2 = LO(d2) & 0x3ffffffffff; 121 | h0 += c * 5; c = (h0 >> 44); h0 = h0 & 0xfffffffffff; 122 | h1 += c; 123 | 124 | m += poly1305_block_size; 125 | bytes -= poly1305_block_size; 126 | } 127 | 128 | st->h[0] = h0; 129 | st->h[1] = h1; 130 | st->h[2] = h2; 131 | } 132 | 133 | 134 | POLY1305_NOINLINE static void 135 | poly1305_finish(poly1305_context *ctx, unsigned char mac[16]) { 136 | poly1305_state_internal_t *st = (poly1305_state_internal_t *)ctx; 137 | unsigned long long h0,h1,h2,c; 138 | unsigned long long g0,g1,g2; 139 | unsigned long long t0,t1; 140 | 141 | /* process the remaining block */ 142 | if (st->leftover) { 143 | size_t i = st->leftover; 144 | st->buffer[i] = 1; 145 | for (i = i + 1; i < poly1305_block_size; i++) 146 | st->buffer[i] = 0; 147 | st->final = 1; 148 | poly1305_blocks(st, st->buffer, poly1305_block_size); 149 | } 150 | 151 | /* fully carry h */ 152 | h0 = st->h[0]; 153 | h1 = st->h[1]; 154 | h2 = st->h[2]; 155 | 156 | c = (h1 >> 44); h1 &= 0xfffffffffff; 157 | h2 += c; c = (h2 >> 42); h2 &= 0x3ffffffffff; 158 | h0 += c * 5; c = (h0 >> 44); h0 &= 0xfffffffffff; 159 | h1 += c; c = (h1 >> 44); h1 &= 0xfffffffffff; 160 | h2 += c; c = (h2 >> 42); h2 &= 0x3ffffffffff; 161 | h0 += c * 5; c = (h0 >> 44); h0 &= 0xfffffffffff; 162 | h1 += c; 163 | 164 | /* compute h + -p */ 165 | g0 = h0 + 5; c = (g0 >> 44); g0 &= 0xfffffffffff; 166 | g1 = h1 + c; c = (g1 >> 44); g1 &= 0xfffffffffff; 167 | g2 = h2 + c - ((unsigned long long)1 << 42); 168 | 169 | /* select h if h < p, or h + -p if h >= p */ 170 | c = (g2 >> ((sizeof(unsigned long long) * 8) - 1)) - 1; 171 | g0 &= c; 172 | g1 &= c; 173 | g2 &= c; 174 | c = ~c; 175 | h0 = (h0 & c) | g0; 176 | h1 = (h1 & c) | g1; 177 | h2 = (h2 & c) | g2; 178 | 179 | /* h = (h + pad) */ 180 | t0 = st->pad[0]; 181 | t1 = st->pad[1]; 182 | 183 | h0 += (( t0 ) & 0xfffffffffff) ; c = (h0 >> 44); h0 &= 0xfffffffffff; 184 | h1 += (((t0 >> 44) | (t1 << 20)) & 0xfffffffffff) + c; c = (h1 >> 44); h1 &= 0xfffffffffff; 185 | h2 += (((t1 >> 24) ) & 0x3ffffffffff) + c; h2 &= 0x3ffffffffff; 186 | 187 | /* mac = h % (2^128) */ 188 | h0 = ((h0 ) | (h1 << 44)); 189 | h1 = ((h1 >> 20) | (h2 << 24)); 190 | 191 | U64TO8(&mac[0], h0); 192 | U64TO8(&mac[8], h1); 193 | 194 | /* zero out the state */ 195 | st->h[0] = 0; 196 | st->h[1] = 0; 197 | st->h[2] = 0; 198 | st->r[0] = 0; 199 | st->r[1] = 0; 200 | st->r[2] = 0; 201 | st->pad[0] = 0; 202 | st->pad[1] = 0; 203 | } 204 | 205 | -------------------------------------------------------------------------------- /pk/dsa.ml: -------------------------------------------------------------------------------- 1 | open Mirage_crypto.Uncommon 2 | 3 | open Common 4 | 5 | type pub = { p : Z.t ; q : Z.t ; gg : Z.t ; y : Z.t } 6 | 7 | let pub ?(fips = false) ~p ~q ~gg ~y () = 8 | let* () = guard Z.(one < gg && gg < p) (`Msg "bad generator") in 9 | let* () = guard (Z_extra.pseudoprime q) (`Msg "q is not prime") in 10 | let* () = guard (Z.is_odd p && Z_extra.pseudoprime p) (`Msg "p is not prime") in 11 | let* () = guard Z.(zero < y && y < p) (`Msg "y not in 0..p-1") in 12 | let* () = guard (q < p) (`Msg "q is not smaller than p") in 13 | let* () = guard Z.(zero = (pred p) mod q) (`Msg "p - 1 mod q <> 0") in 14 | let* () = 15 | if fips then 16 | match Z.numbits p, Z.numbits q with 17 | | 1024, 160 | 2048, 224 | 2048, 256 | 3072, 256 -> Ok () 18 | | _ -> Error (`Msg "bit length of p or q not FIPS specified") 19 | else 20 | Ok () 21 | in 22 | Ok { p ; q ; gg ; y } 23 | 24 | type priv = 25 | { p : Z.t ; q : Z.t ; gg : Z.t ; x : Z.t ; y : Z.t } 26 | 27 | let priv ?fips ~p ~q ~gg ~x ~y () = 28 | let* _ = pub ?fips ~p ~q ~gg ~y () in 29 | let* () = guard Z.(zero < x && x < q) (`Msg "x not in 1..q-1") in 30 | let* () = guard Z.(y = powm gg x p) (`Msg "y <> g ^ x mod p") in 31 | Ok { p ; q ; gg ; x ; y } 32 | 33 | let pub_of_priv { p; q; gg; y; _ } = { p; q; gg; y } 34 | 35 | type keysize = [ `Fips1024 | `Fips2048 | `Fips3072 | `Exactly of int * int ] 36 | 37 | let expand_size = function 38 | | `Fips1024 -> (1024, 160) 39 | | `Fips2048 -> (2048, 256) 40 | | `Fips3072 -> (3072, 256) 41 | | `Exactly (l, n) -> 42 | if 3 <= l && 2 <= n then (l, n) else 43 | invalid_arg "Dsa.generate: bits: `Exactly (%d, %d)" l n 44 | 45 | type mask = [ `No | `Yes | `Yes_with of Mirage_crypto_rng.g ] 46 | 47 | let expand_mask = function 48 | | `No -> `No 49 | | `Yes -> `Yes None 50 | | `Yes_with g -> `Yes (Some g) 51 | 52 | (* 53 | * FIPS.186-4-style derivation: 54 | * - p and q are derived using a method numerically like the one described in 55 | * A.1.1.2, adapted to use the native rng. 56 | * - g is derived as per A.2.1. 57 | *) 58 | let params ?g size = 59 | let two = Z.(~$2) in 60 | let (l, n) = expand_size size in 61 | let q = Z_extra.prime ?g ~msb:1 n in 62 | let p = 63 | let q_q = Z.(q * two) in 64 | until Z_extra.pseudoprime @@ fun () -> 65 | let x = Z_extra.gen_bits ?g ~msb:1 l in 66 | Z.(x - (x mod q_q) + one) 67 | in 68 | let gg = 69 | let e = Z.(pred p / q) in 70 | until ((<>) Z.one) @@ fun () -> 71 | let h = Z_extra.gen_r ?g two Z.(pred p) in 72 | Z.(powm h e p) 73 | in 74 | (* all checks above are already satisfied *) 75 | (p, q, gg) 76 | 77 | let generate ?g size = 78 | let (p, q, gg) = params ?g size in 79 | let x = Z_extra.gen_r ?g Z.one q in 80 | let y = Z.(powm gg x p) in 81 | (* checks are satisfied due to construction *) 82 | { p; q; gg; x; y } 83 | 84 | 85 | module K_gen (H : Digestif.S) = struct 86 | 87 | let drbg : 'a Mirage_crypto_rng.generator = 88 | let module M = Mirage_crypto_rng.Hmac_drbg (H) in (module M) 89 | 90 | let z_gen ~key:{ q; x; _ } z = 91 | let repr = Z_extra.to_octets_be ~size:(Z.numbits q // 8) in 92 | let g = Mirage_crypto_rng.create ~strict:true drbg in 93 | Mirage_crypto_rng.reseed ~g (repr x ^ repr Z.(z mod q)); 94 | Z_extra.gen_r ~g Z.one q 95 | 96 | let generate ~key buf = 97 | z_gen ~key (Z_extra.of_octets_be ~bits:(Z.numbits key.q) buf) 98 | end 99 | 100 | module K_gen_sha256 = K_gen (Digestif.SHA256) 101 | 102 | let sign_z ?(mask = `Yes) ?k:k0 ~key:({ p; q; gg; x; _ } as key) z = 103 | let k = match k0 with Some k -> k | None -> K_gen_sha256.z_gen ~key z in 104 | let k' = Z.invert k q 105 | and b, b' = match expand_mask mask with 106 | | `No -> Z.one, Z.one 107 | | `Yes g -> 108 | let m = Z_extra.gen_r ?g Z.one q in 109 | m, Z.invert m q 110 | in 111 | let r = Z.(powm_sec gg k p mod q) in 112 | (* normal DSA sign is: s = k^-1 * (z + r * x) mod q *) 113 | (* we apply blinding where possible and compute: 114 | s = k^-1 * b^-1 * (b * z + b * r * x) mod q 115 | see https://github.com/openssl/openssl/pull/6524 for further details *) 116 | let s = 117 | let t1 = 118 | let t11 = Z.(b * x mod q) in 119 | Z.(t11 * r mod q) 120 | in 121 | let t2 = Z.(b * z mod q) in 122 | let t3 = Z.((t1 + t2) mod q) in 123 | let t4 = Z.(k' * t3 mod q) in 124 | Z.(b' * t4 mod q) 125 | in 126 | if r = Z.zero || s = Z.zero then invalid_arg "k unsuitable" else (r, s) 127 | 128 | let verify_z ~key:({ p; q; gg; y }: pub ) (r, s) z = 129 | let v () = 130 | let w = Z.invert s q in 131 | let u1 = Z.(z * w mod q) 132 | and u2 = Z.(r * w mod q) in 133 | Z.((powm gg u1 p * powm y u2 p) mod p mod q) in 134 | Z.zero < r && r < q && Z.zero < s && s < q && v () = r 135 | 136 | let sign ?mask ?k ~(key : priv) digest = 137 | let bits = Z.numbits key.q in 138 | let size = bits // 8 in 139 | let (r, s) = sign_z ?mask ?k ~key (Z_extra.of_octets_be ~bits digest) in 140 | Z_extra.(to_octets_be ~size r, to_octets_be ~size s) 141 | 142 | let verify ~(key : pub) (r, s) digest = 143 | let z = Z_extra.of_octets_be ~bits:(Z.numbits key.q) digest 144 | and (r, s) = Z_extra.(of_octets_be r, of_octets_be s) in 145 | verify_z ~key (r, s) z 146 | 147 | let rec shift_left_inplace buf = function 148 | | 0 -> () 149 | | bits when bits mod 8 = 0 -> 150 | let off = bits / 8 in 151 | let to_blit = Bytes.length buf - off in 152 | Bytes.unsafe_blit buf off buf 0 to_blit ; 153 | Bytes.unsafe_fill buf to_blit (Bytes.length buf - to_blit) '\x00' 154 | | bits when bits < 8 -> 155 | let foo = 8 - bits in 156 | for i = 0 to Bytes.length buf - 2 do 157 | let b1 = Bytes.get_uint8 buf i 158 | and b2 = Bytes.get_uint8 buf (i + 1) in 159 | Bytes.set_uint8 buf i ((b1 lsl bits) lor (b2 lsr foo)) 160 | done ; 161 | Bytes.set_uint8 buf (Bytes.length buf - 1) 162 | (Bytes.get_uint8 buf (Bytes.length buf - 1) lsl bits) 163 | | bits -> 164 | shift_left_inplace buf (8 * (bits / 8)) ; 165 | shift_left_inplace buf (bits mod 8) 166 | 167 | let (lsl) buf bits = 168 | let buf' = Bytes.of_string buf in 169 | shift_left_inplace buf' bits; 170 | Bytes.unsafe_to_string buf' 171 | 172 | let massage ~key:({ q; _ }: pub) digest = 173 | let bits = Z.numbits q in 174 | if bits >= String.length digest * 8 then 175 | digest 176 | else 177 | let buf = Z_extra.(to_octets_be Z.(of_octets_be digest mod q)) in 178 | buf lsl ((8 - bits mod 8) mod 8) 179 | -------------------------------------------------------------------------------- /src/chacha20.ml: -------------------------------------------------------------------------------- 1 | (* Based on https://github.com/abeaumont/ocaml-chacha.git *) 2 | 3 | open Uncommon 4 | 5 | let block = 64 6 | 7 | type key = string 8 | 9 | let of_secret a = a 10 | 11 | let chacha20_block state idx key_stream = 12 | Native.Chacha.round 10 state key_stream idx 13 | 14 | let init ctr ~key ~nonce = 15 | let ctr_off = 48 in 16 | let set_ctr32 b v = Bytes.set_int32_le b ctr_off v 17 | and set_ctr64 b v = Bytes.set_int64_le b ctr_off v 18 | in 19 | let inc32 b = set_ctr32 b (Int32.add (Bytes.get_int32_le b ctr_off) 1l) 20 | and inc64 b = set_ctr64 b (Int64.add (Bytes.get_int64_le b ctr_off) 1L) 21 | in 22 | let s, key, init_ctr, nonce_off, inc = 23 | match String.length key, String.length nonce, Int64.shift_right ctr 32 = 0L with 24 | | 32, 12, true -> 25 | let ctr = Int64.to_int32 ctr in 26 | "expand 32-byte k", key, (fun b -> set_ctr32 b ctr), 52, inc32 27 | | 32, 12, false -> 28 | invalid_arg "Counter too big for IETF mode (32 bit counter)" 29 | | 32, 8, _ -> 30 | "expand 32-byte k", key, (fun b -> set_ctr64 b ctr), 56, inc64 31 | | 16, 8, _ -> 32 | let k = key ^ key in 33 | "expand 16-byte k", k, (fun b -> set_ctr64 b ctr), 56, inc64 34 | | _ -> invalid_arg "Valid parameters are nonce 12 bytes and key 32 bytes \ 35 | (counter 32 bit), or nonce 8 byte and key 16 or 32 \ 36 | bytes (counter 64 bit)." 37 | in 38 | let state = Bytes.create block in 39 | Bytes.unsafe_blit_string s 0 state 0 16 ; 40 | Bytes.unsafe_blit_string key 0 state 16 32 ; 41 | init_ctr state ; 42 | Bytes.unsafe_blit_string nonce 0 state nonce_off (String.length nonce) ; 43 | state, inc 44 | 45 | let crypt_into ~key ~nonce ~ctr src ~src_off dst ~dst_off len = 46 | let state, inc = init ctr ~key ~nonce in 47 | let block_count = len // block in 48 | let last_len = 49 | let last = len mod block in 50 | if last = 0 then block else last 51 | in 52 | let rec loop i = function 53 | | 0 -> () 54 | | 1 -> 55 | if last_len = block then begin 56 | chacha20_block state (dst_off + i) dst ; 57 | Native.xor_into_bytes src (src_off + i) dst (dst_off + i) block 58 | end else begin 59 | let buf = Bytes.create block in 60 | chacha20_block state 0 buf ; 61 | Native.xor_into_bytes src (src_off + i) buf 0 last_len ; 62 | Bytes.unsafe_blit buf 0 dst (dst_off + i) last_len 63 | end 64 | | n -> 65 | chacha20_block state (dst_off + i) dst ; 66 | Native.xor_into_bytes src (src_off + i) dst (dst_off + i) block ; 67 | inc state; 68 | (loop [@tailcall]) (i + block) (n - 1) 69 | in 70 | loop 0 block_count 71 | 72 | let crypt ~key ~nonce ?(ctr = 0L) data = 73 | let l = String.length data in 74 | let res = Bytes.create l in 75 | crypt_into ~key ~nonce ~ctr data ~src_off:0 res ~dst_off:0 l; 76 | Bytes.unsafe_to_string res 77 | 78 | module P = Poly1305.It 79 | 80 | let tag_size = P.mac_size 81 | 82 | let generate_poly1305_key ~key ~nonce = 83 | crypt ~key ~nonce (String.make 32 '\000') 84 | 85 | let mac_into ~key ~adata src ~src_off len dst ~dst_off = 86 | let pad16 l = 87 | let len = l mod 16 in 88 | if len = 0 then "" else String.make (16 - len) '\000' 89 | and len_buf = 90 | let data = Bytes.create 16 in 91 | Bytes.set_int64_le data 0 (Int64.of_int (String.length adata)); 92 | Bytes.set_int64_le data 8 (Int64.of_int len); 93 | Bytes.unsafe_to_string data 94 | in 95 | let p1 = pad16 (String.length adata) and p2 = pad16 len in 96 | P.unsafe_mac_into ~key [ adata, 0, String.length adata ; 97 | p1, 0, String.length p1 ; 98 | src, src_off, len ; 99 | p2, 0, String.length p2 ; 100 | len_buf, 0, String.length len_buf ] 101 | dst ~dst_off 102 | 103 | let unsafe_authenticate_encrypt_into ~key ~nonce ?(adata = "") src ~src_off dst ~dst_off ~tag_off len = 104 | let poly1305_key = generate_poly1305_key ~key ~nonce in 105 | crypt_into ~key ~nonce ~ctr:1L src ~src_off dst ~dst_off len; 106 | mac_into ~key:poly1305_key ~adata (Bytes.unsafe_to_string dst) ~src_off:dst_off len dst ~dst_off:tag_off 107 | 108 | let authenticate_encrypt_into ~key ~nonce ?adata src ~src_off dst ~dst_off ~tag_off len = 109 | if String.length src - src_off < len then 110 | invalid_arg "Chacha20: src length %u - src_off %u < len %u" 111 | (String.length src) src_off len; 112 | if Bytes.length dst - dst_off < len then 113 | invalid_arg "Chacha20: dst length %u - dst_off %u < len %u" 114 | (Bytes.length dst) dst_off len; 115 | if Bytes.length dst - tag_off < tag_size then 116 | invalid_arg "Chacha20: dst length %u - tag_off %u < tag_size %u" 117 | (Bytes.length dst) tag_off tag_size; 118 | unsafe_authenticate_encrypt_into ~key ~nonce ?adata src ~src_off dst ~dst_off ~tag_off len 119 | 120 | let authenticate_encrypt ~key ~nonce ?adata data = 121 | let l = String.length data in 122 | let dst = Bytes.create (l + tag_size) in 123 | unsafe_authenticate_encrypt_into ~key ~nonce ?adata data ~src_off:0 dst ~dst_off:0 ~tag_off:l l; 124 | Bytes.unsafe_to_string dst 125 | 126 | let authenticate_encrypt_tag ~key ~nonce ?adata data = 127 | let r = authenticate_encrypt ~key ~nonce ?adata data in 128 | String.sub r 0 (String.length data), String.sub r (String.length data) tag_size 129 | 130 | let unsafe_authenticate_decrypt_into ~key ~nonce ?(adata = "") src ~src_off ~tag_off dst ~dst_off len = 131 | let poly1305_key = generate_poly1305_key ~key ~nonce in 132 | let ctag = Bytes.create tag_size in 133 | mac_into ~key:poly1305_key ~adata src ~src_off len ctag ~dst_off:0; 134 | crypt_into ~key ~nonce ~ctr:1L src ~src_off dst ~dst_off len; 135 | Eqaf.equal (String.sub src tag_off tag_size) (Bytes.unsafe_to_string ctag) 136 | 137 | let authenticate_decrypt_into ~key ~nonce ?adata src ~src_off ~tag_off dst ~dst_off len = 138 | if String.length src - src_off < len then 139 | invalid_arg "Chacha20: src length %u - src_off %u < len %u" 140 | (String.length src) src_off len; 141 | if Bytes.length dst - dst_off < len then 142 | invalid_arg "Chacha20: dst length %u - dst_off %u < len %u" 143 | (Bytes.length dst) dst_off len; 144 | if String.length src - tag_off < tag_size then 145 | invalid_arg "Chacha20: src length %u - tag_off %u < tag_size %u" 146 | (String.length src) tag_off tag_size; 147 | unsafe_authenticate_decrypt_into ~key ~nonce ?adata src ~src_off ~tag_off dst ~dst_off len 148 | 149 | let authenticate_decrypt ~key ~nonce ?adata data = 150 | if String.length data < tag_size then 151 | None 152 | else 153 | let l = String.length data - tag_size in 154 | let r = Bytes.create l in 155 | if unsafe_authenticate_decrypt_into ~key ~nonce ?adata data ~src_off:0 ~tag_off:l r ~dst_off:0 l then 156 | Some (Bytes.unsafe_to_string r) 157 | else 158 | None 159 | 160 | let authenticate_decrypt_tag ~key ~nonce ?adata ~tag data = 161 | let cdata = data ^ tag in 162 | authenticate_decrypt ~key ~nonce ?adata cdata 163 | -------------------------------------------------------------------------------- /src/native/poly1305-donna-32.h: -------------------------------------------------------------------------------- 1 | // from https://github.com/floodyberry/poly1305-donna.git 2 | 3 | /* 4 | poly1305 implementation using 32 bit * 32 bit = 64 bit multiplication and 64 bit addition 5 | */ 6 | 7 | #if defined(_MSC_VER) 8 | #define POLY1305_NOINLINE __declspec(noinline) 9 | #elif defined(__GNUC__) 10 | #define POLY1305_NOINLINE __attribute__((noinline)) 11 | #else 12 | #define POLY1305_NOINLINE 13 | #endif 14 | 15 | #define poly1305_block_size 16 16 | 17 | /* 17 + sizeof(size_t) + 14*sizeof(unsigned long) */ 18 | typedef struct poly1305_state_internal_t { 19 | unsigned long r[5]; 20 | unsigned long h[5]; 21 | unsigned long pad[4]; 22 | size_t leftover; 23 | unsigned char buffer[poly1305_block_size]; 24 | unsigned char final; 25 | } poly1305_state_internal_t; 26 | 27 | /* interpret four 8 bit unsigned integers as a 32 bit unsigned integer in little endian */ 28 | static unsigned long 29 | U8TO32(const unsigned char *p) { 30 | return 31 | (((unsigned long)(p[0] & 0xff) ) | 32 | ((unsigned long)(p[1] & 0xff) << 8) | 33 | ((unsigned long)(p[2] & 0xff) << 16) | 34 | ((unsigned long)(p[3] & 0xff) << 24)); 35 | } 36 | 37 | /* store a 32 bit unsigned integer as four 8 bit unsigned integers in little endian */ 38 | static void 39 | U32TO8(unsigned char *p, unsigned long v) { 40 | p[0] = (v ) & 0xff; 41 | p[1] = (v >> 8) & 0xff; 42 | p[2] = (v >> 16) & 0xff; 43 | p[3] = (v >> 24) & 0xff; 44 | } 45 | 46 | static void 47 | poly1305_init(poly1305_context *ctx, const unsigned char key[32]) { 48 | poly1305_state_internal_t *st = (poly1305_state_internal_t *)ctx; 49 | 50 | /* r &= 0xffffffc0ffffffc0ffffffc0fffffff */ 51 | st->r[0] = (U8TO32(&key[ 0]) ) & 0x3ffffff; 52 | st->r[1] = (U8TO32(&key[ 3]) >> 2) & 0x3ffff03; 53 | st->r[2] = (U8TO32(&key[ 6]) >> 4) & 0x3ffc0ff; 54 | st->r[3] = (U8TO32(&key[ 9]) >> 6) & 0x3f03fff; 55 | st->r[4] = (U8TO32(&key[12]) >> 8) & 0x00fffff; 56 | 57 | /* h = 0 */ 58 | st->h[0] = 0; 59 | st->h[1] = 0; 60 | st->h[2] = 0; 61 | st->h[3] = 0; 62 | st->h[4] = 0; 63 | 64 | /* save pad for later */ 65 | st->pad[0] = U8TO32(&key[16]); 66 | st->pad[1] = U8TO32(&key[20]); 67 | st->pad[2] = U8TO32(&key[24]); 68 | st->pad[3] = U8TO32(&key[28]); 69 | 70 | st->leftover = 0; 71 | st->final = 0; 72 | } 73 | 74 | static void 75 | poly1305_blocks(poly1305_state_internal_t *st, const unsigned char *m, size_t bytes) { 76 | const unsigned long hibit = (st->final) ? 0 : (1UL << 24); /* 1 << 128 */ 77 | unsigned long r0,r1,r2,r3,r4; 78 | unsigned long s1,s2,s3,s4; 79 | unsigned long h0,h1,h2,h3,h4; 80 | unsigned long long d0,d1,d2,d3,d4; 81 | unsigned long c; 82 | 83 | r0 = st->r[0]; 84 | r1 = st->r[1]; 85 | r2 = st->r[2]; 86 | r3 = st->r[3]; 87 | r4 = st->r[4]; 88 | 89 | s1 = r1 * 5; 90 | s2 = r2 * 5; 91 | s3 = r3 * 5; 92 | s4 = r4 * 5; 93 | 94 | h0 = st->h[0]; 95 | h1 = st->h[1]; 96 | h2 = st->h[2]; 97 | h3 = st->h[3]; 98 | h4 = st->h[4]; 99 | 100 | while (bytes >= poly1305_block_size) { 101 | /* h += m[i] */ 102 | h0 += (U8TO32(m+ 0) ) & 0x3ffffff; 103 | h1 += (U8TO32(m+ 3) >> 2) & 0x3ffffff; 104 | h2 += (U8TO32(m+ 6) >> 4) & 0x3ffffff; 105 | h3 += (U8TO32(m+ 9) >> 6) & 0x3ffffff; 106 | h4 += (U8TO32(m+12) >> 8) | hibit; 107 | 108 | /* h *= r */ 109 | d0 = ((unsigned long long)h0 * r0) + ((unsigned long long)h1 * s4) + ((unsigned long long)h2 * s3) + ((unsigned long long)h3 * s2) + ((unsigned long long)h4 * s1); 110 | d1 = ((unsigned long long)h0 * r1) + ((unsigned long long)h1 * r0) + ((unsigned long long)h2 * s4) + ((unsigned long long)h3 * s3) + ((unsigned long long)h4 * s2); 111 | d2 = ((unsigned long long)h0 * r2) + ((unsigned long long)h1 * r1) + ((unsigned long long)h2 * r0) + ((unsigned long long)h3 * s4) + ((unsigned long long)h4 * s3); 112 | d3 = ((unsigned long long)h0 * r3) + ((unsigned long long)h1 * r2) + ((unsigned long long)h2 * r1) + ((unsigned long long)h3 * r0) + ((unsigned long long)h4 * s4); 113 | d4 = ((unsigned long long)h0 * r4) + ((unsigned long long)h1 * r3) + ((unsigned long long)h2 * r2) + ((unsigned long long)h3 * r1) + ((unsigned long long)h4 * r0); 114 | 115 | /* (partial) h %= p */ 116 | c = (unsigned long)(d0 >> 26); h0 = (unsigned long)d0 & 0x3ffffff; 117 | d1 += c; c = (unsigned long)(d1 >> 26); h1 = (unsigned long)d1 & 0x3ffffff; 118 | d2 += c; c = (unsigned long)(d2 >> 26); h2 = (unsigned long)d2 & 0x3ffffff; 119 | d3 += c; c = (unsigned long)(d3 >> 26); h3 = (unsigned long)d3 & 0x3ffffff; 120 | d4 += c; c = (unsigned long)(d4 >> 26); h4 = (unsigned long)d4 & 0x3ffffff; 121 | h0 += c * 5; c = (h0 >> 26); h0 = h0 & 0x3ffffff; 122 | h1 += c; 123 | 124 | m += poly1305_block_size; 125 | bytes -= poly1305_block_size; 126 | } 127 | 128 | st->h[0] = h0; 129 | st->h[1] = h1; 130 | st->h[2] = h2; 131 | st->h[3] = h3; 132 | st->h[4] = h4; 133 | } 134 | 135 | POLY1305_NOINLINE static void 136 | poly1305_finish(poly1305_context *ctx, unsigned char mac[16]) { 137 | poly1305_state_internal_t *st = (poly1305_state_internal_t *)ctx; 138 | unsigned long h0,h1,h2,h3,h4,c; 139 | unsigned long g0,g1,g2,g3,g4; 140 | unsigned long long f; 141 | unsigned long mask; 142 | 143 | /* process the remaining block */ 144 | if (st->leftover) { 145 | size_t i = st->leftover; 146 | st->buffer[i++] = 1; 147 | for (; i < poly1305_block_size; i++) 148 | st->buffer[i] = 0; 149 | st->final = 1; 150 | poly1305_blocks(st, st->buffer, poly1305_block_size); 151 | } 152 | 153 | /* fully carry h */ 154 | h0 = st->h[0]; 155 | h1 = st->h[1]; 156 | h2 = st->h[2]; 157 | h3 = st->h[3]; 158 | h4 = st->h[4]; 159 | 160 | c = h1 >> 26; h1 = h1 & 0x3ffffff; 161 | h2 += c; c = h2 >> 26; h2 = h2 & 0x3ffffff; 162 | h3 += c; c = h3 >> 26; h3 = h3 & 0x3ffffff; 163 | h4 += c; c = h4 >> 26; h4 = h4 & 0x3ffffff; 164 | h0 += c * 5; c = h0 >> 26; h0 = h0 & 0x3ffffff; 165 | h1 += c; 166 | 167 | /* compute h + -p */ 168 | g0 = h0 + 5; c = g0 >> 26; g0 &= 0x3ffffff; 169 | g1 = h1 + c; c = g1 >> 26; g1 &= 0x3ffffff; 170 | g2 = h2 + c; c = g2 >> 26; g2 &= 0x3ffffff; 171 | g3 = h3 + c; c = g3 >> 26; g3 &= 0x3ffffff; 172 | g4 = h4 + c - (1UL << 26); 173 | 174 | /* select h if h < p, or h + -p if h >= p */ 175 | mask = (g4 >> ((sizeof(unsigned long) * 8) - 1)) - 1; 176 | g0 &= mask; 177 | g1 &= mask; 178 | g2 &= mask; 179 | g3 &= mask; 180 | g4 &= mask; 181 | mask = ~mask; 182 | h0 = (h0 & mask) | g0; 183 | h1 = (h1 & mask) | g1; 184 | h2 = (h2 & mask) | g2; 185 | h3 = (h3 & mask) | g3; 186 | h4 = (h4 & mask) | g4; 187 | 188 | /* h = h % (2^128) */ 189 | h0 = ((h0 ) | (h1 << 26)) & 0xffffffff; 190 | h1 = ((h1 >> 6) | (h2 << 20)) & 0xffffffff; 191 | h2 = ((h2 >> 12) | (h3 << 14)) & 0xffffffff; 192 | h3 = ((h3 >> 18) | (h4 << 8)) & 0xffffffff; 193 | 194 | /* mac = (h + pad) % (2^128) */ 195 | f = (unsigned long long)h0 + st->pad[0] ; h0 = (unsigned long)f; 196 | f = (unsigned long long)h1 + st->pad[1] + (f >> 32); h1 = (unsigned long)f; 197 | f = (unsigned long long)h2 + st->pad[2] + (f >> 32); h2 = (unsigned long)f; 198 | f = (unsigned long long)h3 + st->pad[3] + (f >> 32); h3 = (unsigned long)f; 199 | 200 | U32TO8(mac + 0, h0); 201 | U32TO8(mac + 4, h1); 202 | U32TO8(mac + 8, h2); 203 | U32TO8(mac + 12, h3); 204 | 205 | /* zero out the state */ 206 | st->h[0] = 0; 207 | st->h[1] = 0; 208 | st->h[2] = 0; 209 | st->h[3] = 0; 210 | st->h[4] = 0; 211 | st->r[0] = 0; 212 | st->r[1] = 0; 213 | st->r[2] = 0; 214 | st->r[3] = 0; 215 | st->r[4] = 0; 216 | st->pad[0] = 0; 217 | st->pad[1] = 0; 218 | st->pad[2] = 0; 219 | st->pad[3] = 0; 220 | } 221 | 222 | -------------------------------------------------------------------------------- /rng/entropy.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Hannes Mehnert 3 | * Copyright (c) 2014 Anil Madhavapeddy 4 | * Copyright (c) 2014-2016 David Kaloper Meršinjak 5 | * Copyright (c) 2015 Citrix Systems Inc 6 | * All rights reserved. 7 | * 8 | * Redistribution and use in source and binary forms, with or without 9 | * modification, are permitted provided that the following conditions are met: 10 | * 11 | * * Redistributions of source code must retain the above copyright notice, this 12 | * list of conditions and the following disclaimer. 13 | * 14 | * * Redistributions in binary form must reproduce the above copyright notice, 15 | * this list of conditions and the following disclaimer in the documentation 16 | * and/or other materials provided with the distribution. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | *) 29 | 30 | let src = Logs.Src.create "mirage-crypto-rng-entropy" ~doc:"Mirage crypto RNG Entropy" 31 | module Log = (val Logs.src_log src : Logs.LOG) 32 | 33 | let rdrand_calls = Atomic.make 0 34 | let rdrand_failures = Atomic.make 0 35 | let rdseed_calls = Atomic.make 0 36 | let rdseed_failures = Atomic.make 0 37 | 38 | module Cpu_native = struct 39 | 40 | external cycles : unit -> int = "mc_cycle_counter" [@@noalloc] 41 | external rdseed : bytes -> int -> bool = "mc_cpu_rdseed" [@@noalloc] 42 | external rdrand : bytes -> int -> bool = "mc_cpu_rdrand" [@@noalloc] 43 | external rng_type : unit -> int = "mc_cpu_rng_type" [@@noalloc] 44 | 45 | let cpu_rng = 46 | match rng_type () with 47 | | 0 -> [] 48 | | 1 -> [ `Rdrand ] 49 | | 2 -> [ `Rdseed ] 50 | | 3 -> [ `Rdrand ; `Rdseed ] 51 | | _ -> assert false 52 | end 53 | 54 | module S = Set.Make(struct 55 | type t = int * string 56 | (* only the name is relevant for comparison - the idx not *) 57 | let compare ((_a, an) : int * string) ((_b, bn) : int * string) = 58 | String.compare an bn 59 | end) 60 | 61 | let _sources = Atomic.make S.empty 62 | 63 | type source = Rng.source 64 | 65 | let register_source name = 66 | let rec set () = 67 | let sources = Atomic.get _sources in 68 | let n = S.cardinal sources in 69 | let source = (n, name) in 70 | if Atomic.compare_and_set _sources sources (S.add source sources) then 71 | source 72 | else 73 | set () 74 | in 75 | set () 76 | 77 | let id (idx, _) = idx 78 | 79 | let sources () = S.elements (Atomic.get _sources) 80 | 81 | let pp_source ppf (idx, name) = Format.fprintf ppf "[%d] %s" idx name 82 | 83 | let cpu_rng isn buf off = match isn with 84 | | `Rdseed -> 85 | Atomic.incr rdseed_calls; 86 | let success = Cpu_native.rdseed buf off in 87 | if not success then Atomic.incr rdseed_failures; 88 | success 89 | | `Rdrand -> 90 | Atomic.incr rdrand_calls; 91 | let success = Cpu_native.rdrand buf off in 92 | if not success then Atomic.incr rdrand_failures; 93 | success 94 | 95 | let random preferred = 96 | match Cpu_native.cpu_rng with 97 | | [] -> None 98 | | xs when List.mem preferred xs -> Some preferred 99 | | y::_ -> Some y 100 | 101 | let write_header source data = 102 | Bytes.set_uint8 data 0 source; 103 | Bytes.set_uint8 data 1 (Bytes.length data - 2) 104 | 105 | let header source data = 106 | let hdr = Bytes.create (2 + String.length data) in 107 | Bytes.unsafe_blit_string data 0 hdr 2 (String.length data); 108 | write_header source hdr; 109 | Bytes.unsafe_to_string hdr 110 | 111 | (* Note: 112 | * `bootstrap` is not a simple feedback loop. It attempts to exploit CPU-level 113 | * data races that lead to execution-time variability of identical instructions. 114 | * See Whirlwind RNG: 115 | * http://www.ieee-security.org/TC/SP2014/papers/Not-So-RandomNumbersinVirtualizedLinuxandtheWhirlwindRNG.pdf 116 | *) 117 | let whirlwind_bootstrap id = 118 | let outer = 100 119 | and inner_max = 1024 120 | and a = ref 0 121 | in 122 | let buf = Bytes.create (outer * 2 + 2) in 123 | for i = 0 to outer - 1 do 124 | let tsc = Cpu_native.cycles () in 125 | Bytes.set_uint16_le buf ((i + 1) * 2) tsc; 126 | for j = 1 to tsc mod inner_max do 127 | a := tsc / j - !a * i + 1 128 | done 129 | done; 130 | write_header id buf; 131 | Bytes.unsafe_to_string buf 132 | 133 | let cpu_rng_bootstrap = 134 | let rdrand_bootstrap id = 135 | let rec go acc = function 136 | | 0 -> acc 137 | | n -> 138 | let buf = Bytes.create 10 in 139 | let r = cpu_rng `Rdrand buf 2 in 140 | write_header id buf; 141 | if not r then 142 | go acc (pred n) 143 | else 144 | go (Bytes.unsafe_to_string buf :: acc) (pred n) 145 | in 146 | let result = go [] 512 |> String.concat "" in 147 | if String.length result = 0 then 148 | failwith "Too many RDRAND failures" 149 | else 150 | result 151 | in 152 | match random `Rdseed with 153 | | None -> Error `Not_supported 154 | | Some `Rdseed -> 155 | let cpu_rng_bootstrap id = 156 | let buf = Bytes.create 10 in 157 | let r = cpu_rng `Rdseed buf 2 in 158 | write_header id buf; 159 | if not r then 160 | if List.mem `Rdrand Cpu_native.cpu_rng then 161 | rdrand_bootstrap id 162 | else 163 | failwith "RDSEED failed, and RDRAND not available" 164 | else 165 | Bytes.unsafe_to_string buf 166 | in 167 | Ok cpu_rng_bootstrap 168 | | Some `Rdrand -> Ok rdrand_bootstrap 169 | 170 | let bootstrap id = 171 | match cpu_rng_bootstrap with 172 | | Error `Not_supported -> whirlwind_bootstrap id 173 | | Ok cpu_rng_bootstrap -> 174 | try cpu_rng_bootstrap id with 175 | | Failure f -> 176 | Log.err (fun m -> m "CPU RNG bootstrap failed: %s, using whirlwind" f); 177 | whirlwind_bootstrap id 178 | 179 | let interrupt_hook () = 180 | let buf = Bytes.create 4 in 181 | let a = Cpu_native.cycles () in 182 | Bytes.set_int32_le buf 0 (Int32.of_int a) ; 183 | Bytes.unsafe_to_string buf 184 | 185 | let timer_accumulator g = 186 | let g = match g with None -> Some (Rng.default_generator ()) | Some g -> Some g in 187 | let source = register_source "timer" in 188 | let `Acc handle = Rng.accumulate g source in 189 | (fun () -> handle (interrupt_hook ())) 190 | 191 | let feed_pools g source f = 192 | let g = match g with None -> Some (Rng.default_generator ()) | Some g -> Some g in 193 | let `Acc handle = Rng.accumulate g source in 194 | for _i = 0 to pred (Rng.pools g) do 195 | match f () with 196 | | Ok data -> handle data 197 | | Error `No_random_available -> 198 | (* should we log a message? *) 199 | () 200 | done 201 | 202 | let cpu_rng = 203 | match random `Rdrand with 204 | | None -> Error `Not_supported 205 | | Some insn -> 206 | let cpu_rng g = 207 | let randomf = cpu_rng insn 208 | and source = 209 | let s = match insn with `Rdrand -> "rdrand" | `Rdseed -> "rdseed" in 210 | register_source s 211 | in 212 | let f () = 213 | let buf = Bytes.create 8 in 214 | if randomf buf 0 then 215 | Ok (Bytes.unsafe_to_string buf) 216 | else 217 | Error `No_random_available 218 | in 219 | fun () -> feed_pools g source f 220 | in 221 | Ok cpu_rng 222 | 223 | let rdrand_calls () = Atomic.get rdrand_calls 224 | let rdrand_failures () = Atomic.get rdrand_failures 225 | let rdseed_calls () = Atomic.get rdseed_calls 226 | let rdseed_failures () = Atomic.get rdseed_failures 227 | --------------------------------------------------------------------------------