Commit 5d4fc819 authored by Stephane Glondu's avatar Stephane Glondu

Move some platform-specific functions to a new module

Add module Platform: single interface to functions that depend on the
runtime. For now, the native (existing one), and a dummy one that
constitutes a skeleton for the js one.

All calls to Cryptokit, Z, Calendar (which depends on Unix) in the
command-line tool now go through this module.
parent 77ce465b
......@@ -19,6 +19,26 @@ let atdgen_action opts env build =
let js_of_ocaml env build =
Cmd (S [A"js_of_ocaml"; P (env "%.byte")])
let ( / ) = Filename.concat
let platform_rules kind =
let lib = "src" / "lib" in
let platform = "src" / "platform" / kind / "platform" in
let ml = platform ^ ".ml" in
let mli = platform ^ ".mli" in
dep ["file:" ^ ml] [mli];
copy_rule mli (lib / "platform.mli") mli
let tool_rules platform =
let platform = "src" / "platform" / platform / "platform" in
let lib = "src" / "lib" / "serializable_builtin_t" in
let lib_native = lib ^ ".cmx" in
let lib_byte = lib ^ ".cmo" in
let cmo = platform ^ ".cmo" in
let cmx = platform ^ ".cmx" in
dep ["file:" ^ lib_native] [cmx];
dep ["file:" ^ lib_byte] [cmo]
let () = dispatch & function
| Before_options ->
......@@ -51,6 +71,10 @@ let () = dispatch & function
Cmd (S [A"markdown"; P (env "%.md"); Sh">"; P (env "%.html")])
);
platform_rules "native";
platform_rules "js";
tool_rules "native";
copy_rule "belenios-tool" ("src/tool/tool_main" ^ exe_suffix) "belenios-tool";
| _ -> ()
......@@ -20,7 +20,6 @@
(**************************************************************************)
let ( |> ) x f = f x
let ( =% ) = Z.equal
module Array = struct
include Array
......@@ -138,56 +137,10 @@ let rec list_join sep = function
| [x] -> [x]
| x :: xs -> x :: sep :: list_join sep xs
let sha256_hex x = Cryptokit.(x |>
hash_string (Hash.sha256 ()) |>
transform_string (Hexa.encode ())
)
let sha256_b64 x = Cryptokit.(x |>
hash_string (Hash.sha256 ()) |>
transform_string (Base64.encode_compact ())
)
let option_map f = function
| Some x -> Some (f x)
| None -> None
let int_msb i =
let result = String.create 4 in
result.[0] <- char_of_int (i lsr 24);
result.[1] <- char_of_int ((i lsr 16) land 0xff);
result.[2] <- char_of_int ((i lsr 8) land 0xff);
result.[3] <- char_of_int (i land 0xff);
result
let xor a b =
let n = String.length a in
assert (n = String.length b);
let result = String.create n in
for i = 0 to n-1 do
result.[i] <- char_of_int (int_of_char a.[i] lxor int_of_char b.[i])
done;
result
let pbkdf2 ~prf ~salt ~iterations ~size password =
let c = iterations - 1 in
let hLen = (prf password)#hash_size in
let result = String.create (hLen * size) in
let one_iteration i =
let u = Cryptokit.hash_string (prf password) (salt ^ int_msb i) in
let rec loop c u accu =
if c > 0 then
let u' = Cryptokit.hash_string (prf password) u in
loop (c-1) u' (xor accu u')
else accu
in loop c u u
in
for i = 1 to size do
let offset = (i-1) * hLen in
String.blit (one_iteration i) 0 result offset hLen;
done;
result
let save_to filename writer x =
let oc = open_out filename in
let ob = Bi_outbuf.create_channel_writer oc in
......
......@@ -20,7 +20,6 @@
(**************************************************************************)
val ( |> ) : 'a -> ('a -> 'b) -> 'b
val ( =% ) : Z.t -> Z.t -> bool
module Array : sig
include module type of Array
......@@ -50,17 +49,8 @@ end
val list_join : 'a -> 'a list -> 'a list
val sha256_hex : string -> string
val sha256_b64 : string -> string
val option_map : ('a -> 'b) -> 'a option -> 'b option
val pbkdf2 :
prf:(string -> Cryptokit.hash) ->
salt:string ->
iterations:int -> size:int ->
string -> string
val save_to : string -> (Bi_outbuf.t -> 'a -> unit) -> 'a -> unit
module SMap : Map.S with type key = string
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Serializable_t
open Signatures
open Common
......@@ -39,7 +40,7 @@ let check_election_public_key (type t) g e =
(** Simple monad *)
let prng = lazy (Cryptokit.Random.(pseudo_rng (string secure_rng 16)))
let prng = lazy (pseudo_rng (random_string secure_rng 16))
module MakeSimpleMonad (G : GROUP) = struct
type 'a t = unit -> 'a
......@@ -51,7 +52,7 @@ module MakeSimpleMonad (G : GROUP) = struct
let random q =
let size = Z.size q * Sys.word_size / 8 in
fun () ->
let r = Cryptokit.Random.string (Lazy.force prng) size in
let r = random_string (Lazy.force prng) size in
Z.(of_bits r mod q)
type elt = G.t ballot
......@@ -93,7 +94,7 @@ module MakeSimpleDistKeyGen (G : GROUP) (M : RANDOM) = struct
check_modulo q response &&
let commitment = g **~ response / (y **~ challenge) in
let zkp = "pok|" ^ G.to_string y ^ "|" in
challenge =% G.hash zkp [| commitment |]
Z.(challenge =% G.hash zkp [| commitment |])
let combine pks =
Array.fold_left (fun y {trustee_public_key; _} ->
......@@ -226,7 +227,7 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct
let prefix = Printf.sprintf "prove|%s|%s,%s|"
zkp (G.to_string alpha) (G.to_string beta)
in
hash prefix commitments =% !total_challenges
Z.(hash prefix commitments =% !total_challenges)
with Exit -> false
(** Ballot creation *)
......@@ -345,7 +346,7 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct
let commitment = g **~ s_response *~ y **~ s_challenge in
let prefix = make_sig_prefix zkp commitment in
let contents = make_sig_contents b.answers in
s_challenge =% G.hash prefix contents
Z.(s_challenge =% G.hash prefix contents)
in ok, zkp
| None -> true, ""
in ok &&
......@@ -383,7 +384,7 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct
g **~ response / (y **~ challenge);
alpha **~ response / (f **~ challenge);
|]
in hash zkp commitments =% challenge
in Z.(hash zkp commitments =% challenge)
) c f.decryption_factors f.decryption_proofs
type result = elt Serializable_t.result
......
......@@ -21,6 +21,7 @@
(** Election primitives *)
open Platform
open Serializable_t
open Signatures
......
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Serializable_j
open Signatures
open Common
......
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Serializable_j
open Common
......@@ -61,7 +62,7 @@ let unsafe_make group =
let ( *~ ) a b = a * b mod p
let ( **~ ) a b = powm a b p
let invert x = Z.invert x p
let ( =~ ) = Z.equal
let ( =~ ) = Z.( =% )
let check x = check_modulo p x && x **~ q =~ one
let to_string = Z.to_string
let of_string = Z.of_string
......
......@@ -21,6 +21,7 @@
(** Finite field arithmetic *)
open Platform
open Serializable_t
module type GROUP = Signatures.GROUP
......
src/platform/native/Platform
Serializable_builtin_t
Serializable_builtin_j
Serializable_t
......
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
val sha256_hex : string -> string
val sha256_b64 : string -> string
val b64_encode_compact : string -> string
val derive_cred : Uuidm.t -> string -> string
type rng
val secure_rng : rng
val pseudo_rng : string -> rng
val random_string : rng -> int -> string
module Z : sig
type t
val zero : t
val one : t
val of_int : int -> t
val of_string : string -> t
val of_string_base : int -> string -> t
val ( + ) : t -> t -> t
val ( - ) : t -> t -> t
val ( * ) : t -> t -> t
val ( mod ) : t -> t -> t
val erem : t -> t -> t
val to_int : t -> int
val to_string : t -> string
val compare : t -> t -> int
val ( =% ) : t -> t -> bool
val geq : t -> t -> bool
val lt : t -> t -> bool
val powm : t -> t -> t -> t
val invert : t -> t -> t
val probab_prime : t -> int -> int
val size : t -> int
val of_bits : string -> t
end
type datetime
val now : unit -> datetime
val string_of_datetime : datetime -> string
val datetime_of_string : string -> datetime
val datetime_compare : datetime -> datetime -> int
val format_datetime : string -> datetime -> string
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Serializable_builtin_t
(** {1 Helpers for interacting with atd-generated stuff} *)
......@@ -72,20 +73,9 @@ let uuid_of_string x =
(** {1 Serializers for type datetime} *)
open CalendarLib
let datetime_format = "%Y-%m-%d %H:%M:%S"
let write_datetime buf (n, s) =
let write_datetime buf n =
Bi_outbuf.add_char buf '"';
(match s with
| Some s -> Bi_outbuf.add_string buf s
| None ->
let n = Fcalendar.Precise.to_gmt n in
Bi_outbuf.add_string buf (Printer.Precise_Fcalendar.sprint datetime_format n);
let ts = Printf.sprintf "%.6f" (Fcalendar.Precise.to_unixfloat n) in
let i = String.index ts '.' in
Bi_outbuf.add_substring buf ts i (String.length ts - i);
);
Bi_outbuf.add_string buf (Platform.string_of_datetime n);
Bi_outbuf.add_char buf '"'
let string_of_datetime ?(len=28) n =
......@@ -94,12 +84,7 @@ let string_of_datetime ?(len=28) n =
Bi_outbuf.contents buf
let datetime_of_json = function
| `String s ->
let i = String.index s '.' in
let l = Printer.Precise_Fcalendar.from_fstring datetime_format (String.sub s 0 i) in
let l = Fcalendar.Precise.from_gmt l in
let r = float_of_string ("0" ^ String.sub s i (String.length s-i)) in
(Fcalendar.Precise.add l (Fcalendar.Precise.Period.second r), Some s)
| `String s -> Platform.datetime_of_string s
| _ -> assert false
let read_datetime state buf =
......
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Serializable_builtin_t
(** {1 Serializers for type number} *)
......
......@@ -19,9 +19,11 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
type number = Z.t
type uuid = Uuidm.t
type datetime = CalendarLib.Fcalendar.Precise.t * string option
type datetime = Platform.datetime
type int_or_null = int option
module SSet = Set.Make(String)
......
......@@ -19,9 +19,11 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
type number = Z.t
type uuid = Uuidm.t
type datetime = CalendarLib.Fcalendar.Precise.t * string option
type datetime = Platform.datetime
type int_or_null = int option
module SSet : Set.S with type elt = string
......
......@@ -21,6 +21,7 @@
(** Signatures *)
open Platform
open Serializable_t
(** Helpers for interacting with atd stuff *)
......
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
let sha256_hex x = assert false
let sha256_b64 x = assert false
let b64_encode_compact x = assert false
let derive_cred uuid x = assert false
type rng = unit -> unit
let secure_rng () = assert false
let pseudo_rng x () = assert false
let random_string rng i = assert false
module Z = struct
type t = unit -> unit
let zero () = assert false
let one () = assert false
let of_int x = assert false
let of_string x = assert false
let of_string_base b x = assert false
let ( + ) x y = assert false
let ( - ) x y = assert false
let ( * ) x y = assert false
let ( mod ) x y = assert false
let erem x y = assert false
let to_int x = assert false
let to_string x = assert false
let compare x y = assert false
let ( =% ) x y = assert false
let geq x y = assert false
let lt x y = assert false
let powm x y m = assert false
let invert x m = assert false
let probab_prime x n = assert false
let size x = assert false
let of_bits x = assert false
end
type datetime
let now () = assert false
let string_of_datetime x = assert false
let datetime_of_string x = assert false
let datetime_compare x y = assert false
let format_datetime fmt x = assert false
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
let sha256_hex x = Cryptokit.(x |>
hash_string (Hash.sha256 ()) |>
transform_string (Hexa.encode ())
)
let sha256_b64 x = Cryptokit.(x |>
hash_string (Hash.sha256 ()) |>
transform_string (Base64.encode_compact ())
)
let b64_encode_compact x =
Cryptokit.(transform_string (Base64.encode_compact ()) x)
let int_msb i =
let result = String.create 4 in
result.[0] <- char_of_int (i lsr 24);
result.[1] <- char_of_int ((i lsr 16) land 0xff);
result.[2] <- char_of_int ((i lsr 8) land 0xff);
result.[3] <- char_of_int (i land 0xff);
result
let xor a b =
let n = String.length a in
assert (n = String.length b);
let result = String.create n in
for i = 0 to n-1 do
result.[i] <- char_of_int (int_of_char a.[i] lxor int_of_char b.[i])
done;
result
let pbkdf2 ~prf ~salt ~iterations ~size password =
let c = iterations - 1 in
let hLen = (prf password)#hash_size in
let result = String.create (hLen * size) in
let one_iteration i =
let u = Cryptokit.hash_string (prf password) (salt ^ int_msb i) in
let rec loop c u accu =
if c > 0 then
let u' = Cryptokit.hash_string (prf password) u in
loop (c-1) u' (xor accu u')
else accu
in loop c u u
in
for i = 1 to size do
let offset = (i-1) * hLen in
String.blit (one_iteration i) 0 result offset hLen;
done;
result
let remove_dashes x =
let n = String.length x in
let res = Buffer.create n in
for i = 0 to n-1 do
let c = x.[i] in
if c <> '-' then Buffer.add_char res c;
done;
Buffer.contents res
let derive_cred uuid x =
let open Cryptokit in
let uuid = remove_dashes (Uuidm.to_string uuid) in
let salt = transform_string (Hexa.decode ()) uuid in
pbkdf2 ~prf:MAC.hmac_sha256 ~iterations:1000 ~size:1 ~salt x |>
transform_string (Hexa.encode ())
type rng = Cryptokit.Random.rng
let secure_rng = Cryptokit.Random.secure_rng
let pseudo_rng = Cryptokit.Random.pseudo_rng
let random_string = Cryptokit.Random.string
module Z = struct
include Z
let ( =% ) = equal
end
open CalendarLib
let datetime_format = "%Y-%m-%d %H:%M:%S"
type datetime = Fcalendar.Precise.t * string option
let now () = CalendarLib.Fcalendar.Precise.now (), None
let string_of_datetime (n, s) =
match s with
| Some s -> s
| None ->
let n = Fcalendar.Precise.to_gmt n in
let a = Printer.Precise_Fcalendar.sprint datetime_format n in
let ts = Printf.sprintf "%.6f" (Fcalendar.Precise.to_unixfloat n) in
let i = String.index ts '.' in
let b = String.sub ts i (String.length ts - i) in
a ^ b
let datetime_of_string s =
let i = String.index s '.' in
let l = Printer.Precise_Fcalendar.from_fstring datetime_format (String.sub s 0 i) in
let l = Fcalendar.Precise.from_gmt l in
let r = float_of_string ("0" ^ String.sub s i (String.length s-i)) in
(Fcalendar.Precise.add l (Fcalendar.Precise.Period.second r), Some s)
let datetime_compare (a, _) (b, _) =
CalendarLib.Fcalendar.Precise.compare a b
let format_datetime fmt (a, _) =
CalendarLib.Printer.Precise_Fcalendar.sprint fmt a
......@@ -19,25 +19,10 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Signatures
open Common
let remove_dashes x =
let n = String.length x in
let res = Buffer.create n in
for i = 0 to n-1 do
let c = x.[i] in
if c <> '-' then Buffer.add_char res c;
done;
Buffer.contents res
let do_derive uuid x =
let open Cryptokit in
let uuid = remove_dashes (Uuidm.to_string uuid) in
let salt = transform_string (Hexa.decode ()) uuid in
pbkdf2 ~prf:MAC.hmac_sha256 ~iterations:1000 ~size:1 ~salt x |>
transform_string (Hexa.encode ())
type generate_kind = Count of int | File of string
type action = Derive of string | Generate of generate_kind
......@@ -60,7 +45,7 @@ module Run (P : PARAMS) : EMPTY = struct
let n53 = Z.of_int 53
let public_key_of_token uuid x =
let hex = do_derive uuid x in
let hex = derive_cred uuid x in
let x = Z.(of_string_base 16 hex mod G.q) in
let y = G.(g **~ x) in
G.to_string y
......@@ -84,8 +69,8 @@ module Run (P : PARAMS) : EMPTY = struct
(* The generation itself *)
let prng = Cryptokit.Random.(pseudo_rng (string secure_rng 16)) in
let random_char () = int_of_char (Cryptokit.Random.string prng 1).[0] in
let prng = pseudo_rng (random_string secure_rng 16) in
let random_char () = int_of_char (random_string prng 1).[0] in
let generate_raw_token () =
let res = String.create token_length in
......@@ -180,8 +165,6 @@ module Run (P : PARAMS) : EMPTY = struct
end
let derive = do_derive
open Tool_common
let main group dir uuid count file derive =
......
val derive : Uuidm.t -> string -> string
val cmds : (unit Cmdliner.Term.t * Cmdliner.Term.info) list
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Serializable_builtin_j
open Serializable_j
open Signatures
......@@ -150,7 +151,7 @@ module Run (P : PARAMS) : EMPTY = struct
let sk =
match load_from_file (fun x -> x) privcred with
| Some [cred] ->
let hex = Tool_credgen.derive e.e_params.e_uuid cred in
let hex = derive_cred e.e_params.e_uuid cred in
Some Z.(of_string_base 16 hex mod G.q)
| _ -> failwith "invalid credential file"
in
......
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Platform
open Serializable_builtin_j
open Serializable_j
open Signatures
......
......@@ -20,6 +20,7 @@
(**************************************************************************)
open Lwt
open Platform
open Common
open Web_signatures
open Web_common
......
src/platform/native/Platform
Serializable_builtin_t
Serializable_builtin_j
Serializable_j
......
......@@ -20,6 +20,7 @@
(**************************************************************************)
open Lwt
open Platform
open Signatures
open Common
open Serializable_builtin_t
......@@ -43,13 +44,13 @@ let load_from_file read fname =
result
let make_rng = Lwt_preemptive.detach (fun () ->
Cryptokit.Random.(pseudo_rng (string secure_rng 16))
pseudo_rng (random_string secure_rng 16)
)
module type LWT_RANDOM = Signatures.RANDOM with type 'a t = 'a Lwt.t
module type LWT_RNG = sig
val rng : Cryptokit.Random.rng Lwt.t
val rng : rng Lwt.t
end
module MakeLwtRandom (X : LWT_RNG) = struct
......@@ -62,7 +63,7 @@ module MakeLwtRandom (X : LWT_RNG) = struct
let random q =
let size = Z.size q * Sys.word_size / 8 in
lwt rng = X.rng in
let r = Cryptokit.Random.string rng size in
let r = random_string rng size in
return Z.(of_bits r mod q)
end
......@@ -117,7 +118,7 @@ let security_log s =
| None -> return ()
| Some ic -> Lwt_io.atomic (fun ic ->