Commit 86b59f11 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Add a setup mode for elections

parent 0595675f
......@@ -201,3 +201,44 @@ let string_of_election_file = function
let election_file = Eliom_parameter.user_type
~of_string:election_file_of_string
~to_string:string_of_election_file
let uuid_of_string x =
match Uuidm.of_string x with
| Some x -> x
| None -> Printf.ksprintf invalid_arg "invalid UUID [%s]" x
let uuid =
let of_string x = uuid_of_string x
and to_string x = Uuidm.to_string x
in Eliom_parameter.user_type ~of_string ~to_string
type setup_election = {
mutable se_owner : user;
mutable se_group : string;
mutable se_questions : template;
mutable se_public_keys : (string * string ref) list;
mutable se_metadata : metadata;
mutable se_public_creds : string;
}
let b58_digits = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
let token_length = 14
let prng = lazy (pseudo_rng (random_string secure_rng 16))
let random_char () =
lwt rng =
if Lazy.is_val prng then return (Lazy.force prng) else
Lwt_preemptive.detach (fun () -> Lazy.force prng) ()
in
return (int_of_char (random_string rng 1).[0])
let generate_token () =
let res = String.create token_length in
let rec loop i =
if i < token_length then (
lwt digit = random_char () in
let digit = digit mod 58 in
res.[i] <- b58_digits.[digit];
loop (i+1)
) else return res
in loop 0
......@@ -85,3 +85,22 @@ val election_file :
(election_file, [ `WithoutSuffix ],
[ `One of election_file ] Eliom_parameter.param_name)
Eliom_parameter.params_type
val uuid_of_string : string -> Uuidm.t
val uuid :
string ->
(Uuidm.t, [ `WithoutSuffix ],
[ `One of Uuidm.t ] Eliom_parameter.param_name)
Eliom_parameter.params_type
type setup_election = {
mutable se_owner : user;
mutable se_group : string;
mutable se_questions : template;
mutable se_public_keys : (string * string ref) list;
mutable se_metadata : metadata;
mutable se_public_creds : string;
}
val generate_token : unit -> string Lwt.t
......@@ -125,6 +125,151 @@ module type CORE_SERVICES = sig
[< Eliom_service.registrable > `Unregistrable ], 'a)
Eliom_service.service
val election_setup_index :
(unit, unit,
[> `Attached of
([> `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ], unit, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_new :
(unit, unit,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ], unit, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup :
(Uuidm.t, unit,
[> `Attached of
([> `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of Uuidm.t ] Eliom_parameter.param_name, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_group :
(Uuidm.t, string,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of Uuidm.t ] Eliom_parameter.param_name,
[ `One of string ] Eliom_parameter.param_name,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_metadata :
(Uuidm.t, string,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of Uuidm.t ] Eliom_parameter.param_name,
[ `One of string ] Eliom_parameter.param_name,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_questions :
(Uuidm.t, string,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of Uuidm.t ] Eliom_parameter.param_name,
[ `One of string ] Eliom_parameter.param_name,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_trustee_add :
(Uuidm.t, unit,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of Uuidm.t ] Eliom_parameter.param_name,
unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_credentials :
(string, unit,
[> `Attached of
([> `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of string ] Eliom_parameter.param_name, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_credentials_download :
(string, unit,
[> `Attached of
([> `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of string ] Eliom_parameter.param_name, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_credentials_post :
(string, string,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of string ] Eliom_parameter.param_name,
[ `One of string ] Eliom_parameter.param_name,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_credentials_post_file :
(string, Eliom_lib.file_info,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of string ] Eliom_parameter.param_name,
[ `One of Eliom_lib.file_info ] Eliom_parameter.param_name,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_trustee :
(string, unit,
[> `Attached of
([> `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of string ] Eliom_parameter.param_name, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_trustee_post :
(string, string,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of string ] Eliom_parameter.param_name,
[ `One of string ] Eliom_parameter.param_name,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val election_setup_create :
(Uuidm.t, unit,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ],
[ `One of Uuidm.t ] Eliom_parameter.param_name, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
end
module type ELECTION_SERVICES = sig
......@@ -388,6 +533,24 @@ module type TEMPLATES = sig
[ `Exists | `Exception of exn ] ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val generic_error_page :
string -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_index :
Uuidm.t list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup :
Uuidm.t -> Web_common.setup_election -> unit ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_credentials :
string -> string -> Web_common.setup_election -> unit ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_setup_trustee :
string -> string -> Web_common.setup_election -> unit ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
module Login (S : AUTH_SERVICES) : LOGIN_TEMPLATES
module Election (W : WEB_ELECTION_RO) : ELECTION_TEMPLATES
......
......@@ -73,6 +73,15 @@ module Make (C : CONFIG) : SITE = struct
(* Persistent table, used to initialize the server. *)
let election_ptable = Ocsipersist.open_table (C.name ^ "_elections")
(* Table with elections in setup mode. *)
let election_stable = Ocsipersist.open_table (C.name ^ "_setup")
(* Table with tokens given to trustees. *)
let election_pktokens = Ocsipersist.open_table (C.name ^ "_pktokens")
(* Table with tokens given to credential authorities. *)
let election_credtokens = Ocsipersist.open_table (C.name ^ "_credtokens")
(* In-memory table, indexed by UUID, contains closures. *)
let election_table = ref SMap.empty
......@@ -134,6 +143,80 @@ module Make (C : CONFIG) : SITE = struct
let tool =
preapply (static_dir ()) ["tool"; "belenios-tool.html"]
let election_setup_index = service
~path:(make_path ["setup"; ""])
~get_params:unit
()
let election_setup_new = post_coservice
~csrf_safe:true
~fallback:election_setup_index
~post_params:unit
()
let election_setup = service
~path:(make_path ["setup"; "election"])
~get_params:(uuid "uuid")
()
let election_setup_group = post_coservice
~fallback:election_setup
~post_params:(string "group")
()
let election_setup_metadata = post_coservice
~fallback:election_setup
~post_params:(string "metadata")
()
let election_setup_questions = post_coservice
~fallback:election_setup
~post_params:(string "questions")
()
let election_setup_trustee_add = post_coservice
~fallback:election_setup
~post_params:unit
()
let election_setup_credentials = service
~path:(make_path ["setup"; "credentials"])
~get_params:(string "token")
()
let election_setup_credentials_download =
service
~path:(make_path ["setup"; "public_creds.txt"])
~get_params:(string "token")
()
let election_setup_credentials_post = post_coservice
~fallback:election_setup_credentials
~post_params:(string "public_creds")
()
let election_setup_credentials_post_file = post_coservice
~fallback:election_setup_credentials
~post_params:(file "public_creds")
()
let election_setup_trustee = service
~path:(make_path ["setup"; "trustee"])
~get_params:(string "token")
()
let election_setup_trustee_post = post_coservice
~fallback:election_setup_trustee
~post_params:(string "public_key")
()
let election_setup_create =
post_coservice
~csrf_safe:true
~fallback:election_setup
~post_params:unit
()
let cont = Eliom_reference.eref ~scope
(fun () () -> Eliom_registration.Redirection.send home)
......@@ -406,4 +489,333 @@ module Make (C : CONFIG) : SITE = struct
| None -> forbidden ()
)
let generate_uuid = Uuidm.v4_gen (Random.State.make_self_init ())
let () = Html5.register ~service:election_setup_index
(fun () () ->
match_lwt S.get_user () with
| Some u ->
lwt uuids =
Ocsipersist.fold_step (fun k v accu ->
if v.se_owner = u
then return (uuid_of_string k :: accu)
else return accu
) election_stable []
in T.election_setup_index uuids ()
| None -> forbidden ()
)
let () = Redirection.register ~service:election_setup_new
(fun () () ->
match_lwt S.get_user () with
| Some u ->
let uuid = generate_uuid () in
let uuid_s = Uuidm.to_string uuid in
lwt token = generate_token () in
let se_metadata = {
e_voting_starts_at = None;
e_voting_ends_at = None;
e_readers = Some `Any;
e_voters = Some `Any;
e_owner = Some u;
e_auth_config = Some [{auth_system = "dummy"; auth_instance = "demo"; auth_config = []}];
} in
let question = {
q_answers = [| "Answer 1"; "Answer 2" |];
q_min = 0;
q_max = 1;
q_question = "Question 1?";
} in
let se_questions = {
t_description = "Description of the election.";
t_name = "Name of the election";
t_questions = [| question |];
t_short_name = "short_name";
} in
let se = {
se_owner = u;
se_group = "{\"g\":\"14887492224963187634282421537186040801304008017743492304481737382571933937568724473847106029915040150784031882206090286938661464458896494215273989547889201144857352611058572236578734319505128042602372864570426550855201448111746579871811249114781674309062693442442368697449970648232621880001709535143047913661432883287150003429802392229361583608686643243349727791976247247948618930423866180410558458272606627111270040091203073580238905303994472202930783207472394578498507764703191288249547659899997131166130259700604433891232298182348403175947450284433411265966789131024573629546048637848902243503970966798589660808533\",\"p\":\"16328632084933010002384055033805457329601614771185955389739167309086214800406465799038583634953752941675645562182498120750264980492381375579367675648771293800310370964745767014243638518442553823973482995267304044326777047662957480269391322789378384619428596446446984694306187644767462460965622580087564339212631775817895958409016676398975671266179637898557687317076177218843233150695157881061257053019133078545928983562221396313169622475509818442661047018436264806901023966236718367204710755935899013750306107738002364137917426595737403871114187750804346564731250609196846638183903982387884578266136503697493474682071\",\"q\":\"61329566248342901292543872769978950870633559608669337131139375508370458778917\"}";
se_questions;
se_public_keys = [];
se_metadata;
se_public_creds = token;
} in
lwt () = Ocsipersist.add election_stable uuid_s se in
lwt () = Ocsipersist.add election_credtokens token uuid_s in
return (preapply election_setup uuid)
| None -> forbidden ()
)
let () = Html5.register ~service:election_setup
(fun uuid () ->
match_lwt S.get_user () with
| Some u ->
let uuid_s = Uuidm.to_string uuid in
lwt se = Ocsipersist.find election_stable uuid_s in
if se.se_owner = u
then T.election_setup uuid se ()
else forbidden ()
| None -> forbidden ()
)
let election_setup_mutex = Lwt_mutex.create ()
let handle_setup f uuid x =
match_lwt S.get_user () with
| Some u ->
let uuid_s = Uuidm.to_string uuid in
Lwt_mutex.with_lock election_setup_mutex (fun () ->
lwt se = Ocsipersist.find election_stable uuid_s in
if se.se_owner = u then (
try_lwt
f se x u;
Ocsipersist.add election_stable uuid_s se >>
Redirection.send (preapply election_setup uuid)
with e ->
T.generic_error_page (Printexc.to_string e) () >>= Html5.send
) else forbidden ()
)
| None -> forbidden ()
let () =
Any.register
~service:election_setup_group
(handle_setup
(fun se x _ ->
let _group = Group.of_string x in
(* we keep it as a string since it contains a type *)
se.se_group <- x))
let () =
Any.register
~service:election_setup_metadata
(handle_setup
(fun se x u ->
let metadata = metadata_of_string x in
if metadata.e_owner <> Some u then failwith "wrong owner";
se.se_metadata <- metadata))
let () =
Any.register
~service:election_setup_questions
(handle_setup
(fun se x _ ->
se.se_questions <- template_of_string x))
let () =
Redirection.register
~service:election_setup_trustee_add
(fun uuid () ->
match_lwt S.get_user () with
| Some u ->
let uuid_s = Uuidm.to_string uuid in
Lwt_mutex.with_lock election_setup_mutex (fun () ->
lwt se = Ocsipersist.find election_stable uuid_s in
if se.se_owner = u
then (
lwt token = generate_token () in
se.se_public_keys <- (token, ref "") :: se.se_public_keys;
Ocsipersist.add election_stable uuid_s se >>
Ocsipersist.add election_pktokens token uuid_s
) else forbidden ()
) >>
return (preapply election_setup uuid)
| None -> forbidden ()
)
let () =
Html5.register
~service:election_setup_credentials
(fun token () ->
lwt uuid = Ocsipersist.find election_credtokens token in
lwt se = Ocsipersist.find election_stable uuid in
T.election_setup_credentials token uuid se ()
)
let () =
File.register
~service:election_setup_credentials_download
~content_type:"text/plain"
(fun token () ->
lwt uuid = Ocsipersist.find election_credtokens token in
return (C.spool_dir / uuid ^ ".public_creds.txt")
)
let wrap_handler f =
try_lwt f ()
with
| e -> T.generic_error_page (Printexc.to_string e) () >>= Html5.send
let handle_credentials_post token creds =
lwt uuid = Ocsipersist.find election_credtokens token in
lwt se = Ocsipersist.find election_stable uuid in
let module G = (val Group.of_string se.se_group : GROUP) in
let fname = C.spool_dir / uuid ^ ".public_creds.txt" in
Lwt_mutex.with_lock
election_setup_mutex
(fun () ->
Lwt_io.with_file
~flags:(Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC]))
~perm:0o600 ~mode:Lwt_io.Output fname
(fun oc -> Lwt_io.write_chars oc creds)
) >>
lwt () =
let i = ref 1 in
Lwt_stream.iter
(fun x ->
try
let x = G.of_string x in
if not (G.check x) then raise Exit;
incr i
with _ ->
Printf.ksprintf failwith "invalid credential at line %d" !i)
(Lwt_io.lines_of_file fname)
in
Redirection.send (preapply election_setup_credentials token)
let () =
Any.register
~service:election_setup_credentials_post
(fun token creds ->
let s = Lwt_stream.of_string creds in
wrap_handler (fun () -> handle_credentials_post token s))
let () =
Any.register
~service:election_setup_credentials_post_file
(fun token creds ->
let s = Lwt_io.chars_of_file creds.Ocsigen_extensions.tmp_filename in
wrap_handler (fun () -> handle_credentials_post token s))
let () =
Html5.register
~service:election_setup_trustee
(fun token () ->
lwt uuid = Ocsipersist.find election_pktokens token in
lwt se = Ocsipersist.find election_stable uuid in
T.election_setup_trustee token uuid se ()
)
let () =
Any.register
~service:election_setup_trustee_post
(fun token public_key ->
wrap_handler
(fun () ->
lwt uuid = Ocsipersist.find election_pktokens token in
Lwt_mutex.with_lock
election_setup_mutex
(fun () ->
lwt se = Ocsipersist.find election_stable uuid in
let pkref = List.assoc token se.se_public_keys in
let module G = (val Group.of_string se.se_group : GROUP) in
let pk = trustee_public_key_of_string G.read public_key in
let module KG = Election.MakeSimpleDistKeyGen (G) (LwtRandom) in
if not (KG.check pk) then failwith "invalid public key";
(* we keep pk as a string because of G.t *)
pkref := public_key;
Ocsipersist.add election_stable uuid se
) >> Redirection.send (preapply election_setup_trustee token)
)
)
let () =
Any.register
~service:election_setup_create
(fun uuid () ->
match_lwt S.get_user () with
| None -> forbidden ()
| Some u ->
begin try_lwt
let uuid_s = Uuidm.to_string uuid in
Lwt_mutex.with_lock election_setup_mutex (fun () ->
lwt se = Ocsipersist.find election_stable uuid_s in
if se.se_owner <> u then forbidden () else
let group = Group.of_string se.se_group in
let module G = (val group : GROUP) in
let module M = Election.MakeSimpleMonad (G) in
(* FIXME: KG does not actually need M here *)
let module KG = Election.MakeSimpleDistKeyGen (G) (M) in
(* construct election data in memory *)
let () =
match se.se_public_keys with
| [] -> failwith "trustee public keys are missing"
| _ :: _ -> ()
in
let public_keys =
List.map
(fun (_, r) ->
if !r = "" then failwith "some public keys are missing";
trustee_public_key_of_string G.read !r
) se.se_public_keys
in