From 12790c20977dfc3296980237df4a350cbb3150b5 Mon Sep 17 00:00:00 2001 From: =?utf8?q?St=C3=A9phane=20Glondu?= Date: Mon, 22 Nov 2021 17:03:45 +0100 Subject: [PATCH] Import ocaml-eqaf_0.8.orig.tar.bz2 [dgit import orig ocaml-eqaf_0.8.orig.tar.bz2] --- .cirrus.yml | 13 + .github/workflows/test.yml | 42 ++++ .gitignore | 16 ++ .ocamlformat | 2 + CHANGES.md | 80 ++++++ LICENSE.md | 20 ++ README.md | 204 +++++++++++++++ attack/attack.ml | 79 ++++++ attack/dune | 11 + attack/microtime.c | 41 ++++ attack/microtime.ml | 1 + check/README.md | 127 ++++++++++ check/benchmark.ml | 63 +++++ check/check.ml | 477 ++++++++++++++++++++++++++++++++++++ check/dune | 15 ++ check/fmt.ml | 4 + check/linear_algebra.ml | 129 ++++++++++ check/unsafe_pre407.ml | 1 + check/unsafe_pre408.ml | 1 + check/unsafe_stable.ml | 1 + clock/clock_linux.ml | 6 + clock/clock_linux_stubs.c | 55 +++++ clock/clock_mach.ml | 5 + clock/clock_mach_stubs.c | 35 +++ clock/clock_windows.ml | 5 + clock/clock_windows_stubs.c | 30 +++ clock/dune | 21 ++ clock/select/select.ml | 65 +++++ config/config.ml | 10 + config/dune | 7 + dune-project | 3 + eqaf.opam | 28 +++ fuzz/dune | 11 + fuzz/fuzz.ml | 133 ++++++++++ lib/dune | 19 ++ lib/eqaf.ml | 389 +++++++++++++++++++++++++++++ lib/eqaf.mli | 318 ++++++++++++++++++++++++ lib/eqaf_bigstring.ml | 106 ++++++++ lib/eqaf_bigstring.mli | 9 + lib/eqaf_cstruct.ml | 26 ++ lib/eqaf_cstruct.mli | 7 + lib/unsafe_pre407.ml | 13 + lib/unsafe_pre408.ml | 13 + lib/unsafe_stable.ml | 2 + test/dune | 27 ++ test/test.ml | 209 ++++++++++++++++ test/test_branch.ml | 140 +++++++++++ 47 files changed, 3019 insertions(+) create mode 100644 .cirrus.yml create mode 100644 .github/workflows/test.yml create mode 100644 .gitignore create mode 100644 .ocamlformat create mode 100644 CHANGES.md create mode 100644 LICENSE.md create mode 100644 README.md create mode 100644 attack/attack.ml create mode 100644 attack/dune create mode 100644 attack/microtime.c create mode 100644 attack/microtime.ml create mode 100644 check/README.md create mode 100644 check/benchmark.ml create mode 100644 check/check.ml create mode 100644 check/dune create mode 100644 check/fmt.ml create mode 100644 check/linear_algebra.ml create mode 100644 check/unsafe_pre407.ml create mode 100644 check/unsafe_pre408.ml create mode 100644 check/unsafe_stable.ml create mode 100644 clock/clock_linux.ml create mode 100644 clock/clock_linux_stubs.c create mode 100644 clock/clock_mach.ml create mode 100644 clock/clock_mach_stubs.c create mode 100644 clock/clock_windows.ml create mode 100644 clock/clock_windows_stubs.c create mode 100644 clock/dune create mode 100644 clock/select/select.ml create mode 100644 config/config.ml create mode 100644 config/dune create mode 100644 dune-project create mode 100644 eqaf.opam create mode 100644 fuzz/dune create mode 100644 fuzz/fuzz.ml create mode 100644 lib/dune create mode 100644 lib/eqaf.ml create mode 100644 lib/eqaf.mli create mode 100644 lib/eqaf_bigstring.ml create mode 100644 lib/eqaf_bigstring.mli create mode 100644 lib/eqaf_cstruct.ml create mode 100644 lib/eqaf_cstruct.mli create mode 100644 lib/unsafe_pre407.ml create mode 100644 lib/unsafe_pre408.ml create mode 100644 lib/unsafe_stable.ml create mode 100644 test/dune create mode 100644 test/test.ml create mode 100644 test/test_branch.ml diff --git a/.cirrus.yml b/.cirrus.yml new file mode 100644 index 0000000..5caf7b8 --- /dev/null +++ b/.cirrus.yml @@ -0,0 +1,13 @@ +freebsd_instance: + image_family: freebsd-12-1 + +freebsd_task: + env: + matrix: + - OCAML_VERSION: 4.10.1 + - OCAML_VERSION: 4.11.1 + pkg_install_script: pkg install -y ocaml-opam gmp gmake pkgconf bash + ocaml_script: opam init -a --comp=$OCAML_VERSION + dependencies_script: eval `opam env` && opam install -y --deps-only . + build_script: eval `opam env` && dune build @install + test_script: eval `opam env` && opam install -y -t --deps-only . && dune build @runtest diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 0000000..c2151fb --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,42 @@ +name: Eqaf + +on: [push, pull_request] + +jobs: + tests: + name: Tests + + strategy: + fail-fast: false + matrix: + ocaml-version: ["4.10.0", "4.09.0", "4.08.1"] + operating-system: [macos-latest, ubuntu-latest, windows-latest] + + runs-on: ${{ matrix.operating-system }} + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Use OCaml ${{ matrix.ocaml-version }} + uses: avsm/setup-ocaml@v2 + with: + ocaml-version: ${{ matrix.ocaml-version }} + + - name: Install nasm + uses: ilammy/setup-nasm@v1 + + - name: Install dependencies + run: | + opam pin add -n eqaf . + opam depext -y eqaf + opam install -t --deps-only . + + - name: Build + run: opam exec -- dune build -p eqaf + - name: Simple tests + run: opam exec -- dune exec test/test.exe + - name: Branch tests + run: opam exec -- dune exec test/test_branch.exe + - name: Fuzz tests + run: opam exec -- dune exec fuzz/fuzz.exe diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d0504dc --- /dev/null +++ b/.gitignore @@ -0,0 +1,16 @@ +_build +setup.data +setup.log +doc/*.html +*.native +*.byte +*.so +lib/decompress_conf.ml +*.tar.gz +_tests +lib_test/files +zpipe +c/dpipe +*.install +*~ +.merlin \ No newline at end of file diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..94f7d43 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,2 @@ +version=0.18.0 +disable=true diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..03816f6 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,80 @@ +### v0.8 2021-08-06 Paris (France) + +- Fix the check tool on 4.11.0 (@dinosaure, @cfcs, @stedolan, #30) + The compilation on 4.11 triggers a case where the locality of the expected + value when we test `exists_uint8` must be the same. Otherwise, the access to + this value can have a cost which faults our result. +- Add several utility functions (@cfcs, @dinosaure, #26) + * `bytes_of_hex` & `string_of_hex`, hex decoding + * `hex_of_bytes` & `hex_of_string`, hex encoding + * `divmod`, unsigned `int32` division with small divisors + * `ascii_of_int32`, conversion from `int32` to decimal `string` + representation + * `lowercase_ascii` & `uppercase_ascii`, _constant-time_ implementation of + `String.{lower,upper}case_ascii` + * `select_a_if_in_range`, like `select_int` but only supporting positive + ranges + * `int_of_bool` & `bool_of_int`, _constant-time_ of `Bool.to_int` + + A documentation exists for each function. The _constant-time_ is checked only + systematically for `divmod`. +- Merge optional sub-packages (@kit-ty-kate, @hannesm, @dinosaure, #27) + `cstruct` becomes a required dependency of `eqaf` +- Fix FreeBSD support and remove support of < OCaml 4.07 and remove the + dependency to `bigarray-compat` (@hannesm, @dinosaure, #32) +- Add a CI on FreeBSD (@dinosaure, @hannesm, #33) +- Remove the test `check/check.exe` (@dinosaure, #31) + The test `check/check.exe` is really volatile and should be executed into a + controlled environment (for instance, with `nice -n19` and a _bare-metal_ + computer). We still require the test for any improvement of `eqaf` but it is + executed separately from our CI. + +### v0.7 2020-04-16 Paris (France) + +- Add `find_uint8` (@dinosaure, @cfcs, #20) +- Add `exists_uint8` (@dinosaure, @cfcs, #20) + +### v0.6 2020-03-11 Paris (France) + +- remove build dependency on dune (@CraigFe, #16) +- add bigarray-compat and optional dependencies (@hannesm, #17) +- add `select_int`, `one_if_not_zero`, `zero_if_not_zero` (@cfcs, @dinosaure, #19, #18) + +### v0.5 2019-07-01 Paris (France) + +- Delete `min` and use `<>` operator to compare length on `equal` function +- Implementation of `compare_{be,le}{,with_len}` function (@cfcs, @hannesm, @dinosaure) +- Test on `compare` function (@dinosaure) +- Unit test on `compare` (@dinosaure) +- Fuzz test on `compare` (@dinosaure) +- Documentation (@dinosaure, @cfcs) + +### v0.4 2019-05-24 Paris (France) + +- Distribution integrate an attack example +- Fuzzer to test `equal` function +- Unroll internal loop over 16 bits integers instead 32 bits +- Put x86 ASM output in implementation (and audit) +- Do second check even if first on fails (bad r²) +- Avoid indirection to `Pervasives` functions + +### v0.3 2019-05-02 Paris (France) + +- Provide `Eqaf_bigstring` +- Provide `Eqaf_cstruct` +- New check tool and delete any dependencies on `eqaf` package (@dinosaure, @hannesm, @cfcs) + +NOTE: This version is buggy, you MUST use v0.2 or v0.4 + +### v0.2 2018-10-15 Paris (France) + +* _Dunify_ project +* Update OPAM file +* Avoid `core_bench` dependency +* Make benchmark to test constant-time on `eqml` +* __Move `equal` function to the OCaml implementation__ (instead C implementation) +* Port benchmark on Windows and Mac OSX + +### v0.1 2018-08-31 Paris (France) + +* First release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..701e152 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2018 Romain Calascibetta + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..57caa0d --- /dev/null +++ b/README.md @@ -0,0 +1,204 @@ +# Eq(af) - Constant time equal function + +This library implements various *constant time* algorithms, +first and foremost the `Eqaf.equal` equality testing function for `string`. + +While the test suite has a number of external dependencies, the library itself +does not have any dependencies besides the OCaml standard library. +This should make `eqaf` small, self-contained, and easy to integrate in your +code. + +The "constant time" provided by this library is *constant* in the sense that +the time required to execute the functions does not depend on the *values* of +the operands. The purpose is to help programmer shield their code from +timing-based side-channel attacks where an adversary tries to measure execution +time to learn about the contents of the operands. They are *not* necessarily +"constant time" in the sense that each invocation takes exactly the same amount +of microseconds. + +Constant time implementations are beneficial in many different applications; +cryptographic libraries like [digestif](https://github.com/mirage/digestif), +but also practial code that deal with sensitive information (like passwords) +benefit from constant time execution in select situations. +A practical example of where this matters is the +[Lucky Thirteen attack](https://en.wikipedia.org/wiki/Lucky_Thirteen_attack) +against the TLS protocol, where a short-circuiting comparison compromised +the message encryption layer in many vulnerable implementations. + +You can generate and view the documentation in a browser with: +```shell +dune build @doc +xdg-open ./_build/default/_doc/_html/index.html +``` + +# Contents + +We found that we often had to duplicate the constant time `equal` function, and +to avoid replication of code and ensure maintainability of the implementation, +we decided to provide a little package which implements the `equal` +function on `string`. Since then, we have added a number of other useful +constant time implementations: + +- `compare_be` and `compare_le`: can be used to compare integers (or actual + strings) of any size in either big-endian or little-endian representation. + Regular string comparison (e.g. `String.compare`) is usually + *short-circuiting*, which results in an adversary being able to learn the + contents of compared strings by timing repeated executions. + If the lengths do not match, the semantics for `compare_be` follow those + of `String.compare`, and `compare_le` those of `String.compare (reverse str)`. + - The `compare_be_with_len` and `compare_le_with_len` are similar, + but does a constant time comparison of the lengths of the two + strings and the `~len` parameter. If the lengths do not match, + an exception is thrown (which leaks the fact that the lengths did not + match, but not the lengths or the contents of the input operands). + +- `exists_uint8 : ?off -> f:(int -> bool) -> string -> bool`: + implements the equivalent of `List.exists` on `string`, but executing in + constant time with respect to the contents of the string and `?off`. + The user provides a callback function that is given each byte as an integer, + and is responsible for ensuring this function also operates in constant time. + +- `find_uint8`: similar to `exists_uint8`, but implementing the + functionality of `List.find`: It returns the string index of the first match. + +- `divmod`: constant time division and modulo operations. + The execution time of both operations in normal implementations are + notoriously dependent on the operands. The `eqaf` implementation uses an + algorithm ported from `SUPERCOP`. + +- `ascii_of_int32 : digits:int -> int32 -> string`: + Turns the `int32` argument into a fixed-width (of length `= digits`) + left-padded string containing the decimal representation, + ex: `ascii_of_int32 ~digits:4 123l` is `"0123"`. + Usually programming languages provide similar functionality + (ex: `Int32.to_string`), but are vulnerable to timing attacks since they + rely on division. This implementation is similar, but uses `Eqaf.divmod` to + mitigate side channels. + +- `lowercase_ascii` and `uppercase_ascii` implement functionality equivalent to + the identically named functions in `Stdlib.String` module, but without + introducing a timing side channel. + +- `hex_of_string`: constant-time hex encoding. + Normally hex encoding is implemented with either a table lookup or + processor branches, both of which introduce side channels for an adversary to + learn about the contents of the string being encoded. + That can be a problem if an adversary can repeatedly trigger encoding of + sensitive values in your application and measure the response time. + +- `string_of_hex`: constant-time hex decoding. + Inverse of `hex_of_string`, but with support for decoding uppercase and + lowercase letters alike. + +This package, if `cstruct` or `base-bigarray` is available, will make this +`equal` function for them too (as `eqaf.cstruct` and `eqaf.bigarray`). + +A number of low-level primitives used by `Eqaf` are also exposed to enable you +to construct your own constant time implementations: + +- `zero_if_not_zero : int -> int`: + `(if n <> 0 then 0 else 1)`, or `!n` in the C programming language. +- `one_if_not_zero : int -> int`: + `(if n <> 0 then 1 else 0)`, or `!!n` in the C programming language. + - `bool_of_int : int -> bool`, like `one_if_not_zero` but cast to `bool` + - `int_of_bool : bool -> int`, inverse of `bool_of_int` +- `select_int : int -> int -> int -> int`: + `select_int choose_b a b` is a constant time utility for branching, + but always executing all the branches (to ensure constant time operation): + ```ocaml + let select_int choose_b a b = if choose_b = 0 then a else b + ``` +- `select_a_if_in_range : ~low:int -> ~high:int -> n:int -> int -> int -> int` + Similar to `select_int`, but checking for inclusion in a range rather than + testing for zero - a CT version of: + ```ocaml + let select_a_if_in_range ~low ~high ~n a b = + if low <= n && n <= high + then a + else b + ``` + +## Check tool + +To ensure correctness, `eqaf` ships with a test suite to measure the functions +and comparing results both to the `Stdlib` implementations and to executions of +the same function with similar length/size input. +The goal is to try to spot implementation weaknesses that rely on the *values* +of the function operands. + +The check tool will first attempt to calculate how many executions are +required to get statistically sound numbers (sorting out random jitter from +external factors like other programs executing on the computer). + +Then, using linear regression, we compare the results and verify that we did +not spot differences: the regression coefficient should be close to `0.0`. + +You can test `eqaf` with this: + +```sh +$ dune exec check/check.exe +``` + +### Q/A + +**Q** How to update `eqaf` implementation? + +**A** `eqaf` is fragile where the most important assumption is times needed to +compute `equal`. So `eqaf` provides the `check` tool but results from it can be +disturb by side-channel (like hypervisor). In a bare-metal environment, `check` +strictly works and should return `0`. + +**Q** `eqaf` is slower than `String.compare`, it's possible to optimize it? + +**A** The final goal of `eqaf` is to provide a _safe_ equal function. Speed is +clearly not what we want where we prefer to provide an implementation which does +not leak informations like: where is the first byte which differs between `a` +and `b`. + +**Q** Which attack `eqaf` prevents? + +**A** `eqaf` provide an equal function to avoid a timing attack. Most of equal +or compare functions (like `String.compare`) leave at the first byte which +differs. A possible attack is to see how long we need to compare two values, +like an user input and a password. + +Logically, the longer this time is, the more user input is the password. So when +we need to compare sensible values (like hashes), we should use something like +`eqaf`. The distribution provides an example of this attack: + +```sh +$ dune exec attack/attack.exe +Random: [|218;243;59;121;8;57;151;218;212;91;181;41;|]. +471cd8bc03992a31f8f0f0c55e9e477d +471cd8bc03992a31f8f0f0c55e9e477d +``` + +The first value is the hash, the second is what we found just by an +introspection of time needed by our `equal` function. + +**Q** `eqaf` provides only equal function on `string`? + +**A** The first implementation use `string`, then, we copy/paste the code with +`bigarray` and provide it only if `base-bigarray` is available. Finally, we +provide an `equal` function for `cstruct` only if this package is available. + +So, it's not only about `string` but for some others data-structures. + +**Q** Why we need to do a linear regression to check assumptions on `eqaf`? + +**A** As we said, times are noisy by several side-computation (hypervisor, +kernel, butterfly...). So, if we record two times how long we spend to compute +`equal`, we will have 2 different values - close each others but different. + +So we need to have a bunch of samples and do an analyze on them to get an +approximation. From that, we do 2 analyzes: +- get the approximation where we compare 2 same values +- get the approximation where we compare 2 different values + +From these results, we need to do an other analyze on these approximations to +see if they are close each others or not. In the case of `eqaf`, it should be +the case (and if it is, that means `eqaf` does not leak a time information +according inputs). In the case of `String.compare`, we should have a big +difference - and confirm expected behaviors. + +[digestif]: https://github.com/mirage/digestif.git diff --git a/attack/attack.ml b/attack/attack.ml new file mode 100644 index 0000000..cf8199a --- /dev/null +++ b/attack/attack.ml @@ -0,0 +1,79 @@ +open Microtime + +let cycles = 1000 +let length = 32 +let range = [| "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "a"; "b"; "c"; "d"; "e"; "f"; |] + +external random_seed : unit -> int array = "caml_sys_random_seed" + +let pp_int_array ppf arr = + Fmt.pf ppf "[|" ; + for i = 0 to pred (Array.length arr) do Fmt.pf ppf "%d;" arr.(i) done ; + Fmt.pf ppf "|]" + +let () = + let random_seed = random_seed () in + Fmt.pr "Random: %a.\n%!" pp_int_array random_seed ; + Random.full_init random_seed + +let random length = + let get _ = range.(Random.int (Array.length range)).[0] in + String.init length get + +exception Diff + +let equal a b = + let ln = (min : int -> int -> int) (String.length a) (String.length b) in + try + for i = 0 to pred ln do if not (Char.equal a.[i] b.[i]) then raise_notrace Diff ; Unix.sleepf 0.0001 done ; + String.length a = String.length b + with Diff -> false + +let stabilize_garbage_collector () = + let rec go limit last_heap_live_words = + if limit <= 0 then failwith "Unable to stabilize the number of live words in the heap" ; + Gc.compact () ; + let stat = Gc.stat () in + if stat.Gc.live_words <> last_heap_live_words + then go (pred limit) stat.Gc.live_words in + go 10 0 + +let compute a b = + let t0 = microtime () in + for _ = 0 to pred cycles do ignore (equal a b) done ; + let t1 = microtime () in + + t1 - t0 + +let rec run hash prefix = + let timers = Hashtbl.create cycles in + for i = 0 to pred (Array.length range) + do + let m = prefix ^ range.(i) in + stabilize_garbage_collector () ; + Gc.compact () ; + Gc.minor () ; + let r = Sys.opaque_identity (compute m hash) in + Hashtbl.add timers m r ; + done ; + + let results = Hashtbl.fold (fun k v a -> (k, v) :: a) timers [] in + let results = List.sort (fun (_, v0) (_, v1) -> (compare : int -> int -> int) v1 v0) results in + + match results with + | [] -> assert false + | (hit, _) :: _ -> + if String.length hit = length + then hit + else run hash hit + +let exit_success = 0 +let exit_failure = 1 + +let () = + let hash = random length in + print_endline hash ; + let cracked = run hash "" in + print_endline cracked ; + + if String.equal hash cracked then exit exit_success else exit exit_failure diff --git a/attack/dune b/attack/dune new file mode 100644 index 0000000..9753981 --- /dev/null +++ b/attack/dune @@ -0,0 +1,11 @@ +(library + (name microtime) + (modules microtime) + (foreign_stubs + (language c) + (names microtime))) + +(executable + (name attack) + (modules attack) + (libraries fmt unix microtime)) diff --git a/attack/microtime.c b/attack/microtime.c new file mode 100644 index 0000000..d269202 --- /dev/null +++ b/attack/microtime.c @@ -0,0 +1,41 @@ +/* Copyright (c) 2018 David Kaloper Meršinjak. All rights reserved. + See LICENSE.md */ + +#include + +#if defined (__x86_64__) +#define __x86__ + +#elif defined (__i686__) +#warning Unmark uses unboxed native ints for low-level counters. Proceed with extreme caution. +/* We can still do short benchmarks, tho. */ +#define __x86__ + +#endif + +#if defined (__x86__) +#include +#endif + +#include + +#define __unit value unit __attribute__((unused)) +#define nsec 1000000000 + +CAMLprim value caml_rdtsc (__unit) { +#if defined (__x86__) + return Val_long (__rdtsc ()); +#else +#warning Disabling RDTSC. + return Val_long (0); +#endif +} + +/* This will break on some, or all, of: Windows, macOS, Mirage. + * Please fill in the missing definitions. + */ +CAMLprim value caml_microtime (__unit) { + struct timespec ts; + clock_gettime (CLOCK_MONOTONIC, &ts); + return Val_long ((intnat) ts.tv_sec * nsec + (intnat) ts.tv_nsec); +} diff --git a/attack/microtime.ml b/attack/microtime.ml new file mode 100644 index 0000000..064af2c --- /dev/null +++ b/attack/microtime.ml @@ -0,0 +1 @@ +external microtime : unit -> int = "caml_microtime" [@@noalloc] diff --git a/check/README.md b/check/README.md new file mode 100644 index 0000000..71d6fdb --- /dev/null +++ b/check/README.md @@ -0,0 +1,127 @@ +# Check tool - a small benchmark tool + +`eqaf` comes with a small benchmark tool to record time/tick spend by our functions: +- `equal` +- `compare` +- `find_uint8` +- `exists_uint8` + +This README.md wants to explain into details this tool. + +## Some problems + +Try to record time spend is hard. Indeed, the operating system or, at least, the +CPU can disturb this specific sample. Of course, into a virtualized +operating-system, it's more difficult to rely on this sample. At least, +`check.exe` should be executed into a bare-metal operating system. + +By this fact, when we try to record time/tick, we have some noise. It's easily +understable by this simple code (assume a `Clock.now ()` function which gives +you the current time). + +```ocaml +let bench f = + let a = Clock.now () in + f () ; + let b = Clock.now () in + Format.printf "%Ld ns.\n%!" (Int64.sub b a) +``` + +If you run `bench` two times, results are surely differents. The difference is +small but enough to not be able to assert an equality. By this fact, try to +check a predicate such as the _constant-time_ of our function is not so easy +than that. + +**NOTE**: when we talk about _constant-time_, it's not an algorithmic +_constant-time_ as we can believe. Currently, our equal function respects 2 +predicates (and we will fold them into one term, _constant-time_): +- for 2 strings where lengths differs, `equal` must spend `B` ns where `B` is a + real constant +- for 2 strings where lengths are equal but contents __can__ differs (or not), + `equal` must spend `A * L + B` where `L` is a the length of input strings and + `A` and `B` are real constants. + +Then, the first predicate should be a subset of the second where `L = 0`. + +## Metrics + +Currently, `check` relies (when you compile it into a Linux operating-system) on +ticks with the _Time Stamp Counter_ instead to use `clock_gettime`. For MacOS or +Windows, we use `clock_gettime` or something equivalent. It's a special ASM +instruction. So, we possibly not handle your architecture. + +In fact, `RDTSC` is more reliable than `clock_gettime`. + +## Linear regresssion to infer `A * L + B` + +As we said, samples can be disturbed. So we are not able to just compare samples +and see that they are equal or not. We must infer our equation `A * L + B` (eg. +our _constant-time_ predicate). Our experience is done as follow: +1) we infer our equation `A1 * L + B1` when we compare 2 strictly equal strings +2) we infer our equation `A2 * L + B2` when we compare 2 strictly different +strings + +Even if a computation of `Eqaf.equal` will return expected result (see _fuzzer_ +and basic tests): +1) The function always returns `true` +2) The function always returns `false` + +We want to check that `A1 = A2` and `B1 = B2`, or, in other words, we infer the +same equation independently than inputs (different or not) - if we check that +time spent by `Eqaf.equal` does not depend on inputs. At the end, this check +means that `Eqaf.equal` does not leak any information by the _time side +channel_. + +To be able to infer our equation, we use a linear regression: 1) we follow a +sequence to execute our function `R0 = 1`, `Rn = max (R(n-1) * 1.01, R(n-1) + +1)` when `R` is how many times we execute our function and `n` is our iteration +Arbitrary, we do 750 iterations 2) For each iteration, we record our time metric +as follow: `samples.(n).(0) <- tick` `samples.(n).(1) <- R` 3) At the end, from +these samples, we can infer by a linear regression our equation. The resulted +coefficient of determination should be higher than 0.95. It tells to us that the +infered equation is good enough. + +## A counter example + +However, we should show a counter example of our results and we can do that with +`String.equal`. So we redo the experience with `String.equal` and we should have +an inequality betwen our equations. + +**NOTE**: If 2 strings are physically equal, `String.equal` does not introspect +contents and it returns directly `true`. So we ensure that strings can be equal +(and they are) but they are not physically equal. + +## Predictible results + +When we generate different strings, we do that randomly. The first diff +character can be at the beginning of the string or at the end. Because of that, +time spent by `String.equal` is not very predictable - it depends, as we want to +solve, from contents. By this way, `check.exe` use a constant seed to generate +strings to be more predictable about results. + +## How to compare our equations + +Come back earlier, we want to check that our first equation when inputs are +equal is the same than our equation when inputs are not equal. However, due to +our problems (noise on our samples), we can not strictly assert that they are +equal. However, we can infer the difference between them with 2 techniques: +1) CCEA technique +2) SPSS technique + +Both are explained into `check.ml` and they are not really formalized as we +expect. However, they give to us a way to compare our results. From them, it +comes a _coefficient_ which should be between `30.0` and `30.0`. Of course, this +segment is arbitrary but it's far from what we can get when we do the same +process with `String.equal`. + +So if we don't have a good _coefficient_ with the CCEA technique, we restart the +process with the SPSS technique as the final result. + +## Tries + +At the end, if we have a _good_ final coefficient, we can say that our function +respects our predicate. If the coefficient of the determination is not good +enough (`<= 0.95`), we restart the process. If we don't have a good final +_coefficient_, we restart the process. + +At least, we give 20 chances to our process to check our predicate. diff --git a/check/benchmark.ml b/check/benchmark.ml new file mode 100644 index 0000000..62b8114 --- /dev/null +++ b/check/benchmark.ml @@ -0,0 +1,63 @@ +type t = V : (unit -> 'a) -> t + +let stabilize_garbage_collector () = + let rec go limit last_heap_live_words = + if limit <= 0 then failwith "Unable to stabilize the number of live words in the heap" ; + Gc.compact () ; + let stat = Gc.stat () in + if stat.Gc.live_words <> last_heap_live_words + then go (pred limit) stat.Gc.live_words in + go 10 0 + +let runnable f i = + for _ = 1 to i do ignore @@ Sys.opaque_identity (f ()) done [@@inline] + +let tmp = Bytes.create 40 + +let reset () = Bytes.fill tmp 0 40 ' ' + +let print ppf (n, m) = + let l = n * 40 / m in + Bytes.fill tmp 0 l '#' ; + Fmt.pf ppf "[%s] %d%%%!" (Bytes.unsafe_to_string tmp) (n * 100 / m) + +let samples = 750 + +let run t = + let idx = ref 0 in + let run = ref 0 in + let (V fn) = t in + + let m = Array.create_float (samples * 2) in + + reset () ; + Fmt.pr "%a" print (0, samples) ; + + while !idx < samples do + let current_run = !run in + let current_idx = !idx in + + (* XXX(dinosaure): GC and prints can put noise on our samples. + - GC is not predictable + - prints can add a latency on I/O *) + (* Fmt.pr "\r%a" print (current_idx, samples) ; *) + (* if current_run = 0 then stabilize_garbage_collector () ; *) + + let time_0 = Clock.now () in + + runnable fn current_run ; + + let time_1 = Clock.now () in + + m.((current_idx * 2) + 0) <- float_of_int current_run ; + m.((current_idx * 2) + 1) <- Int64.to_float (Int64.sub time_1 time_0) ; + + let next = + (max : int -> int -> int) (int_of_float (float_of_int current_run *. 1.01)) (succ current_run) in + run := next ; incr idx + done ; + + Fmt.pr "\r%a\n%!" print (samples, samples) ; + + Array.init samples (fun i -> [| m.((i * 2) + 0); m.((i * 2) + 1) |]) + diff --git a/check/check.ml b/check/check.ml new file mode 100644 index 0000000..fd681c1 --- /dev/null +++ b/check/check.ml @@ -0,0 +1,477 @@ +let exit_success = 0 +let exit_failure = 1 + +external random_seed : unit -> int array = "caml_sys_random_seed" + +let pp_int_array ppf arr = + Fmt.pf ppf "[|" ; + for i = 0 to pred (Array.length arr) do Fmt.pf ppf "%d;" arr.(i) done ; + Fmt.pf ppf "|]" + + (* XXX(dinosaure): deterministic generation. + It appears that some calls of [check/check.exe] does not get same results, + mostly about [String.*] functions. As we understand implementation of them, + it's an expected behavior but it puts some noises when we try to introspect + results on different platforms. + + So all inputs are generated with this seed to be able to get as much as we + can reproducible outputs. *) +let seed = "4EygbdYh+v35vvrmD9YYP4byT5E3H7lTeXJiIj+dQnc=" +let seed = Base64.decode_exn seed +let seed = + let res = Array.make (String.length seed / 2) 0 in + for i = 0 to (String.length seed / 2) - 1 + do res.(i) <- (Char.code seed.[i * 2] lsl 8) lor (Char.code seed.[i * 2 + 1]) done ; + res + +let () = + let random_seed = seed in + Fmt.pr "Random: %a.\n%!" pp_int_array random_seed ; + Random.full_init random_seed + +let random length = + let get _ = + match Random.int (10 + 26 + 26) with + | n when n < 10 -> Char.(chr (code '0' + n)) + | n when n < 10 + 26 -> Char.(chr (code 'a' + n - 10)) + | n -> Char.(chr (code 'A' + n - 10 - 26)) in + String.init length get + +let hash_eq_0 = random 4096 +let hash_eq_1 = Bytes.to_string (Bytes.of_string hash_eq_0) +let chr_into_hash_eq_0 = hash_eq_0.[Random.int 4096] +let int32_into_hash_eq_0 = + Unsafe.get_int32_ne (Bytes.of_string hash_eq_0) (Random.int (4096-4)) +let int32_into_hash_eq_1 = + Unsafe.get_int32_ne (Bytes.of_string hash_eq_1) (Random.int (4096-4)) +let int14_into_hash_eq_0 = + Unsafe.get_int32_ne (Bytes.of_string hash_eq_0) (Random.int (4096-4)) + |> (Int32.logand 0xfffl) +let int14_into_hash_eq_1 = + Unsafe.get_int32_ne (Bytes.of_string hash_eq_1) (Random.int (4096-4)) + |> (Int32.logand 0xfffl) + +let () = assert (hash_eq_0 != hash_eq_1) +let () = assert (hash_eq_0 = hash_eq_1) +let () = assert (String.contains hash_eq_0 chr_into_hash_eq_0) + +let hash_neq_0 = random 4096 +let hash_neq_1 = + let rec go limit = + if limit <= 0 then failwith "Impossible to generate different hashes." ; + let res = random 4096 in + if res = hash_neq_0 then go (pred limit) else res in + go 10 +let random_chr = + let rec go limit = + if limit <= 0 then failwith "Impossible to generate a byte which does not appear into hash_neq_0." ; + let res = Char.chr (Random.int 256) in + if not (String.contains hash_neq_0 res) then res else go (pred limit) in + go 10 + +let () = assert (hash_neq_0 <> hash_neq_1) +let () = assert (not (String.contains hash_neq_0 random_chr)) + +let error_msgf fmt = Fmt.kstrf (fun err -> Error (`Msg err)) fmt + +let merge m0 m1 = + let cons_0 r = [| 0.; r.(0); r.(1) |] in + let cons_1 r = [| 1.; r.(0); r.(1) |] in + Array.(append (map cons_0 m0) (map cons_1 m1)) + +let test_spss fn_0 fn_1 = + Fmt.pr "> Start benchmarks on [fn⁰].\n%!" ; + let m0 = Benchmark.run fn_0 in + Fmt.pr "> Start benchmarks on [fn¹].\n%!" ; + let m1 = Benchmark.run fn_1 in + Fmt.pr "> Merge results.\n%!" ; + let m = merge m0 m1 in + let m = Array.map (fun r -> [| r.(0); r.(1); r.(2); r.(0) *. r.(1) |]) m in + Fmt.pr "> Start linear regression.\n%!" ; + match Linear_algebra.ols + (fun m -> m.(2)) + [|(fun m -> m.(0)); (fun m -> m.(1)); (fun m -> m.(3))|] + m with + | Ok (estimates, r_square) -> + if r_square >= 0.95 then Ok estimates + else error_msgf "r² (%f) is bad" r_square + | Error (`Msg _) as err -> err + +let test_ccea fn_0 fn_1 = + Fmt.pr "> Start benchmarks on [fn⁰].\n%!" ; + let m0 = Benchmark.run fn_0 in + Fmt.pr "> Start benchmarks on [fn¹].\n%!" ; + let m1 = Benchmark.run fn_1 in + match Linear_algebra.ols (fun m -> m.(1)) [|(fun m -> m.(0))|] m0, + Linear_algebra.ols (fun m -> m.(1)) [|(fun m -> m.(0))|] m1 with + | Ok (estimates_0, r_square_0), + Ok (estimates_1, r_square_1) -> + Fmt.epr "> Calculating Z.\n%!" ; + let z = (estimates_0.(0) -. estimates_1.(0)) /. sqrt ((r_square_0 ** 2.) +. (r_square_1 ** 2.)) in + Ok z + | (Error (`Msg _) as err), Ok _ -> err + | Ok _, (Error (`Msg _) as err) -> err + | Error (`Msg err0), Error (`Msg err1) -> + Fmt.epr "Got errors for while processing both.\n%!" ; + Fmt.epr "B¹: %s.\n%!" err0 ; + Fmt.epr "B²: %s.\n%!" err1 ; + exit exit_failure + +let ccea ~reset ~switch ~name_of_fns_0 ~name_of_fns_1 fns_0 fns_1 = + Fmt.pr "> Start to test %s (B¹).\n%!" name_of_fns_0 ; + reset () ; + let eqaf = test_ccea (fst fns_0) (snd fns_0) in + switch () ; + Fmt.pr "> Start to test %s (B²).\n%!" name_of_fns_1 ; + let stdlib = test_ccea (fst fns_1) (snd fns_1) in + match eqaf, stdlib with + | Ok eqaf, Ok stdlib -> + Ok (eqaf, stdlib) + | Error (`Msg err), Ok _ -> + Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_0 err ; + Error () + | Ok _, Error (`Msg err) -> + Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_1 err ; + Error () + | Error (`Msg err0), Error (`Msg err1) -> + Fmt.epr "Got errors while processing both:\n%!" ; + Fmt.epr "B¹> %s.\n%!" err0 ; + Fmt.epr "B²> %s.\n%!" err1 ; + Error () + +let spss ~reset ~switch ~name_of_fns_0 ~name_of_fns_1 fns_0 fns_1 = + Fmt.pr "> Start to test %s (B¹).\n%!" name_of_fns_0 ; + reset () ; + let eqaf = test_spss (fst fns_0) (snd fns_0) in + switch () ; + Fmt.pr "> Start to test %s (B²).\n%!" name_of_fns_1 ; + let stdlib = test_spss (fst fns_1) (snd fns_1) in + + match eqaf, stdlib with + | Ok eqaf, Ok stdlib -> + Fmt.pr "%s: %f ns/run.\n%!" name_of_fns_0 eqaf.(1) ; + Fmt.pr "%s: %f ns/run.\n%!" name_of_fns_1 stdlib.(1) ; + Ok (eqaf.(2), stdlib.(2)) + | Error (`Msg err), Ok _ -> + Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_0 err ; + Error () + | Ok _, Error (`Msg err) -> + Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_1 err ; + Error () + | Error (`Msg err0), Error (`Msg err1) -> + Fmt.epr "Got errors while processing both:\n%!" ; + Fmt.epr "B¹> %s.\n%!" err0 ; + Fmt.epr "B²> %s.\n%!" err1 ; + Error () + +(* XXX(dinosaure): this program try to compute diff between 2 coefficient + regressions: + + - 1: time needed to compute equal function on 2 same values ([_eq]) + - 2: time needed to compute equal function on 2 different values ([_neq]) + + ### Samples + + We have 2 ways to compute it. The first is to compute a regression equation + which includes group 1 and group 2. A initial regression equation can be done + to know how long [equal] lasts: + + regression + /dep time // m.(1) + /method = enter run // m.(0) + + It's a basic linear regression where we run 1..N times the function with same + inputs. Then, we have a matrix such as: + + m.(n).(0) <- time + m.(n).(1) <- run + + Obviously, if our function is /constant-time/, you should have something like: + + y = m.(x).(0) = a * m.(x).(1) + b + + To infer the curve, we use the linear regression for each points. Then, we + collect same samples but with [_neq] values. Now, the goal is to see that + [_eq]: y = a * x + b and [_neq]: y = a * x + b are ~ equals. For that, we have + 2 ways. + + ### SPSS + + The first way to compare group 1 ([_eq]) and group 2 ([_neq]): we need to + insert a dummy variable [kind] where it is equal to [0.0] when it's owned by + the group 1 and [1.1] is owned by the group 2 (see [cons_*] function). + Finally, we had a new variable which is the product between [kind] ([m.(0)]) + and [run] ([m.(1)]). + + Finally, we can start to compute a regression equation where [time] will be + the responder and [kind], [run] and [kind * run] will be predictors: + + regression + /dep time // m.(2) + /method = enter kind run (kind * run) // m.(0) m.(1) m.(3) + + Time of [equal] will be available on [estimates.(1)] and diff will be + available on [estimates.(2)]. [compare_spss] checks r² ([>= 0.95]) and + main program checks if the diff is between [-30.0] and [30.0]. + + ### CCEA + + The second way to compare group 1 and group 2: it consists to compute basic + regression equation to know how long [equal] lasts. Then, we will compute [Z] + which is equal to: + + B¹-B² + --------------- + sqrt(r¹² + r²²) + + Where B¹ and B² are regression coefficients for [_eq] and [_neq] and r¹ and r² + are standard error of B¹ and B². Then, main program, as the first way, checks + if [Z] is between [-30.0] and [30.0]. + + NOTE about SPSS: + + This is the name of a software which explain how to compare results of linear + regression. + + NOTE about CCEA: + + I don't remmember when I got this name but it seems close to Vuong test. + + NOTE about virtualization: + + Virtual context (VirtualBox, VMWare, Xen or qemu) can delayed CPU instructions + and tricks on the time spended to execute them. By this fact, time counter lies + about time needed to compute [equal] function. So, in a virtual context we can + have some noises when we record measures (in [Benchmark]). + + NOTE about bare-metal: + + In a bare-metal context, results are more determinists (but they are not + completely fixed). In fact, it depends on the system-scheduler which can + prioritize an other process while [check/check.exe] is executed. For all of + these reasons, [check/check.exe] is really fragile and can not work in + your context - however, a CI with [eqaf] is provided is we surely are aware + of it and results. *) + +module Make (Check : sig + type ret + + val eqaf_name : string + val stdlib_name : string + + val reset : unit -> unit + val switch : unit -> unit + + val eqaf_true : unit -> ret + val eqaf_false : unit -> ret + + val stdlib_true : unit -> ret + val stdlib_false : unit -> ret + end) = struct + open Check + + let last_chance () = + let open Benchmark in + match ccea + ~reset:Check.reset ~switch:Check.switch + ~name_of_fns_0:eqaf_name + ~name_of_fns_1:stdlib_name + (V eqaf_true, V eqaf_false) + (V stdlib_true, V stdlib_false) with + | Error () -> exit_failure + | Ok (eqaf, stdlib) -> + if eqaf >= -30. && eqaf <= 30. + then ( Fmt.pr "Z¹ = %f, Z² = %f.\n%!" eqaf stdlib ; exit_success ) + else ( Fmt.pr "Z¹ = %f, Z² = %f.\n%!" eqaf stdlib ; exit_failure ) + + let test () = + let open Benchmark in + match spss + ~reset:Check.reset ~switch:Check.switch + ~name_of_fns_0:eqaf_name + ~name_of_fns_1:stdlib_name + (V eqaf_true, V eqaf_false) + (V stdlib_true, V stdlib_false) with + | Error () -> last_chance () + | Ok (eqaf, stdlib) -> + if eqaf >= -30. && eqaf <= 30. + then ( Fmt.pr "B¹ = %f, B² = %f.\n%!" eqaf stdlib ; exit_success ) + else + ( Fmt.pr "Fail with B¹ = %f, B² = %f.\n%!" eqaf stdlib ; + Fmt.pr "> Start to compute Z.\n%!" ; + last_chance () ) +end + +module Equal = Make(struct + type ret = bool + + let eqaf_name = "Eqaf.equal" + let stdlib_name = "String.equal" + + let reset = ignore and switch = ignore + + let stdlib_true () = String.equal hash_eq_0 hash_eq_1 + let stdlib_false () = String.equal hash_neq_0 hash_neq_1 + + let eqaf_true () = Eqaf.equal hash_eq_0 hash_eq_1 + let eqaf_false () = Eqaf.equal hash_neq_0 hash_neq_1 +end) + +module Compare = Make(struct + type ret = int + + let eqaf_name = "Eqaf.compare" + let stdlib_name = "String.compare" + + let reset = ignore and switch = ignore + + let stdlib_true () = String.compare hash_eq_0 hash_eq_1 + let stdlib_false () = String.compare hash_neq_0 hash_neq_1 + + let eqaf_true () = Eqaf.compare_be hash_eq_0 hash_eq_1 + let eqaf_false () = Eqaf.compare_be hash_neq_0 hash_neq_1 +end) + +module Exists = Make(struct + type ret = bool + + let eqaf_name = "Eqaf.exists_uint8" + let stdlib_name = "String.contains" + + let constant = ref (Char.code chr_into_hash_eq_0) + let reset () = constant := Char.code chr_into_hash_eq_0 + let switch () = constant := Char.code random_chr + + let stdlib_true () = String.contains hash_eq_0 chr_into_hash_eq_0 + let stdlib_false () = String.contains hash_neq_0 random_chr + + let f (v : int) = v = !constant + let eqaf_true () = Eqaf.exists_uint8 ~f hash_eq_0 + let eqaf_false () = Eqaf.exists_uint8 ~f hash_neq_0 +end) + +module Find = Make(struct + type ret = int + + let eqaf_name = "Eqaf.find_uint8" + let stdlib_name = "String.index" + + let switch () = () + let reset () = () + + let stdlib_true () = String.index hash_eq_0 chr_into_hash_eq_0 + let stdlib_false () = try String.index hash_neq_0 random_chr with Not_found -> (-1) + + let f_hash_eq_0 (v : int) = v = Char.code chr_into_hash_eq_0 + let f_random (v : int) = v = Char.code random_chr + let eqaf_true () = Eqaf.find_uint8 ~f:f_hash_eq_0 hash_eq_0 + let eqaf_false () = Eqaf.find_uint8 ~f:f_random hash_neq_0 +end) + +module Divmod32 = Make(struct + type ret = int32 * int32 + + let eqaf_name = "Eqaf.divmod" + let stdlib_name = "Int32.unsigned_div,Int32.unsigned_rem" + + + let switch () = () + let reset () = () + + (* These are here for compat with OCaml <= 4.09 + from >= they can be replaced by + Int32.unsigned_div + Int32.unsigned_rem + *) + let int32_div_unsigned n d = + let sub,min_int = Int32.(sub,min_int)in + let int32_unsigned_compare n m = + Int32.compare (sub n min_int) (sub m min_int) + in + if d < 0_l then + if int32_unsigned_compare n d < 0 then 0_l else 1_l + else + let q = + let open Int32 in + shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in + let r = sub n (Int32.mul q d) in + if int32_unsigned_compare r d >= 0 then Int32.succ q else q + let int32_rem_unsigned n d = + Int32.sub n (Int32.mul (int32_div_unsigned n d) d) + + (* TODO *) + let stdlib_true () = + let x, m = int32_into_hash_eq_0, int14_into_hash_eq_0 in + int32_div_unsigned x m, + int32_rem_unsigned x m + let stdlib_false () = + let x, m = int32_into_hash_eq_1, int14_into_hash_eq_1 in + int32_div_unsigned x m, + int32_rem_unsigned x m + + let eqaf_true () = + Eqaf.divmod ~x:int32_into_hash_eq_0 ~m:int14_into_hash_eq_0 + let eqaf_false () = + Eqaf.divmod ~x:int32_into_hash_eq_1 ~m:int14_into_hash_eq_1 +end) + +module Ascii_int32 = Make(struct + type ret = string + + let eqaf_name = "Eqaf.ascii_of_int32" + let stdlib_name = "Int32.to_string" + + + let switch () = () + let reset () = () + + (* TODO setting 0x8000 bit ensures five digits. + We need a constant amount of digits to specify ~digits because + we don't have a [Int32.to_string] that left-pads. + Maybe we can use [Format.sprintf] ? + *) + let true_int = Int32.logand 0x8000l int14_into_hash_eq_0 + let false_int = Int32.logand 0x8000l int14_into_hash_eq_1 + let stdlib_true () = Int32.to_string true_int + let stdlib_false () = Int32.to_string false_int + + let eqaf_true () = Eqaf.ascii_of_int32 ~digits:5 true_int + let eqaf_false () = Eqaf.ascii_of_int32 ~digits:5 false_int +end) + +let limit = 20 + +let () = + let rec _0 tried = + if tried > 20 then invalid_arg "Too many tried for Eqaf.equal" ; + let res = Equal.test () in + if res = exit_success then tried else _0 (succ tried) in + let rec _1 tried = + if tried > 20 then invalid_arg "Too many tried for Eqaf.compare" ; + let res = Compare.test () in + if res = exit_success then tried else _1 (succ tried) in + let rec _2 tried = + if tried > 20 then invalid_arg "Too many tried for Eqaf.exists" ; + let res = Exists.test () in + if res = exit_success then tried else _2 (succ tried) in + let rec _3 tried = + if tried > 20 then invalid_arg "Too many tried for Eqaf.find_uint8" ; + let res = Find.test () in + if res = exit_success then tried else _3 (succ tried) in + let rec _4 tried = + if tried > 20 then invalid_arg "Too many tried for Eqaf.divmod" ; + let res = Divmod32.test () in + if res = exit_success then tried else _4 (succ tried) in + + let _0 = _0 1 in + Fmt.pr "%d trial(s) for Eqaf.equal.\n%!" _0 ; + let _1 = _1 1 in + Fmt.pr "%d trial(s) for Eqaf.compare.\n%!" _1 ; + let _2 = _2 1 in + Fmt.pr "%d trial(s) for Eqaf.exists.\n%!" _2 ; + let _3 = _3 1 in + Fmt.pr "%d trial(s) for Eqaf.find_uint8.\n%!" _3 ; + let _4 = _4 1 in + Fmt.pr "%d trial(s) for Eqaf.divmod.\n%!" _3 ; + + exit exit_success diff --git a/check/dune b/check/dune new file mode 100644 index 0000000..81d7c33 --- /dev/null +++ b/check/dune @@ -0,0 +1,15 @@ +(executable + (name check) + (modules check linear_algebra benchmark fmt unsafe) + (libraries eqaf base64 clock)) + +(rule + (copy %{read:../config/which-unsafe-file} unsafe.ml)) + +(rule + (alias runbench) + (package eqaf) + (deps + (:check check.exe)) + (action + (run %{check}))) diff --git a/check/fmt.ml b/check/fmt.ml new file mode 100644 index 0000000..19be10d --- /dev/null +++ b/check/fmt.ml @@ -0,0 +1,4 @@ +let pr fmt = Format.printf fmt +let epr fmt = Format.eprintf fmt +let pf ppf fmt = Format.fprintf ppf fmt +let kstrf k fmt = Format.kasprintf k fmt diff --git a/check/linear_algebra.ml b/check/linear_algebra.ml new file mode 100644 index 0000000..db27391 --- /dev/null +++ b/check/linear_algebra.ml @@ -0,0 +1,129 @@ +(* Code under Apache License 2.0 - Jane Street Group, LLC *) + +let col_norm a column = + let acc = ref 0. in + for i = 0 to Array.length a - 1 do + let entry = a.(i).(column) in + acc := !acc +. (entry *. entry) + done ; + sqrt !acc + +let col_inner_prod t j1 j2 = + let acc = ref 0. in + for i = 0 to Array.length t - 1 do + acc := !acc +. (t.(i).(j1) *. t.(i).(j2)) + done ; + !acc + +let qr_in_place a = + let m = Array.length a in + if m = 0 then ([||], [||]) + else + let n = Array.length a.(0) in + let r = Array.make_matrix n n 0. in + for j = 0 to n - 1 do + let alpha = col_norm a j in + r.(j).(j) <- alpha ; + let one_over_alpha = 1. /. alpha in + for i = 0 to m - 1 do + a.(i).(j) <- a.(i).(j) *. one_over_alpha + done ; + for j2 = j + 1 to n - 1 do + let c = col_inner_prod a j j2 in + r.(j).(j2) <- c ; + for i = 0 to m - 1 do + a.(i).(j2) <- a.(i).(j2) -. (c *. a.(i).(j)) + done + done + done ; + (a, r) + +let qr ?(in_place = false) a = + let a = if in_place then a else Array.map Array.copy a in + qr_in_place a + +let mul_mv ?(trans = false) a x = + let rows = Array.length a in + if rows = 0 then [||] + else + let cols = Array.length a.(0) in + let m, n, get = + if trans then + let get i j = a.(j).(i) in + (cols, rows, get) + else + let get i j = a.(i).(j) in + (rows, cols, get) + in + if n <> Array.length x then failwith "Dimension mismatch" ; + let result = Array.make m 0. in + for i = 0 to m - 1 do + let v, _ = + Array.fold_left + (fun (acc, j) x -> (acc +. (get i j *. x), succ j)) + (0., 0) x + in + result.(i) <- v + done ; + result + +let is_nan v = match classify_float v with FP_nan -> true | _ -> false + let error_msg msg = Error (`Msg msg) + +let triu_solve r b = + let m = Array.length b in + if m <> Array.length r then + error_msg + "triu_solve R b requires R to be square with same number of rows as b" + else if m = 0 then Ok [||] + else if m <> Array.length r.(0) then + error_msg "triu_solve R b requires R to be a square" + else + let sol = Array.copy b in + for i = m - 1 downto 0 do + sol.(i) <- sol.(i) /. r.(i).(i) ; + for j = 0 to i - 1 do + sol.(j) <- sol.(j) -. (r.(j).(i) *. sol.(i)) + done + done ; + if Array.exists is_nan sol then + error_msg "triu_solve detected NaN result" + else Ok sol + +let ols ?(in_place = false) a b = + let q, r = qr ~in_place a in + triu_solve r (mul_mv ~trans:true q b) + +let make_lr_inputs responder predictors m = + Array.init (Array.length m) (fun i -> Array.map (fun a -> a m.(i)) predictors), + Array.init (Array.length m) (fun i -> responder m.(i)) + +let r_square m responder predictors r = + let predictors_matrix, responder_vector = + make_lr_inputs responder predictors m + in + let sum_responder = Array.fold_left ( +. ) 0. responder_vector in + let mean = sum_responder /. float (Array.length responder_vector) in + let tot_ss = ref 0. in + let res_ss = ref 0. in + let predicted i = + let x = ref 0. in + for j = 0 to Array.length r - 1 do + x := !x +. (predictors_matrix.(i).(j) *. r.(j)) + done ; + !x + in + for i = 0 to Array.length responder_vector - 1 do + tot_ss := !tot_ss +. ((responder_vector.(i) -. mean) ** 2.) ; + res_ss := !res_ss +. ((responder_vector.(i) -. predicted i) ** 2.) + done ; + 1. -. (!res_ss /. !tot_ss) + +let ols responder predictors m = + let matrix, vector = make_lr_inputs responder predictors m in + match ols ~in_place:true matrix vector with + | Ok estimates -> + let r_square = r_square m responder predictors estimates in + Ok (estimates, r_square) + | Error _ as err -> err + diff --git a/check/unsafe_pre407.ml b/check/unsafe_pre407.ml new file mode 100644 index 0000000..7671f40 --- /dev/null +++ b/check/unsafe_pre407.ml @@ -0,0 +1 @@ +external get_int32_ne : bytes -> int -> int32 = "%caml_string_get32" diff --git a/check/unsafe_pre408.ml b/check/unsafe_pre408.ml new file mode 100644 index 0000000..512bf4d --- /dev/null +++ b/check/unsafe_pre408.ml @@ -0,0 +1 @@ +external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32" diff --git a/check/unsafe_stable.ml b/check/unsafe_stable.ml new file mode 100644 index 0000000..ad02bf7 --- /dev/null +++ b/check/unsafe_stable.ml @@ -0,0 +1 @@ +let get_int32_ne b i = Bytes.get_int32_ne b i diff --git a/clock/clock_linux.ml b/clock/clock_linux.ml new file mode 100644 index 0000000..50daeae --- /dev/null +++ b/clock/clock_linux.ml @@ -0,0 +1,6 @@ +external clock_linux_get_time + : unit -> (int64[@unboxed]) + = "clock_linux_get_time_byte" "clock_linux_get_time_native" +[@@noalloc] + +let now () = clock_linux_get_time () diff --git a/clock/clock_linux_stubs.c b/clock/clock_linux_stubs.c new file mode 100644 index 0000000..479275e --- /dev/null +++ b/clock/clock_linux_stubs.c @@ -0,0 +1,55 @@ +#include +#include +#include +#include +#include + +#include +#include +#include +#include + +#ifndef __unused +#define __unused(x) x __attribute((unused)) +#endif +#define __unit() value __unused(unit) + +CAMLprim value +clock_linux_get_time_byte(__unit ()) +{ + struct timespec ts; + + if (clock_gettime(CLOCK_MONOTONIC, &ts)) + caml_invalid_argument("clock: unsupported clock"); + + return copy_int64(ts.tv_sec * 1000000000LL + ts.tv_nsec); +} + +// XXX(dinosaure): commented because to be able to compile the test into any +// platform (ARM) +// +// uint64_t +// clock_linux_get_tick(__unit ()) +// { +// // struct timespec ts; +// unsigned hi, lo; +// __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); +// +// // XXX(dinosaure): [clock_gettime] costs a lot and are +// // not really precise. [rdtsc] (Read Time Stamp Counter) +// // is more reliable. +// +// return (((unsigned long long) lo) | (((unsigned long long) hi) << 32)); +// } + +uint64_t +clock_linux_get_time_native(__unit ()) +{ + struct timespec ts; + + (void) clock_gettime(CLOCK_MONOTONIC, &ts); + // XXX(dinosaure): assume that it will never fail. + // [caml_invalid_argument] allocs. + + return (ts.tv_sec * 1000000000LL + ts.tv_nsec); +} diff --git a/clock/clock_mach.ml b/clock/clock_mach.ml new file mode 100644 index 0000000..c867301 --- /dev/null +++ b/clock/clock_mach.ml @@ -0,0 +1,5 @@ +external clock_mach_init : unit -> unit = "clock_mach_init" +external clock_mach_get_time : unit -> int64 = "clock_mach_get_time" + +let () = clock_mach_init () +let now () = clock_mach_get_time () diff --git a/clock/clock_mach_stubs.c b/clock/clock_mach_stubs.c new file mode 100644 index 0000000..245697f --- /dev/null +++ b/clock/clock_mach_stubs.c @@ -0,0 +1,35 @@ +#ifdef __MACH__ +#include +#include +#include +#endif + +#include +#include +#include +#include + +// (c) Daniel Bünzli + +static mach_timebase_info_data_t s = { 0 }; + +CAMLprim value +clock_mach_init(value unit) +{ + if (mach_timebase_info (&s) != KERN_SUCCESS) + caml_raise_sys_error (caml_copy_string("clock_mach_init: mach_timebase_info () failed")); + if (s.denom == 0) + caml_raise_sys_error (caml_copy_string("clock_mach_init: mach_timebase_info_data.denom is 0")); + + return Val_unit; +} + +CAMLprim value +clock_mach_get_time(value unit) +{ + uint64_t now; + + now = mach_absolute_time(); + + return copy_int64(now * s.numer / s.denom); +} diff --git a/clock/clock_windows.ml b/clock/clock_windows.ml new file mode 100644 index 0000000..d5162e0 --- /dev/null +++ b/clock/clock_windows.ml @@ -0,0 +1,5 @@ +external clock_windows_get_time : unit -> int64 = "clock_windows_get_time" +external clock_windows_init : unit -> unit = "clock_windows_init" + +let () = clock_windows_init () +let now () = clock_windows_get_time () diff --git a/clock/clock_windows_stubs.c b/clock/clock_windows_stubs.c new file mode 100644 index 0000000..9784b93 --- /dev/null +++ b/clock/clock_windows_stubs.c @@ -0,0 +1,30 @@ +#include +#include +#include + +#include + +static LARGE_INTEGER frequency; + +CAMLprim value +clock_windows_init(value unit) +{ + QueryPerformanceFrequency(&frequency); + frequency.QuadPart = 1000000000L / frequency.QuadPart; + + return Val_unit; +} + +CAMLprim value +clock_windows_get_time(value unit) +{ + CAMLparam0(); + CAMLlocal1(res); + LARGE_INTEGER now; + + QueryPerformanceCounter(&now); + + res = copy_int64(now.QuadPart * frequency.QuadPart); + + CAMLreturn(res); +} diff --git a/clock/dune b/clock/dune new file mode 100644 index 0000000..488d129 --- /dev/null +++ b/clock/dune @@ -0,0 +1,21 @@ +(rule + (targets clock.ml clock_stubs.c clock.sexp) + (deps + (:select select/select.ml) + clock_linux.ml + clock_linux_stubs.c + clock_windows.ml + clock_windows_stubs.c + clock_mach.ml + clock_mach_stubs.c) + (action + (run %{ocaml} %{select} --system %{ocaml-config:system} -o clock))) + +(library + (name clock) + (modules clock) + (foreign_stubs + (language c) + (names clock_stubs) + (flags + (:include clock.sexp)))) diff --git a/clock/select/select.ml b/clock/select/select.ml new file mode 100644 index 0000000..78b45cf --- /dev/null +++ b/clock/select/select.ml @@ -0,0 +1,65 @@ +let invalid_arg fmt = Format.ksprintf (fun s -> invalid_arg s) fmt + +let load_file filename = + let ic = open_in_bin filename in + let ln = in_channel_length ic in + let rs = Bytes.create ln in + let () = really_input ic rs 0 ln in + Bytes.unsafe_to_string rs + +let sexp_linux = "(-lrt)" + +let sexp_freebsd = "()" + +let sexp_windows = "()" + +let sexp_mach = "()" + +let () = + let system, output = + try + match Sys.argv with + | [|_; "--system"; system; "-o"; output|] -> + let system = + match system with + | "linux" | "elf" -> `Linux + | "windows" | "mingw64" | "mingw" | "cygwin" -> `Windows + | "freebsd" -> `FreeBSD + | "macosx" -> `MacOSX + | v -> + if String.sub system 0 5 = "linux" + then `Linux + else invalid_arg "Invalid argument of system option: %s" v + in + (system, output) + | _ -> invalid_arg "%s --system system -o " Sys.argv.(0) + with _ -> invalid_arg "%s --system system -o " Sys.argv.(0) + in + let oc_ml, oc_c, oc_sexp = + ( open_out (output ^ ".ml") + , open_out (output ^ "_stubs.c") + , open_out (output ^ ".sexp") ) + in + let ml, c, sexp = + match system with + | `Linux -> + ( load_file "clock_linux.ml" + , load_file "clock_linux_stubs.c" + , sexp_linux ) + | `FreeBSD -> + ( load_file "clock_linux.ml" + , load_file "clock_linux_stubs.c" + , sexp_freebsd ) + | `Windows -> + ( load_file "clock_windows.ml" + , load_file "clock_windows_stubs.c" + , sexp_windows ) + | `MacOSX -> + (load_file "clock_mach.ml", load_file "clock_mach_stubs.c", sexp_mach) + in + Printf.fprintf oc_ml "%s%!" ml ; + Printf.fprintf oc_c "%s%!" c ; + Printf.fprintf oc_sexp "%s%!" sexp ; + close_out oc_ml ; + close_out oc_c ; + close_out oc_sexp diff --git a/config/config.ml b/config/config.ml new file mode 100644 index 0000000..2133f92 --- /dev/null +++ b/config/config.ml @@ -0,0 +1,10 @@ +let parse s = Scanf.sscanf s "%d.%d" (fun major minor -> (major, minor)) + +let () = + let version = parse Sys.ocaml_version in + if version >= (4, 8) + then print_string "unsafe_stable.ml" + else if version >= (4, 7) + then print_string "unsafe_pre408.ml" + else print_string "unsafe_pre407.ml" + diff --git a/config/dune b/config/dune new file mode 100644 index 0000000..4c30024 --- /dev/null +++ b/config/dune @@ -0,0 +1,7 @@ +(executable + (name config)) + +(rule + (with-stdout-to + which-unsafe-file + (run ./config.exe))) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..8c97908 --- /dev/null +++ b/dune-project @@ -0,0 +1,3 @@ +(lang dune 2.0) +(name eqaf) +(version v0.8) diff --git a/eqaf.opam b/eqaf.opam new file mode 100644 index 0000000..1db0219 --- /dev/null +++ b/eqaf.opam @@ -0,0 +1,28 @@ +version: "0.8" +opam-version: "2.0" +maintainer: [ "Romain Calascibetta " ] +authors: [ "Romain Calascibetta " ] +homepage: "https://github.com/mirage/eqaf" +bug-reports: "https://github.com/mirage/eqaf/issues" +dev-repo: "git+https://github.com/mirage/eqaf.git" +doc: "https://mirage.github.io/eqaf/" +license: "MIT" +synopsis: "Constant-time equal function on string" +description: """ +This package provides an equal function on string in constant-time to avoid timing-attack with crypto stuff. +""" + +build: [ + [ "dune" "subst" ] {dev} + [ "dune" "build" "-p" name "-j" jobs ] + [ "dune" "runtest" "-p" name "-j" "1" "--no-buffer" "--verbose" ] {with-test} +] + +depends: [ + "ocaml" {>= "4.07.0"} + "dune" {>= "2.0"} + "cstruct" {>= "1.1.0"} + "base64" {with-test} + "alcotest" {with-test} + "crowbar" {with-test} +] \ No newline at end of file diff --git a/fuzz/dune b/fuzz/dune new file mode 100644 index 0000000..99991f1 --- /dev/null +++ b/fuzz/dune @@ -0,0 +1,11 @@ +(executable + (name fuzz) + (libraries crowbar eqaf)) + +(rule + (alias runtest) + (package eqaf) + (deps + (:fuzz fuzz.exe)) + (action + (run %{fuzz}))) diff --git a/fuzz/fuzz.ml b/fuzz/fuzz.ml new file mode 100644 index 0000000..42dabe9 --- /dev/null +++ b/fuzz/fuzz.ml @@ -0,0 +1,133 @@ +open Crowbar + +let () = + add_test ~name:"bool_of_int" [ int ] + @@ fun n -> + let result = Eqaf.bool_of_int n in + check_eq ~eq:(=) (if n = 0 then false else true) result + +let () = + add_test ~name:"select_a_if_in_range" + [ range max_int ; range max_int ; int; range 10000; range 10000 ] + @@ fun low high n a b -> + let low, high = min low high, max low high in + let choice = Eqaf.select_a_if_in_range ~low ~high ~n a b in + check_eq ~eq:(=) (if low <= n && n <= high then a else b) choice + +let () = + add_test ~name:"uppercase_ascii" [ bytes ] + @@ fun raw_str -> + check_eq ~eq:String.equal + (String.uppercase_ascii raw_str) + (Eqaf.uppercase_ascii raw_str) + +let () = + add_test ~name:"lowercase_ascii" [ bytes ] + @@ fun raw_str -> + check_eq ~eq:String.equal + (String.lowercase_ascii raw_str) + (Eqaf.lowercase_ascii raw_str) + +let () = + (* These are here for compat with OCaml <= 4.09 + from >= they can be replaced by + Int32.unsigned_div + Int32.unsigned_rem + *) + let int32_div_unsigned n d = + let sub,min_int = Int32.(sub,min_int)in + let int32_unsigned_compare n m = + Int32.compare (sub n min_int) (sub m min_int) + in + if d < 0_l then + if int32_unsigned_compare n d < 0 then 0_l else 1_l + else + let q = + let open Int32 in + shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in + let r = sub n (Int32.mul q d) in + if int32_unsigned_compare r d >= 0 then Int32.succ q else q + in + let int32_rem_unsigned n d = + Int32.sub n (Int32.mul (int32_div_unsigned n d) d) + in + add_test ~name:"divmod" [ int32 ; int32 ] + @@ fun x m -> + try + let result = Eqaf.divmod ~x ~m in + let expect = int32_div_unsigned x m, + int32_rem_unsigned x m in + check_eq ~eq:(=) expect result + with + | Invalid_argument desc -> + (* we expect this for negative m: *) + assert (desc = "m <= 0" || desc = "m >= 16348 not supported") + +let () = + add_test ~name:"hex_of_string |> string_of_hex" [ bytes ] + @@ fun raw -> + let enc = Eqaf.hex_of_string raw in + let dec = Eqaf.string_of_hex enc in + check_eq ~pp:(fun fmt (s,err) -> Format.fprintf fmt "(%S,%d)" s err) + ~eq:(=) (raw,0) dec ; + String.iter (function (* check for invalid encoding: *) + | '0'..'9' + | 'a'..'z' + | 'A'..'Z' -> () + | _ -> assert false) enc + +let () = + add_test ~name:"string_of_hex |> hex_of_string" [ bytes ] + @@ fun hex -> + begin + match Eqaf.string_of_hex hex with + | dec, 0 -> + let enc = Eqaf.hex_of_string dec in + check_eq ~pp:(fun fmt s -> Format.pp_print_string fmt @@ String.escaped s) + ~eq:(=) (String.lowercase_ascii hex) enc ; + | _ -> + let invalid = ref false in + begin + if (String.length hex mod 2 = 1) + then invalid := true + else String.iter (function + | 'a'..'f' + | '0'..'9' + | 'A'..'F' -> () + | _ -> invalid := true + ) hex + end ; assert !invalid (* we expect it to be invalid since it raised *) + end + +let () = + add_test ~name:"equal" [ bytes; bytes; ] @@ fun a b -> + let expect = String.equal a b in + let result = Eqaf.equal a b in + check_eq ~pp:Format.pp_print_bool ~eq:(=) expect result + +let rev str = + let len = String.length str in + let res = Bytes.create len in + for i = 0 to len - 1 do Bytes.set res (len - 1 - i) str.[i] done ; + Bytes.unsafe_to_string res + +type order = Zero | Neg | Pos + +let of_int = function 0 -> Zero | n -> if n < 0 then Neg else Pos + +let pf = Format.fprintf +let pp_order ppf = function Zero -> pf ppf "Zero" | Neg -> pf ppf "Neg" | Pos -> pf ppf "Pos" + +let () = + add_test ~name:"compare_le" [ bytes; bytes ] @@ fun a b -> + if String.length a <> String.length b then bad_test () ; + let expect = String.compare a b in + let result = Eqaf.compare_be a b in + check_eq ~pp:pp_order ~eq:(=) (of_int expect) (of_int result) + +let () = + add_test ~name:"compare_be" [ bytes; bytes ] @@ fun a b -> + if String.length a <> String.length b then bad_test () ; + let expect = String.compare (rev a) (rev b) in + let result = Eqaf.compare_le a b in + check_eq ~pp:pp_order ~eq:(=) (of_int expect) (of_int result) diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..23e5572 --- /dev/null +++ b/lib/dune @@ -0,0 +1,19 @@ +(library + (name eqaf) + (public_name eqaf) + (modules unsafe eqaf)) + +(rule + (copy %{read:../config/which-unsafe-file} unsafe.ml)) + +(library + (name eqaf_bigstring) + (public_name eqaf.bigstring) + (modules eqaf_bigstring) + (libraries eqaf)) + +(library + (name eqaf_cstruct) + (public_name eqaf.cstruct) + (modules eqaf_cstruct) + (libraries cstruct eqaf.bigstring)) diff --git a/lib/eqaf.ml b/lib/eqaf.ml new file mode 100644 index 0000000..bc9d3d7 --- /dev/null +++ b/lib/eqaf.ml @@ -0,0 +1,389 @@ +let[@inline always] char_chr ch = + (* Char.chr contains a branch on [ch] and a plt indirection, this + * implementation ensures well-formedness by construction and avoids that: *) + Char.unsafe_chr (ch land 0xff) + +let[@inline] get x i = String.unsafe_get x i |> Char.code + +(* XXX(dinosaure): we use [unsafe_get] to avoid jump to exception: + + sarq $1, %rbx + movzbq (%rax,%rbx), %rax + leaq 1(%rax,%rax), %rax + ret +*) + +external unsafe_get_int16 : string -> int -> int = "%caml_string_get16u" +let[@inline] get16 x i = unsafe_get_int16 x i + +(* XXX(dinosaure): same as [unsafe_get] but for [int16]: + + sarq $1, %rbx + movzwq (%rax,%rbx), %rax + leaq 1(%rax,%rax), %rax + ret +*) + +let equal ~ln a b = + let l1 = ln asr 1 in + + (* + sarq $1, %rcx + orq $1, %rcx + *) + + let r = ref 0 in + + (* + movq $1, %rdx + *) + + for i = 0 to pred l1 do r := !r lor (get16 a (i * 2) lxor get16 b (i * 2)) done ; + + (* + movq $1, %rsi + addq $-2, %rcx + cmpq %rcx, %rsi + jg .L104 +.L105: + leaq -1(%rsi,%rsi), %r8 + + sarq $1, %r8 + movzwq (%rdi,%r8), %r9 + leaq 1(%r9,%r9), %r9 + movzwq (%rbx,%r8), %r8 + leaq 1(%r8,%r8), %r8 + + // [unsafe_get_int16 a i] and [unsafe_get_int6 b i] + + xorq %r9, %r8 + orq $1, %r8 + orq %r8, %rdx + movq %rsi, %r8 + addq $2, %rsi + cmpq %rcx, %r8 + jne .L105 +.L104: + *) + + for _ = 1 to ln land 1 do r := !r lor (get a (ln - 1) lxor get b (ln - 1)) done ; + + (* + movq $3, %rsi + movq %rax, %rcx + andq $3, %rcx + cmpq %rcx, %rsi + jg .L102 +.L103: + movq %rax, %r8 + addq $-2, %r8 + + sarq $1, %r8 + movzbq (%rdi,%r8), %r9 + leaq 1(%r9,%r9), %r9 + movzbq (%rbx,%r8), %r8 + leaq 1(%r8,%r8), %r8 + + // [unsafe_get a i] and [unsafe_get b i] + + xorq %r9, %r8 + orq $1, %r8 + orq %r8, %rdx + movq %rsi, %r8 + addq $2, %rsi + cmpq %rcx, %r8 + jne .L103 +.L102: + *) + + !r = 0 + +(* + cmpq $1, %rdx + sete %al + movzbq %al, %rax + leaq 1(%rax,%rax), %rax + ret +*) + +let equal a b = + let al = String.length a in + let bl = String.length b in + if al <> bl + then false + else equal ~ln:al a b + +let[@inline always] compare (a:int) b = a - b +let[@inline always] sixteen_if_minus_one_or_less n = (n asr Sys.int_size) land 16 +let[@inline always] eight_if_one_or_more n = ((-n) asr Sys.int_size) land 8 + +let compare_le ~ln a b = + let r = ref 0 in + let i = ref (pred ln) in + + while !i >= 0 do + let xa = get a !i and xb = get b !i in + let c = compare xa xb in + r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; + decr i ; + done ; + + (!r land 8) - (!r land 16) + +let compare_le_with_len ~len:ln a b = + let al = String.length a in + let bl = String.length b in + if ln = 0 then 0 + else if (al lxor ln) lor (bl lxor ln) <> 0 + then invalid_arg "compare_le_with_len" + else compare_le ~ln a b + +let compare_le a b = + let al = String.length a in + let bl = String.length b in + if al < bl + then 1 + else if al > bl + then (-1) + else compare_le ~ln:al (* = bl *) a b + +let compare_be ~ln a b = + let r = ref 0 in + let i = ref 0 in + + while !i < ln do + let xa = get a !i and xb = get b !i in + let c = compare xa xb in + r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; + incr i ; + done ; + + (!r land 8) - (!r land 16) + +let compare_be_with_len ~len:ln a b = + let al = String.length a in + let bl = String.length b in + if ln = 0 then 0 + else if (al lxor ln) lor (bl lxor ln) <> 0 + then invalid_arg "compare_be_with_len" + else compare_be ~ln a b + +let compare_be a b = + let al = String.length a in + let bl = String.length b in + if al < bl then 1 + else if al > bl then (-1) + else compare_be ~ln:al (* = bl *) a b + +let[@inline always] minus_one_or_less n = + n lsr (Sys.int_size - 1) + +let[@inline always] one_if_not_zero n = + minus_one_or_less ((- n) lor n) + +let[@inline always] zero_if_not_zero n = + (one_if_not_zero n) - 1 + +let[@inline always] select_int choose_b a b = + let mask = ((- choose_b) lor choose_b) asr Sys.int_size in + (a land (lnot mask)) lor (b land mask) + +external int_of_bool : bool -> int = "%identity" +external unsafe_bool_of_int : int -> bool = "%identity" + +let[@inline] bool_of_int n = + unsafe_bool_of_int (one_if_not_zero n) + +let[@inline always] find_uint8 ~off ~len ~f str = + let i = ref (len - 1) in + let a = ref (lnot 0) in + while !i >= off do + let byte = get str !i in + let pred = int_of_bool (f byte) in + (* XXX(dinosaure): a composition of [f] with [bool_of_int] such as + [let f = bool_of_int <.> f in] implies an allocation (of a closure). + To be GC-free, we must store result of [f] into a register, and apply + [bool_of_int] then (introspection was done on OCaml 4.08.1). *) + a := select_int (((!i - off) land min_int) lor pred) !a !i ; + decr i ; + done ; !a + +let find_uint8 ?(off= 0) ~f str = + (* XXX(dinosaure): with this overload, OCaml is able to produce 2 [find_uint8]. + One with [off= 0] and one other where [off] is an argument. I think it's about + cross-module optimization where a call to [find_uint8 ~f v] will directly call + the first one and a call to [find_uint8 ~off:x ~f v] will call the second one. *) + let len = String.length str in + find_uint8 ~off ~len ~f str + +let exists_uint8 ?off ~f str = + let v = find_uint8 ?off ~f str in + let r = select_int (v + 1) 0 1 in + unsafe_bool_of_int r + +let divmod ~(x:int32) ~(m:int32) : int32 * int32 = + (* Division and remainder being constant-time with respect to [x] + * ( NOT [m] !). The OCaml variant would be: + * [(x / m , x mod m)] where [x] is a secret and [m] is not secret. + * Adapted from the NTRU Prime team's algorithm from + * supercop/crypto_kem/sntrup761/ref/uint32.c + * cite the round-2 ntru prime submission to nistpqc (march 2019) + * Note that in practice this works for at least some much larger [x] and [m], + * but it's unclear to me how to evaluate *which*, so leaving the original + * restrictions in. + *) + let ( - ) , ( + ), ( * ) = Int32.(sub, add, mul) in + let ( >> ) = Int32.shift_right_logical in + if (m <= 0l) then raise (Invalid_argument "m <= 0") ; + if (m >= 16348l) then raise (Invalid_argument "m >= 16348 not supported") ; + + let of_uint32 uint = + (* apparently Int64.of_int32 sign-extends ... great... avoid that: *) + let b = Bytes.make 8 '\x00' in + Unsafe.set_int32_le b 0 uint ; + Unsafe.get_int64_le b 0 + in + + let x_0 = x in + + let x_2, q_1 = + let int32_div_unsigned n d = + (* can be replaced by Int32.unsigned_div + * from OCaml >= 4.10 *) + let sub,min_int = Int32.(sub,min_int)in + let int32_unsigned_compare n m = + Int32.compare (sub n min_int) (sub m min_int) + in + if d < 0_l then + if int32_unsigned_compare n d < 0 then 0_l else 1_l + else + let q = + let open Int32 in + shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in + let r = sub n (Int32.mul q d) in + if int32_unsigned_compare r d >= 0 then Int32.succ q else q + in + let v = int32_div_unsigned Int32.min_int m |> of_uint32 in + (*let v = 0x80_00_00_00 / m in*) (* floored div *) + let x_1, q_0 = + let qpart_0 = + let open Int64 in + shift_right_logical (mul (of_uint32 x_0) v) 31 + |> to_int32 + in + x_0 - (qpart_0 * m), qpart_0 + in + let qpart_1 = + let open Int64 in + shift_right_logical (mul (of_uint32 x_1) v) 31 + |> to_int32 in + x_1 - (qpart_1 * m), + (q_0 + qpart_1 + 1l) in + let x_3 = x_2 - m in + let mask = 0l - (x_3 >> 31) in + q_1 + mask, x_3 + (Int32.logand mask m) + +let ascii_of_int32 ~digits (n:int32) : string = + (* Recursively calls [divmod n 10]; the remainder is turned into ASCII + and the quotient is used for the next division.*) + if digits < 0 then raise (Invalid_argument "digits < 0"); + let out = Bytes.make digits '0' in + let rec loop x = function + | -1 -> Bytes.unsafe_to_string out + | idx -> + let next, this = divmod ~x ~m:10l in + Bytes.set out idx @@ char_chr (0x30 lor (Int32.to_int this)) ; + loop next (pred idx) + in loop n (pred digits) + +let[@inline always] to_hex_nibble f : char = + let a = 86 + f in + let c = 1 + ((a - 71 * ((a land 0x10) lsr 4)) lor 0x20) in + char_chr c + +let hex_of_string rawbytes = + String.init (2 * String.length rawbytes) + (fun idx -> + let byt = String.get rawbytes (idx lsr 1) |> Char.code in + (* select which 4 bits to use, this can probably be done faster:*) + let nib = 0xf land (byt lsr (((lnot idx) land 1) lsl 2)) in + to_hex_nibble nib) + +let hex_of_bytes rawbytes = hex_of_string (Bytes.unsafe_to_string rawbytes) + +let[@inline always] select_a_if_in_range ~low ~high ~n a b = + (* select [a] if [low <= n <= high] and [b] if [n] is out of range.*) + (* NB: ONLY WORKS FOR [0 <= low <= high <= max_int]*) + (* The idea being that: + 1.a) if low <= n : (n - low) is positive + + 1.b) if low > n : (n - low) is negative - + 2.a) if n <= high: (high - n) is positive + + 2.b) if n > high: (high - n) is negative - + We OR the numbers together; we only really care about the sign bit + which is set when negative. + Thus both numbers are positive iff (low <= n && n <= high). + We then select the sign bit with (land min_int) and use that to choose: + *) + let out_of_range = (* choose b if out of range *) + ((n - low) lor (high - n) + land min_int) + in + select_int out_of_range a b + +let lowercase_ascii src = + (* ct version of String.lowercase_ascii *) + String.map + ( fun ch -> let n = Char.code ch in + (* 0x41 is 'A'; 0x5a is 'Z'; 0x20 controls case for ASCII letters *) + select_a_if_in_range ~low:0x41 ~high:0x5a ~n (n lor 0x20) (n) + |> char_chr + ) src + +let uppercase_ascii src = + (* ct version of String.uppercase_ascii *) + String.map + ( fun ch -> let n = Char.code ch in + (* 0x61 is 'a'; 0x7a is 'z'; 0x20 controls case for ASCII letters *) + select_a_if_in_range ~low:0x61 ~high:0x7a ~n (n lxor 0x20) (n) + |> char_chr + ) src + +let bytes_of_hex rawhex = + (* hex length must be multiple of 2: *) + let error_bitmap = ref ((String.length rawhex land 1) lsl 4) in + let decoded = + Bytes.init (String.length rawhex lsr 1) + (fun idx -> + let idx = idx lsl 1 in + let nib idx = + String.get rawhex idx + |> Char.code + |> fun n -> (* uppercase -> lowercase: *) + select_a_if_in_range ~low:0x41 ~high:0x5a + ~n + (n lor 0x20) (* set case bit *) + n (* leave as-is *) + |> fun n -> (* now either invalid; lowercase; numeric*) + (select_a_if_in_range ~low:0x30 ~high:0x39 + ~n + (n - 0x30) (* numeric: subtract '0' to get [0..9] *) + (select_a_if_in_range ~low:0x61 ~high:0x66 + ~n + (* a-f: subtract 'a' and add 10 to get [10..15]: *) + (n - 0x61 + 10) + (0xff) (* invalid, ensure we set upper bits of error_bitmap *) + ) + ) + in + let nibf0 = nib idx + and nib0f = nib (succ idx) in + error_bitmap := !error_bitmap lor nibf0 lor nib0f ; + char_chr ((nibf0 lsl 4) lor nib0f) + ) + in + (* if any non-nibble bits were set in !error_bitmap, decoding failed: *) + decoded, !error_bitmap land (lnot 0xf) + +let string_of_hex rawhex = + let byt, error = bytes_of_hex rawhex in + Bytes.unsafe_to_string byt, error diff --git a/lib/eqaf.mli b/lib/eqaf.mli new file mode 100644 index 0000000..0245e03 --- /dev/null +++ b/lib/eqaf.mli @@ -0,0 +1,318 @@ +(** Eqaf - constant time / timing side channel resistant functions *) + +(** {1 Basics} + + In cryptography, a timing-attack is a side-channel attack in which the + attacker attempts to compromise a cryptosystem by analyzing the time taken to + execute cryptographic algorithms. + + In some cases, a process needs to compare two values (input value and + expected password). An attacker can analyze time needed by + {!String.compare}/{!String.equal} to calculate expected password. + + This side-channel attack is due implementation of + {!String.compare}/{!String.equal} which leaves as soon as possible when it + reachs a difference between [a] and [b]. By this way, time taken to compare + two values differs if they are equal or not. + + Distribution provides a little example of this kind of attack where we + construct step by step (byte per byte) expected value from time spended to + execute {!Stdlib.compare}. + + Distribution wants to provide some functions which protect user against this + kind of attack: + + {ul + {- [equal] like {!String.equal}} + {- [compare_be] like {!String.compare}} + {- [compare_le] which is a {!String.compare} with a reverse operation on + inputs} + {- {!divmod} like {!Int32.unsigned_div} and {!Int32.unsigned_rem}}} + + These functions are tested to see how long they took to compare two equal + values and two different values. See {i check} tool for more informations. *) + +(** {1 Comparison functions} *) + +(** {2 Equal} *) + +val equal : string -> string -> bool +(** [equal a b] returns [true] if [a] and [b] are equals. [String.equal a b = + equal a b] for any [a] and [b]. The execution time of [equal] depends solely + on the length of the strings, not the contents. *) + +(** {2 Big-endian comparison} *) + +val compare_be : string -> string -> int +(** [compare_be a b] returns [0] if [a] is equal to [b], a negative integer if + [a] if {i less} (lexicographically) than [b], and a positive integer if [a] + is {i greater} (lexicographically) than [b]. + + [compare_be a b] returns the same {i order} than [String.compare a b] for + any [a] and [b] (but not necessary the same integer!). Order is defined as: + + {ul + {- [compare_be a b < 0] means [a < b]} + {- [compare_be a b > 0] means [a > b]} + {- [compare_be a b = 0] means [a = b]}} + + About time, if [String.length a <> String.length b], [compare_be] does not + look into [a] or [b] and no comparison in bytes will be done. *) + +val compare_be_with_len : len:int -> string -> string -> int +(** [compare_be_with_len ~len a b] does {!compare_be}[ a b] on [len] bytes. + + @raise Invalid_argument if [len] is upper than [String.length a] or + [String.length b]. *) + +(** {2 Little-endian comparison} *) + +val compare_le : string -> string -> int +(** [compare_le a b] is semantically [compare_be (rev a) (rev b)], + where [rev] is a function that reverses a string bytewise + ([a = rev (rev a)]). *) + +val compare_le_with_len : len:int -> string -> string -> int +(** [compare_le_with_len a b] is semantically [compare_be_with_len ~len (rev a) + (rev b)]. With [rev] reverse a string ([a = rev (rev a)]). + + @raise Invalid_argument if [len] is upper than [String.length a] or + [String.length b]. *) + +(** {1 Arithmetic} *) + +(** {2 Division} *) + +val divmod : x:int32 -> m:int32 -> int32 * int32 +(** 32-bit unsigned division with remainder, + constant-time with respect to [x] ({b not} [m]). + + @param x Dividend (number to be divided). {b Can be secret}. + @param m Divisor {b Must not be secret}. Must be [0 < m < 16384] + + This function is useful for implementation that need to produce e.g. + pincodes from binary values in int32 format, example: {!ascii_of_int32}. + + @return [quotient, remainder] + + Example: + {[ + let ct = Eqaf.divmod ~x ~m in + let not_ct = Int32.unsigned_div x m, Int32.unsigned_rem x m in + assert ct = not_ct ; + ]} + + That is, an attacker might be able to learn [m] by measuring + execution time, but not the value of [x]. + + @raise Invalid_argument when [not (0 < m && m < 16384)]. + + @see "supercop/crypto_kem/sntrup761/ref/uint32.c" Adapted from the NTRU Prime team's algorithm from [supercop/sntrup761], see round-2 NTRU Prime submission to NISTPQC (March 2019). +*) + +(** {1:stringutil String utilities} *) + +(** {2 String search}*) + +val find_uint8 : ?off:int -> f:(int -> bool) -> string -> int +(** [find_uint8 ?off ~f v] returns the index of the first occurrence which + respects the predicate [f] in string [v]. Otherwise, it returns [-1]. + The caller is responsible for ensuring that [~f] operates in constant time. + The {!bool_of_int} function can be relevant when writing [~f] functions. +*) + +val exists_uint8 : ?off:int -> f:(int -> bool) -> string -> bool +(** [exists_uint8 ?off ~f v] tests if an occurrence respects the predicate + [f] in the string [v]. *) + +(** {2:ascii ASCII functions}*) + +val ascii_of_int32 : digits:int -> int32 -> string +(** [ascii_of_int64 ~digits ~n] is a string consisting of + the rightmost [digits] characters of the decimal representation + of [n]. + If [digits] is larger than the decimal representation, it is left-padded + with ['0']. + If [digits] is smaller, the output is truncated. + + Example: + {[ + let s1 = ascii_of_int64 ~digits:6 ~n:12345678L in + assert (s = "345678") ; + let s2 = ascii_of_int64 ~digits:6 ~n:1234L in + assert (s = "001234") ; + ]} + + @raise Invalid_argument when [digits < 0] +*) + +val lowercase_ascii : string -> string +(** [lowercase_ascii str] is [str] where [A-Z] is replaced with [a-z]. + It is a constant time implementation of {!String.lowercase_ascii} +*) + +val uppercase_ascii : string -> string +(** [uppercase_ascii str] is [str] where [a-z] is replaced with [A-Z]. + It is a constant time implementation of {!String.uppercase_ascii} +*) + +(** {2:hex Hex encoding and decoding}*) + +val hex_of_bytes : bytes -> string +(** [hex_of_bytes raw] is [raw] hex-encoded in constant time. + Can be used to serialize sensitive values. + The {b contents can be secret}, but an attacker can learn the + {b length of} [raw] by timing this function. + + Hex has two valid forms, lowercase and uppercase. + This function produces lowercase hex characters exclusively. + + Example: + {[ + let secret = "--Hi\x24" in + let serialized = hex_of_string secret in + (* serialized is now "2d2d486924" *) + ]} + + @param raw is the source buffer. [raw] is not mutated by this function. +*) + +val hex_of_string : string -> string +(** [hex_of_string raw] is [hex_of_bytes raw] as a {!string} *) + +val bytes_of_hex : string -> bytes * int +(** [bytes_of_hex hex] is [raw, error] decoded in constant time. + Can be used to e.g. decode secrets from configuration files. + The {b contents can be secret}, but an attacker can learn + the {b length of} [hex] by timing this function. + + {b Error handling:} The second tuple element [error] is {b non-zero} + when the length of [hex] is not a multiple of 2, + or [hex] contains invalid characters. + Implementations should ensure that `error = 0` before using [raw]. + The function signals errors this way to allow implementations to handle + invalid input errors in constant time. + + @param hex The hex-encoded octet string. Accepts characters [0-9 a-f A-F]. + Note that [0x] prefixes or whitespace are not accepted. + + Example: + {[ + let serialized = "2d2d486924" in + let secret, error = string_of_hex serialized in + assert (error = 0); + (* secret is now [--Hi$] *) + ]} +*) + +val string_of_hex : string -> string * int +(** [string_of_hex hex] is {!bytes_of_hex} [hex], + but returning a {!type:string} instead of {!type:bytes}. + See {!bytes_of_hex} regarding handling of invalid input errors. +*) + +(** {1 Low-level primitives} *) + +(** {2 Bithacks} *) + +val one_if_not_zero : int -> int +(** [one_if_not_zero n] is a constant-time version of + [if n <> 0 then 1 else 0]. This is functionally equivalent to [!!n] in the C + programming language. *) + +val zero_if_not_zero : int -> int +(** [zero_if_not_zero n] is a constant-time of + [if n <> 0 then 0 else 1]. This is functionnaly equivalent to [!n] in the C + programming language. *) + +val int_of_bool : bool -> int +(** [int_of_bool b] is equivalent to [if b then 1 else 0]. + Internally it cast with [%identity] instead of branching.*) + +val bool_of_int : int -> bool +(** [bool_of_int n] is equivalent to [if n = 0 then false else true]. *) + +(** {2 Composition} *) + +val select_int : int -> int -> int -> int +(** [select_int choose_b a b] is [a] if [choose_b = 0] and [b] otherwise. + This comparison is constant-time and it should not be possible for a measuring + adversary to determine anything about the values of [choose_b], [a], or [b]. *) + +val select_a_if_in_range : low:int -> high:int -> + n:int -> int -> int -> int +(** [select_a_if_in_range ~low ~high ~n a b] + - is [a] if [low <= n <= high] (in range) + - is [b] is [n < low || high < n] (out of range) + + This function {b only works for positive ranges}: + @param low invariant: [0 <= low <= max_int] + @param high invariant: [low <= high <= max_int] + + This function can be used like {!select_int} but using an integer range + instead of zero/non-zero to select. + + It operates in constant time and is safe to use with secret parameters for + [low, high, n, a, b]. + + Example: + {[ + let a = 123 and b = 456 in + let x = select_a_if_in_range ~low:10 ~high:20 ~n:10 a b in + (* x = 123 *) + let x = select_a_if_in_range ~low:10 ~high:20 ~n:0 a b in + (* x = 456 *) + let x = select_a_if_in_range ~low:10 ~high:20 ~n:20 a b in + (* x = 123 *) + let x = select_a_if_in_range ~low:10 ~high:20 ~n:21 a b in + (* x = 456 *) + + (* Constant-time subpatterns can be expressed by nesting, + Below is a constant time version of: + match 3 with + | 1 | 2| 3 | 4 -> + begin match 3 with + | 2 | 3 -> 111 + | _ -> 222 + end + | _ -> 333 + + *) + let n = 3 + select_a_if_in_range ~low:1 ~high:4 ~n + (select_a_if_in_range ~low:2 ~high:3 ~n + (111) + (222) + ) + 333 + (* evalutes to 111 because [1 <= n <= 4] selects the inner pattern + and [2 <= n <= 3] selects the first branch ("a") of the inner pattern. + *) + + (* The applications can also be composed in constant time, + note that all the branches are always evaluated, so large + expressions can get slow: + *) + 4 + |> fun n -> select_a_if_in_range ~low:1 ~high:5 ~n + (n * 10) + (n - 100) + |> fun n -> select_a_if_in_range ~low:20 ~high 30 ~n + (n * 100) + (n+3) + (* evaluates to [4 *10 + 3] *) + + (* Below the normal, non-constant time version: *) + 4 + |> (function + | n when 1 <= n && n <= 5 -> n * 10 + | n -> n - 100) + |> (function + | n when 20 <= n && n <= 30 -> n * 100 + | n -> n + 3) + ]} + + Another example of how to use this can be found in the implementations of + {!lowercase_ascii} and {!bytes_of_hex}. +*) + diff --git a/lib/eqaf_bigstring.ml b/lib/eqaf_bigstring.ml new file mode 100644 index 0000000..14a5476 --- /dev/null +++ b/lib/eqaf_bigstring.ml @@ -0,0 +1,106 @@ +type bigstring = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +let length x = Bigarray.Array1.dim x [@@inline] +let get x i = Bigarray.Array1.unsafe_get x i |> Char.code [@@inline] +external unsafe_get_int16 : bigstring -> int -> int = "%caml_bigstring_get16u" [@@noalloc] +let get16 x i = unsafe_get_int16 x i [@@inline] + +let equal ~ln a b = + let l1 = ln asr 1 in + let r = ref 0 in + for i = 0 to pred l1 do r := !r lor (get16 a (i * 2) lxor get16 b (i * 2)) done ; + for _ = 1 to ln land 1 do r := !r lor (get a (ln - 1) lxor get b (ln - 1)) done ; + !r = 0 + +let equal a b = + let al = length a in + let bl = length b in + if al <> bl + then false + else equal ~ln:al a b + +let[@inline always] compare (a:int) b = a - b +let[@inline always] sixteen_if_minus_one_or_less n = (n asr Sys.int_size) land 16 +let[@inline always] eight_if_one_or_more n = ((-n) asr Sys.int_size) land 8 + +let compare_le ~ln a b = + let r = ref 0 in + let i = ref (pred ln) in + + while !i >= 0 do + let xa = get a !i and xb = get b !i in + let c = compare xa xb in + r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; + decr i ; + done ; + + (!r land 8) - (!r land 16) + +let compare_le_with_len ~len:ln a b = + let al = length a in + let bl = length b in + if ln = 0 then 0 + else if (al lxor ln) lor (bl lxor ln) <> 0 + then invalid_arg "compare_le_with_len" + else compare_le ~ln a b + +let compare_le a b = + let al = length a in + let bl = length b in + if al < bl + then 1 + else if al > bl + then (-1) + else compare_le ~ln:al (* = bl *) a b + +let compare_be ~ln a b = + let r = ref 0 in + let i = ref 0 in + + while !i < ln do + let xa = get a !i and xb = get b !i in + let c = compare xa xb in + r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; + incr i ; + done ; + + (!r land 8) - (!r land 16) + +let compare_be_with_len ~len:ln a b = + let al = length a in + let bl = length b in + if ln = 0 then 0 + else if (al lxor ln) lor (bl lxor ln) <> 0 + then invalid_arg "compare_be_with_len" + else compare_be ~ln a b + +let compare_be a b = + let al = length a in + let bl = length b in + if al < bl then 1 + else if al > bl then (-1) + else compare_be ~ln:al (* = bl *) a b + +(* XXX(dinosaure): see [eqaf.ml] for this part. *) + +external int_of_bool : bool -> int = "%identity" +external unsafe_bool_of_int : int -> bool = "%identity" + +let[@inline always] find_uint8 ~off ~len ~f str = + let i = ref (len - 1) in + let a = ref (lnot 0) in + while !i >= off do + let byte = get str !i in + let pred = int_of_bool (f byte) in + a := Eqaf.select_int (((!i - off) land min_int) lor pred) !a !i ; + decr i ; + done ; !a + +let find_uint8 ?(off= 0) ~f str = + let len = length str in + find_uint8 ~off ~len ~f str + +let exists_uint8 ?off ~f str = + let v = find_uint8 ?off ~f str in + let r = Eqaf.select_int (v + 1) 0 1 in + unsafe_bool_of_int r diff --git a/lib/eqaf_bigstring.mli b/lib/eqaf_bigstring.mli new file mode 100644 index 0000000..d0526d6 --- /dev/null +++ b/lib/eqaf_bigstring.mli @@ -0,0 +1,9 @@ +type bigstring = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +val equal : bigstring -> bigstring -> bool +val compare_be : bigstring -> bigstring -> int +val compare_be_with_len : len:int -> bigstring -> bigstring -> int +val compare_le : bigstring -> bigstring -> int +val compare_le_with_len : len:int -> bigstring -> bigstring -> int +val find_uint8 : ?off:int -> f:(int -> bool) -> bigstring -> int +val exists_uint8 : ?off:int -> f:(int -> bool) -> bigstring -> bool diff --git a/lib/eqaf_cstruct.ml b/lib/eqaf_cstruct.ml new file mode 100644 index 0000000..fe5b3ff --- /dev/null +++ b/lib/eqaf_cstruct.ml @@ -0,0 +1,26 @@ +let equal a b = + Eqaf_bigstring.equal (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) + +let compare_be_with_len ~len a b = + Eqaf_bigstring.compare_be_with_len ~len + (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) + +let compare_le_with_len ~len a b = + Eqaf_bigstring.compare_le_with_len ~len + (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) + +let compare_le a b = + Eqaf_bigstring.compare_le + (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) + +let compare_be a b = + Eqaf_bigstring.compare_be + (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) + +let find_uint8 ?off ~f v = + Eqaf_bigstring.find_uint8 + ?off ~f (Cstruct.to_bigarray v) + +let exists_uint8 ?off ~f v = + Eqaf_bigstring.exists_uint8 + ?off ~f (Cstruct.to_bigarray v) diff --git a/lib/eqaf_cstruct.mli b/lib/eqaf_cstruct.mli new file mode 100644 index 0000000..5f875fb --- /dev/null +++ b/lib/eqaf_cstruct.mli @@ -0,0 +1,7 @@ +val equal : Cstruct.t -> Cstruct.t -> bool +val compare_be : Cstruct.t -> Cstruct.t -> int +val compare_be_with_len : len:int -> Cstruct.t -> Cstruct.t -> int +val compare_le : Cstruct.t -> Cstruct.t -> int +val compare_le_with_len : len:int -> Cstruct.t -> Cstruct.t -> int +val find_uint8 : ?off:int -> f:(int -> bool) -> Cstruct.t -> int +val exists_uint8 : ?off:int -> f:(int -> bool) -> Cstruct.t -> bool diff --git a/lib/unsafe_pre407.ml b/lib/unsafe_pre407.ml new file mode 100644 index 0000000..6dba3bd --- /dev/null +++ b/lib/unsafe_pre407.ml @@ -0,0 +1,13 @@ +external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_string_set32" +external get_int64_ne : bytes -> int -> int64 = "%caml_string_get64" + +external swap32 : int32 -> int32 = "%bswap_int32" +external swap64 : int64 -> int64 = "%bswap_int64" + +let set_int32_le b i x = + if Sys.big_endian then set_int32_ne b i (swap32 x) + else set_int32_ne b i x + +let get_int64_le b i = + if Sys.big_endian then swap64 (get_int64_ne b i) + else get_int64_ne b i diff --git a/lib/unsafe_pre408.ml b/lib/unsafe_pre408.ml new file mode 100644 index 0000000..26a4f41 --- /dev/null +++ b/lib/unsafe_pre408.ml @@ -0,0 +1,13 @@ +external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32" +external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64" + +external swap32 : int32 -> int32 = "%bswap_int32" +external swap64 : int64 -> int64 = "%bswap_int64" + +let set_int32_le b i x = + if Sys.big_endian then set_int32_ne b i (swap32 x) + else set_int32_ne b i x + +let get_int64_le b i = + if Sys.big_endian then swap64 (get_int64_ne b i) + else get_int64_ne b i diff --git a/lib/unsafe_stable.ml b/lib/unsafe_stable.ml new file mode 100644 index 0000000..968693d --- /dev/null +++ b/lib/unsafe_stable.ml @@ -0,0 +1,2 @@ +let set_int32_le b i x = Bytes.set_int32_le b i x +let get_int64_le b i = Bytes.get_int64_le b i diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..c4a6c3c --- /dev/null +++ b/test/dune @@ -0,0 +1,27 @@ +(executable + (name test) + (modules test) + (libraries alcotest eqaf)) + +(rule + (alias runtest) + (locks singleton) + (package eqaf) + (deps + (:test test.exe)) + (action + (run %{test} --color=always))) + +(executable + (name test_branch) + (modules test_branch) + (libraries clock unix eqaf)) + +(rule + (alias runtest) + (locks singleton) + (package eqaf) + (deps + (:test test_branch.exe)) + (action + (run %{test}))) diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 0000000..c08e349 --- /dev/null +++ b/test/test.ml @@ -0,0 +1,209 @@ +type r = Neg | Pos | Zero + +let equal w a b = match w with + | Zero -> a = 0 && b = 0 + | Neg -> a < 0 && b < 0 + | Pos -> a > 0 && b > 0 + +let of_expected = function + | 0 -> Zero | n -> if n < 0 then Neg else Pos + +let value w = Alcotest.testable Fmt.int (equal w) + +let be a b expected = + let title = Fmt.strf "be %S %S = %d" a b expected in + Alcotest.test_case title `Quick @@ fun () -> + let expected' = String.compare a b in + Alcotest.(check (value (of_expected expected))) "result" (Eqaf.compare_be a b) expected ; + Alcotest.(check (value (of_expected expected'))) "string.compare" (Eqaf.compare_be a b) expected' + +let le a b expected = + let title = Fmt.strf "le %S %S = %d" a b expected in + Alcotest.test_case title `Quick @@ fun () -> + Alcotest.(check (value (of_expected expected))) "result" (Eqaf.compare_le a b) expected + +let exists str chr exists = + Alcotest.test_case (Fmt.strf "contains %S %c = %b" str chr exists) `Quick @@ fun () -> + let res = Eqaf.exists_uint8 ~f:((=) (Char.code chr)) str in + Alcotest.(check bool) "result" res exists + +let find str chr index = + Alcotest.test_case (Fmt.strf "index %S %c = %d" str chr index) `Quick @@ fun () -> + let res = Eqaf.find_uint8 ~f:((=) (Char.code chr)) str in + Alcotest.(check int) "result" res index + +let int_of_bool bool expect = + Alcotest.test_case + (Fmt.strf + "int_of_bool %B = %d" bool expect + ) `Quick @@ fun ()-> + Alcotest.(check int) "result" expect (Eqaf.int_of_bool bool) + +let bool_of_int desc n expect = + Alcotest.test_case + (Fmt.strf + "int_of_bool %s = %B" desc expect + ) `Quick @@ fun ()-> + Alcotest.(check bool) "result" expect (Eqaf.bool_of_int n) + +let select_a_if_in_range (low,high) n a b expect = + Alcotest.test_case + (Fmt.strf + "select_a_if_in_range (%d,%d) ~n:%d %d %d" + low high n a b + ) `Quick @@ fun ()-> + let choice = Eqaf.select_a_if_in_range ~low ~high ~n a b in + Alcotest.(check int) "selected" expect choice + +let a_uint32 = Alcotest.testable Fmt.uint32 (=) + + +let divmod str x m q r = + (* (x / m = q) and (x mod m = r) *) + Alcotest.test_case + (Fmt.strf + "divmod %s %lu / %lu = %lu, %lu mod %lu = %lu" + str x m q x m r + ) `Quick @@ fun ()-> + let eq_quot, eq_rem = Eqaf.divmod ~x ~m in + Alcotest.(check (pair a_uint32 a_uint32)) "q,r" (q,r) (eq_quot,eq_rem) + +let ascii_of_int32 str digits n expect = + Alcotest.test_case + (Fmt.strf + "ascii_of_string %s %d %lu %S" + str digits n expect + ) `Quick @@ fun ()-> + try + let ascii = Eqaf.ascii_of_int32 ~digits n in + Alcotest.(check string) str expect ascii + with Invalid_argument x when x = "digits < 0" -> () + +let string_of_hex str hex expect = + Alcotest.test_case + (Fmt.strf + " %s %S %S" + str hex expect + ) `Quick @@ fun ()-> + let enc = Eqaf.string_of_hex hex in + Alcotest.(check @@ pair string int) str (expect,0) enc + +let hex_of_string str raw expect = + Alcotest.test_case + (Fmt.strf + " %s %S %S" + str raw expect + ) `Quick @@ fun ()-> + let enc = Eqaf.hex_of_string raw in + Alcotest.(check string) str expect enc + +let () = + Alcotest.run "eqaf" + [ "be", [ be "a" "a" 0 + ; be "a" "b" (-1) + ; be "b" "a" 1 + ; be "aa" "ab" (-1) + ; be "aaa" "aba" (-1) + ; be "bbb" "abc" 1 + ; be "bbb" "bbc" (-1) + ; be "bbb" "abb" 1 + ; be "\x00\x34\x12" "\x00\x33\x12" 1 + ; be "\x00\x34\x12" "\x00\x33\x99" 1 ] + ; "le", [ le "a" "a" 0 + ; le "a" "b" (-1) + ; le "b" "a" 1 + ; le "aa" "ab" (-1) + ; le "aaa" "aba" (-1) + ; le "bbb" "abc" (-1) + ; le "bbb" "bbc" (-1) + ; le "bbb" "abb" 1 + ; le "\x00\x34\x12" "\x00\x33\x12" 1 + ; le "\x00\x34\x12" "\x00\x33\x99" (-1) ] + ; "exists", [ exists "a" 'a' true + ; exists "a" 'b' false + ; exists "abc" 'c' true + ; exists "abc" 'a' true + ; exists "abc" 'b' true + ; exists "abc" 'd' false ] + ; "find", [ find "a" 'a' 0 + ; find "a" 'b' (-1) + ; find "aaaa" 'a' 0 + ; find "bbbb" 'a' (-1) + ; find "aabb" 'b' 2 + ; find "aabb" 'a' 0 + ; find "aaab" 'b' 3 ] + ; "int_of_bool", [ int_of_bool false 0 (* exhaustive :-) *) + ; int_of_bool true 1] + ; "bool_of_int", [ bool_of_int "0" 0 false + ; bool_of_int "-1" ~-1 true + ; bool_of_int "2" 2 true + ; bool_of_int "max_int" max_int true + ; bool_of_int "min_int" min_int true + ; bool_of_int "1" 1 true ] + ; "select_a_if_in_range", + [ select_a_if_in_range (0,3) 0 22 30 22 + ; select_a_if_in_range (0,3) 1 22 30 22 + ; select_a_if_in_range (0,3) 2 22 30 22 + ; select_a_if_in_range (0,3) 3 22 30 22 + ; select_a_if_in_range (0,3) 4 22 30 30 + ; select_a_if_in_range (0,3) ~-1 22 30 30 + ; select_a_if_in_range (0,0) 0 1 2 1 + ; select_a_if_in_range (1,1) 0 3 4 4 + ; select_a_if_in_range (1,1) 1 5 6 5 + ; select_a_if_in_range (1,1) 2 7 8 8 + ; select_a_if_in_range (0,0) 0 7904 0 7904 + ; select_a_if_in_range (0,3) min_int 22 30 30 + ; select_a_if_in_range (0,3) max_int 22 30 30 + ; select_a_if_in_range (1,max_int-1) max_int 1 2 2 + ; select_a_if_in_range (1,max_int-1) min_int 1 2 2 + ; select_a_if_in_range (1,max_int-1) ~-1 3 4 4 + ; select_a_if_in_range (1,max_int-1) 0 5 6 6 + ; select_a_if_in_range (1,max_int) max_int 1 2 1 + ; select_a_if_in_range (1,max_int) min_int 1 2 2 + ; select_a_if_in_range (1,max_int) ~-1 3 4 4 + ; select_a_if_in_range (1,max_int) 0 5 6 6 + ; select_a_if_in_range (1,max_int) 1 5 6 5 + ; select_a_if_in_range (0,max_int) max_int 1 2 1 + ; select_a_if_in_range (0,max_int) min_int 1 2 2 + ; select_a_if_in_range (0,max_int) ~-1 3 4 4 + ; select_a_if_in_range (0,max_int) 0 5 6 5 + ] + ; "divmod", [ divmod "" 1l 2l 0l 1l + ; divmod "" 123l 1l 123l 0l + ; divmod "" 1l 3l 0l 1l + ; divmod "" 2l 3l 0l 2l + ; divmod "" 3l 2l 1l 1l + ; divmod "" 10l 6l 1l 4l + ; divmod "" 10l 4l 2l 2l + ; divmod "" 1l 2l 0l 1l + ; divmod "" 30l 7l 4l 2l + ; divmod "" 4l 2l 2l 0l + ; divmod "" 1234567l 1l 1234567l 0l + ; divmod "" 1234567l 10l 123456l 7l + ; divmod "" 1234567l 100l 12345l 67l + ; divmod "" 1234567l 1000l 1234l 567l + ; divmod "" 1234567l 10000l 123l 4567l + ; divmod "" 12345l 100l 123l 45l + ; divmod "" 0xffff1234l 1_000_l 4294906l 420l + ; divmod "" 1123456789l 10_000_l 112345l 6789l ] + ; "ascii_of_int32", [ ascii_of_int32 "" 6 12345678l "345678" + ; ascii_of_int32 "" ~-1 1234l "001234" + ; ascii_of_int32 "" 1 9876l "6" + ; ascii_of_int32 "" 4 0l "0000" + ; ascii_of_int32 "" 6 1234l "001234" + ; ascii_of_int32 "" 0 1234l ""] + ; "string_of_hex", [ string_of_hex "" "2d2d486924" "--Hi$" + ; string_of_hex "" "2D2d486924" "--Hi$" + ; string_of_hex "" "1234" "\x12\x34" + ; string_of_hex "" "ff80" "\xff\x80" + ; string_of_hex "" "b7DDdd" "\xb7\xdd\xdd" + ; string_of_hex "" "808888Fd" "\x80\x88\x88\xfd" + ; string_of_hex "" "E0EE8eEEEE" "\xe0\xee\x8e\xee\xee" + ; string_of_hex "empty" "" ""] + ; "hex_of_string", [ hex_of_string "" "--Hi$" "2d2d486924" + ; hex_of_string "" "\x12\x34" "1234" + ; hex_of_string "" "\xff\x80" "ff80" + ; hex_of_string "" "\xb7\xff\x20" "b7ff20" + ; hex_of_string "" "\x00\x01\x00" "000100" + ; hex_of_string "empty" "" ""] + ] diff --git a/test/test_branch.ml b/test/test_branch.ml new file mode 100644 index 0000000..3d8f7c8 --- /dev/null +++ b/test/test_branch.ml @@ -0,0 +1,140 @@ +let exit_success = 0 +let exit_failure = 1 + +(* First computation wants to count operations needed by + - one_if_not_zero + - zero_if_not_zero + - select_int + + For each /assembly instructions/, we update a counter. This way is not + totally true. Even if we check by hands that bitwise operations don't + emit branches, this is our only assumption! *) + +let operation = ref 0 + +let logical_shift_right a b = incr operation ; a lsr b +let logical_or a b = incr operation ; a lor b +let shift_right a b = incr operation ; a asr b +let logical_and a b = incr operation ; a land b +let logical_not a = incr operation ; lnot a +let minus a = incr operation ; (- a) +let sub a b = incr operation ; a - b + +let[@inline always] minus_one_or_less n = + logical_shift_right n (sub Sys.int_size 1) + +let[@inline always] one_if_not_zero n = minus_one_or_less (logical_or (minus n) n) +let[@inline always] zero_if_not_zero n = sub (one_if_not_zero n) 1 +let[@inline always] select_int choose_b a b = + let mask = shift_right (logical_or (minus choose_b) choose_b) Sys.int_size in + logical_or (logical_and a (logical_not mask)) (logical_and b mask) + +let one_if_not_zero_ops = + let _ = one_if_not_zero 0x7eadbeef in + Format.printf "[one_if_not_zero]: %d operation(s).\n%!" !operation ; + !operation + +let () = operation := 0 + +let zero_if_not_zero_ops = + let _ = zero_if_not_zero 0x7eadbeef in + Format.printf "[zero_if_not_zero]: %d operation(s).\n%!" !operation ; + !operation + +let () = operation := 0 + +let select_int_ops = + let _ = select_int 0 1 2 in + Format.printf "[select_int]: %d operation(s).\n%!" !operation ; + !operation + +let eqaf_sleep () = Unix.sleep 1 + +let logical_shift_right a b = eqaf_sleep () ; a lsr b +let logical_or a b = eqaf_sleep () ; a lor b +let shift_right a b = eqaf_sleep () ; a asr b +let logical_and a b = eqaf_sleep () ; a land b +let logical_not a = eqaf_sleep () ; lnot a +let minus a = eqaf_sleep () ; (- a) +let sub a b = eqaf_sleep () ; a - b + +let[@inline always] minus_one_or_less n = + logical_shift_right n (sub Sys.int_size 1) + +let[@inline always] one_if_not_zero n = minus_one_or_less (logical_or (minus n) n) +let[@inline always] zero_if_not_zero n = sub (one_if_not_zero n) 1 +let[@inline always] select_int choose_b a b = + let mask = shift_right (logical_or (minus choose_b) choose_b) Sys.int_size in + logical_or (logical_and a (logical_not mask)) (logical_and b mask) + +(* Finally, we count how many time we spend when we call our + functions. [eqaf_sleep] spends 1 second, so our bitwise operators + should spend 1 second + some nanosecond. At the end, execution of + them should be closely equal to our operation counter where: + + 1 operation ~= 1 second + + To be able to count time, we use [caml_time] which is available only + on Linux and for a native compilation (see [@unboxed]). Because bitwise + operation spend at least 1 second, we finally [floor] our results to + delete noise. + + NOTE: [check/check] does a linear regression to delete noise and really + get how long is our functions. We think that for our functions: + - zero_if_not_zero + - one_if_not_zero + - select_int + [check/check] is too huge. *) + +let time () = Clock.now () + +let fdiv a b = a /. b + +let () = + let t0 = time () in + let _ = one_if_not_zero 0x7eadbeef in + let t1 = time () in + let v0 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in + Format.printf "[one_if_not_zero 0x7eadbeef]: %fs.\n%!" v0 ; + let t0 = time () in + let _ = one_if_not_zero 0x0 in + let t1 = time () in + let v1 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in + Format.printf "[one_if_not_zero 0x0]: %fs.\n%!" v0 ; + if v0 = v1 + && int_of_float v0 = one_if_not_zero_ops + && int_of_float v1 = one_if_not_zero_ops + then () else exit exit_failure + +let () = + let t0 = time () in + let _ = zero_if_not_zero 0x7eadbeef in + let t1 = time () in + let v0 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in + Format.printf "[zero_if_not_zero 0x7eadbeef]: %fs.\n%!" v0 ; + let t0 = time () in + let _ = zero_if_not_zero 0x0 in + let t1 = time () in + let v1 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in + Format.printf "[zero_if_not_zero 0x0]: %fs.\n%!" v0 ; + if v0 = v1 + && int_of_float v0 = zero_if_not_zero_ops + && int_of_float v1 = zero_if_not_zero_ops + then () else exit exit_failure + +let () = + let t0 = time () in + let _ = select_int 0 1 2 in + let t1 = time () in + let v0 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in + Format.printf "[select_int 0 1 2]: %fs.\n%!" v0 ; + let t0 = time () in + let _ = select_int 2 1 0 in + let t1 = time () in + let v1 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in + Format.printf "[select_int 2 1 0]: %fs.\n%!" v1 ; + if v0 = v1 + && int_of_float v0 = select_int_ops + && int_of_float v1 = select_int_ops + then () else exit exit_failure +;; -- 2.30.2