Commit ca6a6511 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Fix indentation in Web_site

parent eea75e7d
......@@ -58,795 +58,795 @@ let delete_shallow_directory dir =
in
Lwt_unix.rmdir dir
open Eliom_service
open Eliom_registration
module LwtRandom = MakeLwtRandom (struct let rng = make_rng () end)
let store = Ocsipersist.open_store "site"
(* Persistent table, used to initialize the server. *)
let election_ptable = Ocsipersist.open_table "site_elections"
(* Table with elections in setup mode. *)
let election_stable = Ocsipersist.open_table "site_setup"
(* Table with tokens given to trustees. *)
let election_pktokens = Ocsipersist.open_table "site_pktokens"
(* Table with tokens given to credential authorities. *)
let election_credtokens = Ocsipersist.open_table "site_credtokens"
(* In-memory table, indexed by UUID, contains closures. *)
let election_table = ref SMap.empty
lwt main_election =
Ocsipersist.make_persistent store "main_election" None
lwt featured =
Ocsipersist.make_persistent store "featured_elections" []
(* The following reference is there to cut a dependency loop:
S.register_election depends on S (via Templates). It will be set
to a proper value once we have called Templates.Make. *)
let import_election_ref = ref (fun _ -> assert false)
(* Forward reference *)
let install_authentication_ref = ref (fun _ -> assert false)
include Web_site_auth
let import_election f = !import_election_ref f
let add_featured_election x =
lwt the_featured = Ocsipersist.get featured in
if List.mem x the_featured then (
return ()
) else if SMap.mem x !election_table then (
Ocsipersist.set featured (x :: the_featured)
) else (
Lwt.fail Not_found
)
let remove_featured_election x =
lwt the_featured = Ocsipersist.get featured in
Ocsipersist.set featured (list_remove x the_featured)
let is_featured_election x =
lwt the_featured = Ocsipersist.get featured in
return (List.mem x the_featured)
let set_main_election x =
if SMap.mem x !election_table then (
Ocsipersist.set main_election (Some x)
) else (
Lwt.fail Not_found
open Eliom_service
open Eliom_registration
module LwtRandom = MakeLwtRandom (struct let rng = make_rng () end)
let store = Ocsipersist.open_store "site"
(* Persistent table, used to initialize the server. *)
let election_ptable = Ocsipersist.open_table "site_elections"
(* Table with elections in setup mode. *)
let election_stable = Ocsipersist.open_table "site_setup"
(* Table with tokens given to trustees. *)
let election_pktokens = Ocsipersist.open_table "site_pktokens"
(* Table with tokens given to credential authorities. *)
let election_credtokens = Ocsipersist.open_table "site_credtokens"
(* In-memory table, indexed by UUID, contains closures. *)
let election_table = ref SMap.empty
lwt main_election =
Ocsipersist.make_persistent store "main_election" None
lwt featured =
Ocsipersist.make_persistent store "featured_elections" []
(* The following reference is there to cut a dependency loop:
S.register_election depends on S (via Templates). It will be set
to a proper value once we have called Templates.Make. *)
let import_election_ref = ref (fun _ -> assert false)
(* Forward reference *)
let install_authentication_ref = ref (fun _ -> assert false)
include Web_site_auth
let import_election f = !import_election_ref f
let add_featured_election x =
lwt the_featured = Ocsipersist.get featured in
if List.mem x the_featured then (
return ()
) else if SMap.mem x !election_table then (
Ocsipersist.set featured (x :: the_featured)
) else (
Lwt.fail Not_found
)
let remove_featured_election x =
lwt the_featured = Ocsipersist.get featured in
Ocsipersist.set featured (list_remove x the_featured)
let is_featured_election x =
lwt the_featured = Ocsipersist.get featured in
return (List.mem x the_featured)
let set_main_election x =
if SMap.mem x !election_table then (
Ocsipersist.set main_election (Some x)
) else (
Lwt.fail Not_found
)
let unset_main_election () =
Ocsipersist.set main_election None
let install_authentication xs = !install_authentication_ref xs
module T = Web_templates
let register_election params web_params =
let module P = (val params : ELECTION_PARAMS) in
let uuid = Uuidm.to_string P.params.e_uuid in
let module D = struct
module G = P.G
let election = {
e_params = P.params;
e_pks = None;
e_fingerprint = P.fingerprint;
}
end in
let module P = (val web_params : WEB_PARAMS) in
let module R = Web_election.Make (D) (P) in
(module R : Web_election.REGISTRABLE), fun () ->
(* starting from here, we do side-effects on the running server *)
let module R = R.Register (struct end) in
let module W = R.W in
let module X : ELECTION_HANDLERS = R.Register (T) in
let module W = struct
include W
module Z = X
end in
let election = (module W : WEB_ELECTION) in
election_table := SMap.add uuid election !election_table;
election
(* Mutex to avoid simultaneous registrations of the same election *)
let registration_mutex = Lwt_mutex.create ()
let () = import_election_ref := fun f ->
Lwt_mutex.lock registration_mutex >>
try_lwt
lwt raw_election =
Lwt_io.lines_of_file f.f_election |>
get_single_line >>=
(function
| Some e -> return e
| None -> Printf.ksprintf
failwith "election.json must contain a single line"
)
let unset_main_election () =
Ocsipersist.set main_election None
let install_authentication xs = !install_authentication_ref xs
module T = Web_templates
let register_election params web_params =
in
let params = Group.election_params_of_string raw_election in
let module P = (val params : ELECTION_PARAMS) in
let uuid = Uuidm.to_string P.params.e_uuid in
let module D = struct
module G = P.G
let election = {
e_params = P.params;
e_pks = None;
e_fingerprint = P.fingerprint;
}
end in
let module P = (val web_params : WEB_PARAMS) in
let module R = Web_election.Make (D) (P) in
(module R : Web_election.REGISTRABLE), fun () ->
(* starting from here, we do side-effects on the running server *)
let module R = R.Register (struct end) in
let module W = R.W in
let module X : ELECTION_HANDLERS = R.Register (T) in
let module W = struct
include W
module Z = X
lwt exists =
try_lwt
lwt _ = Ocsipersist.find election_ptable uuid in
return true
with Not_found -> return false
in
if exists then (
Lwt_mutex.unlock registration_mutex;
return None
) else (
let dir = !spool_dir/uuid in
lwt metadata =
Lwt_io.chars_of_file f.f_metadata |>
Lwt_stream.to_string >>=
wrap1 metadata_of_string
in
let module X = struct
let metadata = metadata
let dir = dir
let state = ref `Open
end in
let election = (module W : WEB_ELECTION) in
election_table := SMap.add uuid election !election_table;
election
(* Mutex to avoid simultaneous registrations of the same election *)
let registration_mutex = Lwt_mutex.create ()
let () = import_election_ref := fun f ->
Lwt_mutex.lock registration_mutex >>
try_lwt
lwt raw_election =
Lwt_io.lines_of_file f.f_election |>
get_single_line >>=
(function
| Some e -> return e
| None -> Printf.ksprintf
failwith "election.json must contain a single line"
let web_params = (module X : WEB_PARAMS) in
let r, do_register = register_election params web_params in
let module R = (val r : Web_election.REGISTRABLE) in
let module G = R.W.G in
let module KG = Election.MakeSimpleDistKeyGen (G) (LwtRandom) in
let public_keys = Lwt_io.lines_of_file f.f_public_keys in
lwt pks = Lwt_stream.(
clone public_keys |>
map (trustee_public_key_of_string G.read) |>
to_list >>= wrap1 Array.of_list
) in
if not (Array.forall KG.check pks) then
failwith "Public keys are invalid.";
if not G.(R.W.election.e_params.e_public_key =~ KG.combine pks) then
failwith "Public keys mismatch with election public key.";
let public_creds = Lwt_io.lines_of_file f.f_public_creds in
lwt () = Lwt_stream.(
clone public_creds |>
iter_s (fun x ->
if not G.(check @@ of_string x) then (
Lwt.fail @@ Failure "Public credentials are invalid."
) else return ()
)
in
let params = Group.election_params_of_string raw_election in
let module P = (val params : ELECTION_PARAMS) in
let uuid = Uuidm.to_string P.params.e_uuid in
lwt exists =
try_lwt
lwt _ = Ocsipersist.find election_ptable uuid in
return true
with Not_found -> return false
in
if exists then (
Lwt_mutex.unlock registration_mutex;
return None
) else (
let dir = !spool_dir/uuid in
lwt metadata =
Lwt_io.chars_of_file f.f_metadata |>
Lwt_stream.to_string >>=
wrap1 metadata_of_string
in
let module X = struct
let metadata = metadata
let dir = dir
let state = ref `Open
end in
let web_params = (module X : WEB_PARAMS) in
let r, do_register = register_election params web_params in
let module R = (val r : Web_election.REGISTRABLE) in
let module G = R.W.G in
let module KG = Election.MakeSimpleDistKeyGen (G) (LwtRandom) in
let public_keys = Lwt_io.lines_of_file f.f_public_keys in
lwt pks = Lwt_stream.(
clone public_keys |>
map (trustee_public_key_of_string G.read) |>
to_list >>= wrap1 Array.of_list
) in
if not (Array.forall KG.check pks) then
failwith "Public keys are invalid.";
if not G.(R.W.election.e_params.e_public_key =~ KG.combine pks) then
failwith "Public keys mismatch with election public key.";
let public_creds = Lwt_io.lines_of_file f.f_public_creds in
lwt () = Lwt_stream.(
clone public_creds |>
iter_s (fun x ->
if not G.(check @@ of_string x) then (
Lwt.fail @@ Failure "Public credentials are invalid."
) else return ()
)
) in
let module R = struct
let discard () = Lwt_mutex.unlock registration_mutex
let register () =
if not (Lwt_mutex.is_locked registration_mutex) then
failwith "This election can no longer be registered.";
try_lwt
Lwt_unix.mkdir dir 0o700 >>
Lwt_io.(with_file Output (dir/"election.json") (fun oc ->
write_line oc raw_election
)) >>
Lwt_io.(with_file Output (dir/"public_keys.jsons") (fun oc ->
write_lines oc public_keys
)) >>
let election = do_register () in
let module W = (val election : WEB_ELECTION) in
let () =
Ocsigen_messages.debug (fun () ->
Printf.sprintf "Injecting credentials for %s" uuid
)
in
public_creds |>
Lwt_stream.iter_s W.B.inject_cred >>
W.B.update_files () >>
Ocsipersist.add election_ptable uuid (raw_election, web_params) >>
let () = Lwt_mutex.unlock registration_mutex in
return election
with e ->
lwt () =
try_lwt delete_shallow_directory dir
with e ->
Printf.ksprintf
(fun s ->
return (Ocsigen_messages.unexpected_exception e s))
"error while deleting %s after failure of %s"
dir uuid
in
Lwt_mutex.unlock registration_mutex;
Lwt.fail e
end in
(* until here, no side-effects on the running server *)
return @@ Some (module R : REGISTRABLE_ELECTION)
)
with e ->
Lwt_mutex.unlock registration_mutex;
Lwt.fail e
lwt () =
Ocsipersist.iter_step (fun uuid (raw_election, web_params) ->
let params = Group.election_params_of_string raw_election in
let _, do_register = register_election params web_params in
let election = do_register () in
let module W = (val election : WEB_ELECTION) in
assert (uuid = Uuidm.to_string W.election.e_params.e_uuid);
Ocsigen_messages.debug (fun () ->
Printf.sprintf "Initialized election %s from persistent store" uuid
);
return ()
) election_ptable
module L = struct
let login x = Eliom_service.preapply site_login x
let logout = Eliom_service.preapply site_logout ()
end
let () = install_authentication_ref := fun auth_configs ->
let module T = T.Login (Web_site_auth) (L) in
let templates = (module T : LOGIN_TEMPLATES) in
Web_site_auth.register templates auth_configs
let () = Any.register ~service:home
(fun () () ->
Eliom_reference.unset cont >>
match_lwt Ocsipersist.get main_election with
| None ->
lwt featured =
Ocsipersist.get featured >>=
Lwt_list.map_p (fun x -> return @@ SMap.find x !election_table)
in
T.home ~featured () >>= Html5.send
| Some x ->
let module W = (val SMap.find x !election_table : WEB_ELECTION) in
Redirection.send
(preapply election_home (W.election.e_params.e_uuid, ()))
) in
let module R = struct
let discard () = Lwt_mutex.unlock registration_mutex
let register () =
if not (Lwt_mutex.is_locked registration_mutex) then
failwith "This election can no longer be registered.";
try_lwt
Lwt_unix.mkdir dir 0o700 >>
Lwt_io.(with_file Output (dir/"election.json") (fun oc ->
write_line oc raw_election
)) >>
Lwt_io.(with_file Output (dir/"public_keys.jsons") (fun oc ->
write_lines oc public_keys
)) >>
let election = do_register () in
let module W = (val election : WEB_ELECTION) in
let () =
Ocsigen_messages.debug (fun () ->
Printf.sprintf "Injecting credentials for %s" uuid
)
in
public_creds |>
Lwt_stream.iter_s W.B.inject_cred >>
W.B.update_files () >>
Ocsipersist.add election_ptable uuid (raw_election, web_params) >>
let () = Lwt_mutex.unlock registration_mutex in
return election
with e ->
lwt () =
try_lwt delete_shallow_directory dir
with e ->
Printf.ksprintf
(fun s ->
return (Ocsigen_messages.unexpected_exception e s))
"error while deleting %s after failure of %s"
dir uuid
in
Lwt_mutex.unlock registration_mutex;
Lwt.fail e
end in
(* until here, no side-effects on the running server *)
return @@ Some (module R : REGISTRABLE_ELECTION)
)
let () = Html5.register ~service:admin
(fun () () ->
let cont () () = Redirection.send admin in
Eliom_reference.set Web_services.cont cont >>
lwt elections =
match_lwt get_user () with
| None -> return []
| Some u ->
SMap.fold (fun _ w accu ->
let module W = (val w : WEB_ELECTION) in
if W.metadata.e_owner = Some u then (
w :: accu
) else (
accu
)
) !election_table [] |> List.rev |> return
with e ->
Lwt_mutex.unlock registration_mutex;
Lwt.fail e
lwt () =
Ocsipersist.iter_step (fun uuid (raw_election, web_params) ->
let params = Group.election_params_of_string raw_election in
let _, do_register = register_election params web_params in
let election = do_register () in
let module W = (val election : WEB_ELECTION) in
assert (uuid = Uuidm.to_string W.election.e_params.e_uuid);
Ocsigen_messages.debug (fun () ->
Printf.sprintf "Initialized election %s from persistent store" uuid
);
return ()
) election_ptable
module L = struct
let login x = Eliom_service.preapply site_login x
let logout = Eliom_service.preapply site_logout ()
end
let () = install_authentication_ref := fun auth_configs ->
let module T = T.Login (Web_site_auth) (L) in
let templates = (module T : LOGIN_TEMPLATES) in
Web_site_auth.register templates auth_configs
let () = Any.register ~service:home
(fun () () ->
Eliom_reference.unset cont >>
match_lwt Ocsipersist.get main_election with
| None ->
lwt featured =
Ocsipersist.get featured >>=
Lwt_list.map_p (fun x -> return @@ SMap.find x !election_table)
in
T.admin ~elections ()
)
let () = File.register
~service:source_code
~content_type:"application/x-gzip"
(fun () () -> return !source_file)
let do_get_randomness =
let prng = Lazy.lazy_from_fun (Lwt_preemptive.detach (fun () ->
pseudo_rng (random_string secure_rng 16)
)) in
let mutex = Lwt_mutex.create () in
fun () ->
Lwt_mutex.with_lock mutex (fun () ->
lwt prng = Lazy.force prng in
return (random_string prng 32)
)
let () = String.register
~service:get_randomness
(fun () () ->
lwt r = do_get_randomness () in
b64_encode_compact r |>
(fun x -> string_of_randomness { randomness=x }) |>
(fun x -> return (x, "application/json"))
)
let () = Html5.register ~service:new_election
(fun () () ->
T.home ~featured () >>= Html5.send
| Some x ->
let module W = (val SMap.find x !election_table : WEB_ELECTION) in
Redirection.send
(preapply election_home (W.election.e_params.e_uuid, ()))
)
let () = Html5.register ~service:admin
(fun () () ->
let cont () () = Redirection.send admin in
Eliom_reference.set Web_services.cont cont >>
lwt elections =
match_lwt get_user () with
| None -> forbidden ()
| Some _ -> T.new_election ()
| None -> return []
| Some u ->
SMap.fold (fun _ w accu ->
let module W = (val w : WEB_ELECTION) in
if W.metadata.e_owner = Some u then (
w :: accu
) else (
accu
)
) !election_table [] |> List.rev |> return
in
T.admin ~elections ()
)
let () = File.register
~service:source_code
~content_type:"application/x-gzip"
(fun () () -> return !source_file)
let do_get_randomness =
let prng = Lazy.lazy_from_fun (Lwt_preemptive.detach (fun () ->
pseudo_rng (random_string secure_rng 16)
)) in
let mutex = Lwt_mutex.create () in
fun () ->
Lwt_mutex.with_lock mutex (fun () ->
lwt prng = Lazy.force prng in
return (random_string prng 32)
)
let () = Any.register ~service:new_election_post
(fun () (election, (metadata, (public_keys, public_creds))) ->
match_lwt get_user () with
| Some u ->
let open Ocsigen_extensions in
let files = {
f_election = election.tmp_filename;
f_metadata = metadata.tmp_filename;
f_public_keys = public_keys.tmp_filename;
f_public_creds = public_creds.tmp_filename;
} in
begin try_lwt
begin match_lwt import_election files with
| None ->
T.new_election_failure `Exists () >>= Html5.send
| Some w ->
let module W = (val w : REGISTRABLE_ELECTION) in
lwt w = W.register () in
let module W = (val w : WEB_ELECTION) in
Redirection.send
(preapply election_admin (W.election.e_params.e_uuid, ()))
end
with e ->
T.new_election_failure (`Exception e) () >>= Html5.send
let () = String.register
~service:get_randomness
(fun () () ->
lwt r = do_get_randomness () in
b64_encode_compact r |>
(fun x -> string_of_randomness { randomness=x }) |>
(fun x -> return (x, "application/json"))
)
let () = Html5.register ~service:new_election
(fun () () ->