Commit f623971b authored by Stephane Glondu's avatar Stephane Glondu

Fix numerous warnings

parent 099da35d
...@@ -3,3 +3,6 @@ ...@@ -3,3 +3,6 @@
<src/web/*.{ml,mli,byte,native,odoc}>: thread, package(eliom.server), syntax(camlp4o), package(lwt.syntax), package(csv) <src/web/*.{ml,mli,byte,native,odoc}>: thread, package(eliom.server), syntax(camlp4o), package(lwt.syntax), package(csv)
<src/tool/tool_cmdline.*>: package(zarith), package(calendar), package(cryptokit), package(cmdliner), use_platform-native <src/tool/tool_cmdline.*>: package(zarith), package(calendar), package(cryptokit), package(cmdliner), use_platform-native
<src/tool/tool_js*> or <src/platform/js/*> or <src/booth/*>: package(js_of_ocaml), syntax(camlp4o), package(js_of_ocaml.syntax), package(lwt.syntax), use_platform-js <src/tool/tool_js*> or <src/platform/js/*> or <src/booth/*>: package(js_of_ocaml), syntax(camlp4o), package(js_of_ocaml.syntax), package(lwt.syntax), use_platform-js
<**/*serializable_j.ml>: warn(-32)
true: warn(A-3-6-44-48)
...@@ -346,7 +346,7 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct ...@@ -346,7 +346,7 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct
type factor = elt partial_decryption type factor = elt partial_decryption
let eg_factor x {alpha; beta} = let eg_factor x {alpha; _} =
let zkp = "decrypt|" ^ G.to_string (g **~ x) ^ "|" in let zkp = "decrypt|" ^ G.to_string (g **~ x) ^ "|" in
alpha **~ x, alpha **~ x,
fs_prove [| g; alpha |] x (hash zkp) fs_prove [| g; alpha |] x (hash zkp)
...@@ -404,8 +404,8 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct ...@@ -404,8 +404,8 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct
let result = Array.mmap log results in let result = Array.mmap log results in
{num_tallied; encrypted_tally; partial_decryptions; result} {num_tallied; encrypted_tally; partial_decryptions; result}
let check_result e pks r = let check_result pks r =
let {encrypted_tally; partial_decryptions; result; num_tallied} = r in let {encrypted_tally; partial_decryptions; result; _} = r in
check_ciphertext encrypted_tally && check_ciphertext encrypted_tally &&
Array.forall2 (check_factor encrypted_tally) pks partial_decryptions && Array.forall2 (check_factor encrypted_tally) pks partial_decryptions &&
let dummy = Array.mmap (fun _ -> G.one) encrypted_tally in let dummy = Array.mmap (fun _ -> G.one) encrypted_tally in
...@@ -415,7 +415,7 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct ...@@ -415,7 +415,7 @@ module MakeElection (G : GROUP) (M : RANDOM) = struct
let results = Array.mmap2 (fun {beta; _} f -> let results = Array.mmap2 (fun {beta; _} f ->
beta / f beta / f
) encrypted_tally factors in ) encrypted_tally factors in
Array.fforall2 (fun r1 r2 -> r1 =~ g **~ Z.of_int r2) results r.result Array.fforall2 (fun r1 r2 -> r1 =~ g **~ Z.of_int r2) results result
let extract_tally r = r.result let extract_tally r = r.result
end end
...@@ -22,7 +22,6 @@ ...@@ -22,7 +22,6 @@
open Platform open Platform
open Serializable_j open Serializable_j
open Signatures open Signatures
open Common
(** Generic group parsing *) (** Generic group parsing *)
......
...@@ -19,7 +19,6 @@ ...@@ -19,7 +19,6 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Platform
open Serializable_builtin_t open Serializable_builtin_t
(** {1 Serializers for type number} *) (** {1 Serializers for type number} *)
......
...@@ -228,7 +228,7 @@ module type ELECTION = sig ...@@ -228,7 +228,7 @@ module type ELECTION = sig
produce the election result. The first argument is the number of produce the election result. The first argument is the number of
tallied ballots. May raise [Invalid_argument]. *) tallied ballots. May raise [Invalid_argument]. *)
val check_result : t -> public_key array -> result -> bool val check_result : public_key array -> result -> bool
val extract_tally : result -> plaintext val extract_tally : result -> plaintext
(** Extract the plaintext result of the election. *) (** Extract the plaintext result of the election. *)
......
...@@ -38,7 +38,7 @@ let sha256_b64 x = ...@@ -38,7 +38,7 @@ let sha256_b64 x =
| Some i -> String.sub raw 0 i | Some i -> String.sub raw 0 i
| None -> raw | None -> raw
let b64_encode_compact x = assert false let b64_encode_compact _ = assert false
let remove_dashes x = let remove_dashes x =
let n = String.length x in let n = String.length x in
...@@ -71,7 +71,7 @@ let sjcl_random = Js.Unsafe.get sjcl "random" ...@@ -71,7 +71,7 @@ let sjcl_random = Js.Unsafe.get sjcl "random"
(* PRNG is initialized in random.js *) (* PRNG is initialized in random.js *)
let secure_rng () = () let secure_rng () = ()
let pseudo_rng x () = () let pseudo_rng _ () = ()
let string_of_hex hex n = let string_of_hex hex n =
let res = String.create n in let res = String.create n in
...@@ -127,7 +127,7 @@ module Z = struct ...@@ -127,7 +127,7 @@ module Z = struct
if lt r zero then r + y else r if lt r zero then r + y else r
let probab_prime x n = let probab_prime x n =
meth_call x "isProbablePrime" [| |] |> meth_call x "isProbablePrime" [| n |> float_of_int |> Js.number_of_float |> inject |] |>
Js.float_of_number |> int_of_float Js.float_of_number |> int_of_float
let z256 = of_int 256 let z256 = of_int 256
...@@ -143,7 +143,7 @@ end ...@@ -143,7 +143,7 @@ end
type datetime type datetime
let now () = assert false let now () = assert false
let string_of_datetime x = assert false let string_of_datetime _ = assert false
let datetime_of_string x = assert false let datetime_of_string _ = assert false
let datetime_compare x y = assert false let datetime_compare _ _ = assert false
let format_datetime fmt x = assert false let format_datetime _ _ = assert false
...@@ -365,22 +365,6 @@ module Mkelection : CMDLINER_MODULE = struct ...@@ -365,22 +365,6 @@ module Mkelection : CMDLINER_MODULE = struct
close_out oc close_out oc
) )
let template_c =
(fun fname ->
if Sys.file_exists fname then (
try
let ic = open_in fname in
let ls = Yojson.init_lexer () in
let lb = Lexing.from_channel ic in
let r = read_template ls lb in
close_in ic;
`Ok (fname, r)
with e ->
let e = Printexc.to_string e and s = Printf.sprintf in
`Error (s "could not read template from %s (%s)" fname e)
) else `Error (Printf.sprintf "file %s does not exist" fname)
), (fun fmt (fname, _) -> Format.pp_print_string fmt fname)
let template_t = let template_t =
let doc = "Read election template from file $(docv)." in let doc = "Read election template from file $(docv)." in
Arg.(value & opt (some file) None & info ["template"] ~docv:"TEMPLATE" ~doc) Arg.(value & opt (some file) None & info ["template"] ~docv:"TEMPLATE" ~doc)
......
...@@ -19,9 +19,7 @@ ...@@ -19,9 +19,7 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Printf
open Platform open Platform
open Serializable_builtin_j
open Serializable_j open Serializable_j
open Signatures open Signatures
open Common open Common
...@@ -166,7 +164,7 @@ module Make (P : PARSED_PARAMS) : S = struct ...@@ -166,7 +164,7 @@ module Make (P : PARSED_PARAMS) : S = struct
let tally = Lazy.force encrypted_tally in let tally = Lazy.force encrypted_tally in
assert (Array.forall2 (E.check_factor tally) pks factors); assert (Array.forall2 (E.check_factor tally) pks factors);
let result = E.combine_factors (M.cardinal ()) tally factors in let result = E.combine_factors (M.cardinal ()) tally factors in
assert (E.check_result election pks result); assert (E.check_result pks result);
string_of_result G.write result string_of_result G.write result
let verify () = let verify () =
...@@ -176,7 +174,7 @@ module Make (P : PARSED_PARAMS) : S = struct ...@@ -176,7 +174,7 @@ module Make (P : PARSED_PARAMS) : S = struct
); );
(match get_result () with (match get_result () with
| Some result -> | Some result ->
assert (E.check_result election pks (result_of_string G.read result)) assert (E.check_result pks (result_of_string G.read result))
| None -> print_msg "W: no result to check" | None -> print_msg "W: no result to check"
); );
print_msg "I: all checks passed" print_msg "I: all checks passed"
......
...@@ -19,8 +19,6 @@ ...@@ -19,8 +19,6 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Platform
open Serializable_j
open Tool_js_common open Tool_js_common
open Tool_credgen open Tool_credgen
......
...@@ -19,10 +19,8 @@ ...@@ -19,10 +19,8 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Platform
open Serializable_j open Serializable_j
open Tool_js_common open Tool_js_common
open Tool_credgen
let (>>=) = Js.Opt.bind let (>>=) = Js.Opt.bind
let return = Js.Opt.return let return = Js.Opt.return
...@@ -132,7 +130,7 @@ let createQuestion q = ...@@ -132,7 +130,7 @@ let createQuestion q =
let x = Dom_html.createDiv document in let x = Dom_html.createDiv document in
let b = Dom_html.createButton document in let b = Dom_html.createButton document in
let t = document##createTextNode (Js.string "Add an answer") in let t = document##createTextNode (Js.string "Add an answer") in
let f e = let f _ =
let x = createAnswer "" in let x = createAnswer "" in
Dom.appendChild h_answers x Dom.appendChild h_answers x
in in
...@@ -141,7 +139,7 @@ let createQuestion q = ...@@ -141,7 +139,7 @@ let createQuestion q =
Dom.appendChild x b; Dom.appendChild x b;
let b = Dom_html.createButton document in let b = Dom_html.createButton document in
let t = document##createTextNode (Js.string "Remove last answer") in let t = document##createTextNode (Js.string "Remove last answer") in
let f e = let f _ =
let answers = h_answers##querySelectorAll (Js.string ".question_answer") in let answers = h_answers##querySelectorAll (Js.string ".question_answer") in
let last_answer = answers##item (answers##length - 1) in let last_answer = answers##item (answers##length - 1) in
last_answer >>= fun x -> last_answer >>= fun x ->
...@@ -212,7 +210,7 @@ let createTemplate template = ...@@ -212,7 +210,7 @@ let createTemplate template =
let x = Dom_html.createDiv document in let x = Dom_html.createDiv document in
let b = Dom_html.createButton document in let b = Dom_html.createButton document in
let t = document##createTextNode (Js.string "Add a question") in let t = document##createTextNode (Js.string "Add a question") in
let f e = let f _ =
let x = createQuestion {q_question=""; q_min=0; q_max=1; q_answers=[||]} in let x = createQuestion {q_question=""; q_min=0; q_max=1; q_answers=[||]} in
Dom.appendChild h_questions_div x Dom.appendChild h_questions_div x
in in
...@@ -221,7 +219,7 @@ let createTemplate template = ...@@ -221,7 +219,7 @@ let createTemplate template =
Dom.appendChild x b; Dom.appendChild x b;
let b = Dom_html.createButton document in let b = Dom_html.createButton document in
let t = document##createTextNode (Js.string "Remove last question") in let t = document##createTextNode (Js.string "Remove last question") in
let f e = let f _ =
let questions = h_questions_div##querySelectorAll (Js.string ".question_question") in let questions = h_questions_div##querySelectorAll (Js.string ".question_question") in
let last_question = questions##item (questions##length - 1) in let last_question = questions##item (questions##length - 1) in
last_question >>= fun x -> last_question >>= fun x ->
...@@ -241,7 +239,7 @@ let createTemplate template = ...@@ -241,7 +239,7 @@ let createTemplate template =
let x = Dom_html.createDiv document in let x = Dom_html.createDiv document in
let b = Dom_html.createButton document in let b = Dom_html.createButton document in
let t = document##createTextNode (Js.string "Submit") in let t = document##createTextNode (Js.string "Submit") in
let f e = let f _ =
try try
let template = extractTemplate () in let template = extractTemplate () in
set_textarea "questions" (string_of_template template); set_textarea "questions" (string_of_template template);
......
...@@ -19,8 +19,6 @@ ...@@ -19,8 +19,6 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Platform
open Serializable_j
open Tool_js_common open Tool_js_common
open Tool_tkeygen open Tool_tkeygen
......
...@@ -19,7 +19,6 @@ ...@@ -19,7 +19,6 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Serializable_builtin_j
open Serializable_j open Serializable_j
open Signatures open Signatures
open Common open Common
......
...@@ -20,7 +20,6 @@ ...@@ -20,7 +20,6 @@
(**************************************************************************) (**************************************************************************)
open Platform open Platform
open Serializable_builtin_j
open Serializable_j open Serializable_j
open Signatures open Signatures
open Common open Common
......
...@@ -21,30 +21,13 @@ ...@@ -21,30 +21,13 @@
open Lwt open Lwt
open Platform open Platform
open Signatures
open Common open Common
open Serializable_builtin_t
open Serializable_builtin_j open Serializable_builtin_j
open Serializable_t open Serializable_t
open Web_serializable_t open Web_serializable_t
let spool_dir = ref "." let spool_dir = ref "."
let enforce_single_element s =
let open Lwt_stream in
lwt t = next s in
lwt b = is_empty s in
(assert_lwt b) >>
Lwt.return t
let load_from_file read fname =
let i = open_in fname in
let buf = Lexing.from_channel i in
let lex = Yojson.init_lexer ~fname () in
let result = read lex buf in
close_in i;
result
let make_rng = Lwt_preemptive.detach (fun () -> let make_rng = Lwt_preemptive.detach (fun () ->
pseudo_rng (random_string secure_rng 16) pseudo_rng (random_string secure_rng 16)
) )
...@@ -150,12 +133,6 @@ let set_rewrite_prefix ~src ~dst = ...@@ -150,12 +133,6 @@ let set_rewrite_prefix ~src ~dst =
else x else x
in rewrite_fun := f in rewrite_fun := f
let uuid = Eliom_parameter.user_type
~of_string:(fun x -> match Uuidm.of_string x with
| Some x -> x
| None -> invalid_arg "uuid")
~to_string:Uuidm.to_string
type election_file = type election_file =
| ESRaw | ESRaw
| ESKeys | ESKeys
......
...@@ -19,7 +19,6 @@ ...@@ -19,7 +19,6 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Serializable_builtin_t
open Serializable_t open Serializable_t
open Web_serializable_t open Web_serializable_t
......
...@@ -21,14 +21,12 @@ ...@@ -21,14 +21,12 @@
open Lwt open Lwt
open Platform open Platform
open Serializable_builtin_t
open Serializable_j open Serializable_j
open Signatures open Signatures
open Common open Common
open Web_serializable_t open Web_serializable_t
open Web_signatures open Web_signatures
open Web_common open Web_common
open Web_services
let ( / ) = Filename.concat let ( / ) = Filename.concat
......
...@@ -19,10 +19,7 @@ ...@@ -19,10 +19,7 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Serializable_builtin_t
open Serializable_t
open Signatures open Signatures
open Web_serializable_t
open Web_signatures open Web_signatures
module Make (D : WEB_ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELECTION module Make (D : WEB_ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELECTION
...@@ -20,8 +20,6 @@ ...@@ -20,8 +20,6 @@
(**************************************************************************) (**************************************************************************)
open Lwt open Lwt
open Serializable_t
open Signatures
open Common open Common
open Web_serializable_j open Web_serializable_j
open Web_signatures open Web_signatures
...@@ -40,7 +38,6 @@ let () = CalendarLib.Time_Zone.(change Local) ...@@ -40,7 +38,6 @@ let () = CalendarLib.Time_Zone.(change Local)
let spool_dir = ref None let spool_dir = ref None
let import_dirs = ref [] let import_dirs = ref []
let source_file = ref None let source_file = ref None
let main_election_uuid = ref None
let auth_instances = ref [] let auth_instances = ref []
let () = let () =
...@@ -127,7 +124,7 @@ lwt () = ...@@ -127,7 +124,7 @@ lwt () =
); return () ); return ()
| Some w -> | Some w ->
let module W = (val w : REGISTRABLE_ELECTION) in let module W = (val w : REGISTRABLE_ELECTION) in
lwt w = W.register () in lwt _ = W.register () in
return () return ()
) )
) !import_dirs ) !import_dirs
...@@ -20,7 +20,6 @@ ...@@ -20,7 +20,6 @@
(**************************************************************************) (**************************************************************************)
open Lwt open Lwt
open Serializable_builtin_j
open Serializable_j open Serializable_j
open Common open Common
open Web_serializable_j open Web_serializable_j
......
...@@ -23,7 +23,6 @@ open Eliom_service ...@@ -23,7 +23,6 @@ open Eliom_service
open Eliom_service.Http open Eliom_service.Http
open Eliom_parameter open Eliom_parameter
open Web_common open Web_common
open Web_signatures
let home = service ~path:[""] ~get_params:unit () let home = service ~path:[""] ~get_params:unit ()
let admin = service ~path:["admin"] ~get_params:unit () let admin = service ~path:["admin"] ~get_params:unit ()
......
...@@ -19,10 +19,7 @@ ...@@ -19,10 +19,7 @@
(* <http://www.gnu.org/licenses/>. *) (* <http://www.gnu.org/licenses/>. *)
(**************************************************************************) (**************************************************************************)
open Serializable_builtin_t
open Serializable_t
open Signatures open Signatures
open Common
open Web_serializable_t open Web_serializable_t
module type AUTH_SERVICES = sig module type AUTH_SERVICES = sig
......
...@@ -103,7 +103,7 @@ let find_election = ...@@ -103,7 +103,7 @@ let find_election =
let cache = new WCache.cache raw_find_election 100 in let cache = new WCache.cache raw_find_election 100 in
fun x -> cache#find x fun x -> cache#find x
let dump_passwords dir table uuid = let dump_passwords dir table =
Lwt_io.(with_file Output (dir / "passwords.csv") (fun oc -> Lwt_io.(with_file Output (dir / "passwords.csv") (fun oc ->
Ocsipersist.iter_step (fun voter (salt, hashed) -> Ocsipersist.iter_step (fun voter (salt, hashed) ->
write_line oc (voter ^ "," ^ salt ^ "," ^ hashed) write_line oc (voter ^ "," ^ salt ^ "," ^ hashed)
...@@ -229,7 +229,7 @@ let import_election f = ...@@ -229,7 +229,7 @@ let import_election f =
let table = "password_" ^ underscorize uuid in let table = "password_" ^ underscorize uuid in
let table = Ocsipersist.open_table table in let table = Ocsipersist.open_table table in
lwt size = Ocsipersist.length table in lwt size = Ocsipersist.length table in
if size > 0 then dump_passwords dir table uuid else return_unit if size > 0 then dump_passwords dir table else return_unit
) >> ) >>
let () = Lwt_mutex.unlock registration_mutex in let () = Lwt_mutex.unlock registration_mutex in
return (module W : WEB_ELECTION) return (module W : WEB_ELECTION)
...@@ -558,7 +558,7 @@ let () = ...@@ -558,7 +558,7 @@ let () =
let () = let () =
Any.register Any.register
~service:election_regenpwd ~service:election_regenpwd
(fun (uuid, ()) user -> (fun (uuid, ()) () ->
T.regenpwd uuid () >>= Html5.send) T.regenpwd uuid () >>= Html5.send)
let () = let () =
...@@ -581,7 +581,7 @@ let () = ...@@ -581,7 +581,7 @@ let () =
begin try_lwt begin try_lwt
lwt _ = Ocsipersist.find table user in lwt _ = Ocsipersist.find table user in
generate_password table title url user >>