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

Fix indentation in Web_site

parent eea75e7d
...@@ -58,48 +58,48 @@ let delete_shallow_directory dir = ...@@ -58,48 +58,48 @@ let delete_shallow_directory dir =
in in
Lwt_unix.rmdir dir Lwt_unix.rmdir dir
open Eliom_service open Eliom_service
open Eliom_registration open Eliom_registration
module LwtRandom = MakeLwtRandom (struct let rng = make_rng () end) module LwtRandom = MakeLwtRandom (struct let rng = make_rng () end)
let store = Ocsipersist.open_store "site" let store = Ocsipersist.open_store "site"
(* Persistent table, used to initialize the server. *) (* Persistent table, used to initialize the server. *)
let election_ptable = Ocsipersist.open_table "site_elections" let election_ptable = Ocsipersist.open_table "site_elections"
(* Table with elections in setup mode. *) (* Table with elections in setup mode. *)
let election_stable = Ocsipersist.open_table "site_setup" let election_stable = Ocsipersist.open_table "site_setup"
(* Table with tokens given to trustees. *) (* Table with tokens given to trustees. *)
let election_pktokens = Ocsipersist.open_table "site_pktokens" let election_pktokens = Ocsipersist.open_table "site_pktokens"
(* Table with tokens given to credential authorities. *) (* Table with tokens given to credential authorities. *)
let election_credtokens = Ocsipersist.open_table "site_credtokens" let election_credtokens = Ocsipersist.open_table "site_credtokens"
(* In-memory table, indexed by UUID, contains closures. *) (* In-memory table, indexed by UUID, contains closures. *)
let election_table = ref SMap.empty let election_table = ref SMap.empty
lwt main_election = lwt main_election =
Ocsipersist.make_persistent store "main_election" None Ocsipersist.make_persistent store "main_election" None
lwt featured = lwt featured =
Ocsipersist.make_persistent store "featured_elections" [] Ocsipersist.make_persistent store "featured_elections" []
(* The following reference is there to cut a dependency loop: (* The following reference is there to cut a dependency loop:
S.register_election depends on S (via Templates). It will be set S.register_election depends on S (via Templates). It will be set
to a proper value once we have called Templates.Make. *) to a proper value once we have called Templates.Make. *)
let import_election_ref = ref (fun _ -> assert false) let import_election_ref = ref (fun _ -> assert false)
(* Forward reference *) (* Forward reference *)
let install_authentication_ref = ref (fun _ -> assert false) let install_authentication_ref = ref (fun _ -> assert false)
include Web_site_auth include Web_site_auth
let import_election f = !import_election_ref f let import_election f = !import_election_ref f
let add_featured_election x = let add_featured_election x =
lwt the_featured = Ocsipersist.get featured in lwt the_featured = Ocsipersist.get featured in
if List.mem x the_featured then ( if List.mem x the_featured then (
return () return ()
...@@ -109,29 +109,29 @@ let delete_shallow_directory dir = ...@@ -109,29 +109,29 @@ let delete_shallow_directory dir =
Lwt.fail Not_found Lwt.fail Not_found
) )
let remove_featured_election x = let remove_featured_election x =
lwt the_featured = Ocsipersist.get featured in lwt the_featured = Ocsipersist.get featured in
Ocsipersist.set featured (list_remove x the_featured) Ocsipersist.set featured (list_remove x the_featured)
let is_featured_election x = let is_featured_election x =
lwt the_featured = Ocsipersist.get featured in lwt the_featured = Ocsipersist.get featured in
return (List.mem x the_featured) return (List.mem x the_featured)
let set_main_election x = let set_main_election x =
if SMap.mem x !election_table then ( if SMap.mem x !election_table then (
Ocsipersist.set main_election (Some x) Ocsipersist.set main_election (Some x)
) else ( ) else (
Lwt.fail Not_found Lwt.fail Not_found
) )
let unset_main_election () = let unset_main_election () =
Ocsipersist.set main_election None Ocsipersist.set main_election None
let install_authentication xs = !install_authentication_ref xs let install_authentication xs = !install_authentication_ref xs
module T = Web_templates module T = Web_templates
let register_election params web_params = let register_election params web_params =
let module P = (val params : ELECTION_PARAMS) in let module P = (val params : ELECTION_PARAMS) in
let uuid = Uuidm.to_string P.params.e_uuid in let uuid = Uuidm.to_string P.params.e_uuid in
let module D = struct let module D = struct
...@@ -157,10 +157,10 @@ let delete_shallow_directory dir = ...@@ -157,10 +157,10 @@ let delete_shallow_directory dir =
election_table := SMap.add uuid election !election_table; election_table := SMap.add uuid election !election_table;
election election
(* Mutex to avoid simultaneous registrations of the same election *) (* Mutex to avoid simultaneous registrations of the same election *)
let registration_mutex = Lwt_mutex.create () let registration_mutex = Lwt_mutex.create ()
let () = import_election_ref := fun f -> let () = import_election_ref := fun f ->
Lwt_mutex.lock registration_mutex >> Lwt_mutex.lock registration_mutex >>
try_lwt try_lwt
lwt raw_election = lwt raw_election =
...@@ -266,7 +266,7 @@ let delete_shallow_directory dir = ...@@ -266,7 +266,7 @@ let delete_shallow_directory dir =
Lwt_mutex.unlock registration_mutex; Lwt_mutex.unlock registration_mutex;
Lwt.fail e Lwt.fail e
lwt () = lwt () =
Ocsipersist.iter_step (fun uuid (raw_election, web_params) -> Ocsipersist.iter_step (fun uuid (raw_election, web_params) ->
let params = Group.election_params_of_string raw_election in let params = Group.election_params_of_string raw_election in
let _, do_register = register_election params web_params in let _, do_register = register_election params web_params in
...@@ -279,17 +279,17 @@ let delete_shallow_directory dir = ...@@ -279,17 +279,17 @@ let delete_shallow_directory dir =
return () return ()
) election_ptable ) election_ptable
module L = struct module L = struct
let login x = Eliom_service.preapply site_login x let login x = Eliom_service.preapply site_login x
let logout = Eliom_service.preapply site_logout () let logout = Eliom_service.preapply site_logout ()
end end
let () = install_authentication_ref := fun auth_configs -> let () = install_authentication_ref := fun auth_configs ->
let module T = T.Login (Web_site_auth) (L) in let module T = T.Login (Web_site_auth) (L) in
let templates = (module T : LOGIN_TEMPLATES) in let templates = (module T : LOGIN_TEMPLATES) in
Web_site_auth.register templates auth_configs Web_site_auth.register templates auth_configs
let () = Any.register ~service:home let () = Any.register ~service:home
(fun () () -> (fun () () ->
Eliom_reference.unset cont >> Eliom_reference.unset cont >>
match_lwt Ocsipersist.get main_election with match_lwt Ocsipersist.get main_election with
...@@ -305,7 +305,7 @@ let delete_shallow_directory dir = ...@@ -305,7 +305,7 @@ let delete_shallow_directory dir =
(preapply election_home (W.election.e_params.e_uuid, ())) (preapply election_home (W.election.e_params.e_uuid, ()))
) )
let () = Html5.register ~service:admin let () = Html5.register ~service:admin
(fun () () -> (fun () () ->
let cont () () = Redirection.send admin in let cont () () = Redirection.send admin in
Eliom_reference.set Web_services.cont cont >> Eliom_reference.set Web_services.cont cont >>
...@@ -325,12 +325,12 @@ let delete_shallow_directory dir = ...@@ -325,12 +325,12 @@ let delete_shallow_directory dir =
T.admin ~elections () T.admin ~elections ()
) )
let () = File.register let () = File.register
~service:source_code ~service:source_code
~content_type:"application/x-gzip" ~content_type:"application/x-gzip"
(fun () () -> return !source_file) (fun () () -> return !source_file)
let do_get_randomness = let do_get_randomness =
let prng = Lazy.lazy_from_fun (Lwt_preemptive.detach (fun () -> let prng = Lazy.lazy_from_fun (Lwt_preemptive.detach (fun () ->
pseudo_rng (random_string secure_rng 16) pseudo_rng (random_string secure_rng 16)
)) in )) in
...@@ -341,7 +341,7 @@ let delete_shallow_directory dir = ...@@ -341,7 +341,7 @@ let delete_shallow_directory dir =
return (random_string prng 32) return (random_string prng 32)
) )
let () = String.register let () = String.register
~service:get_randomness ~service:get_randomness
(fun () () -> (fun () () ->
lwt r = do_get_randomness () in lwt r = do_get_randomness () in
...@@ -350,14 +350,14 @@ let delete_shallow_directory dir = ...@@ -350,14 +350,14 @@ let delete_shallow_directory dir =
(fun x -> return (x, "application/json")) (fun x -> return (x, "application/json"))
) )
let () = Html5.register ~service:new_election let () = Html5.register ~service:new_election
(fun () () -> (fun () () ->
match_lwt get_user () with match_lwt get_user () with
| None -> forbidden () | None -> forbidden ()
| Some _ -> T.new_election () | Some _ -> T.new_election ()
) )
let () = Any.register ~service:new_election_post let () = Any.register ~service:new_election_post
(fun () (election, (metadata, (public_keys, public_creds))) -> (fun () (election, (metadata, (public_keys, public_creds))) ->
match_lwt get_user () with match_lwt get_user () with
| Some u -> | Some u ->
...@@ -385,9 +385,9 @@ let delete_shallow_directory dir = ...@@ -385,9 +385,9 @@ let delete_shallow_directory dir =
| None -> forbidden () | None -> forbidden ()
) )
let generate_uuid = Uuidm.v4_gen (Random.State.make_self_init ()) let generate_uuid = Uuidm.v4_gen (Random.State.make_self_init ())
let () = Html5.register ~service:election_setup_index let () = Html5.register ~service:election_setup_index
(fun () () -> (fun () () ->
match_lwt get_user () with match_lwt get_user () with
| Some u -> | Some u ->
...@@ -401,7 +401,7 @@ let delete_shallow_directory dir = ...@@ -401,7 +401,7 @@ let delete_shallow_directory dir =
| None -> forbidden () | None -> forbidden ()
) )
let () = Redirection.register ~service:election_setup_new let () = Redirection.register ~service:election_setup_new
(fun () () -> (fun () () ->
match_lwt get_user () with match_lwt get_user () with
| Some u -> | Some u ->
...@@ -442,7 +442,7 @@ let delete_shallow_directory dir = ...@@ -442,7 +442,7 @@ let delete_shallow_directory dir =
| None -> forbidden () | None -> forbidden ()
) )
let () = Html5.register ~service:election_setup let () = Html5.register ~service:election_setup
(fun uuid () -> (fun uuid () ->
match_lwt get_user () with match_lwt get_user () with
| Some u -> | Some u ->
...@@ -454,9 +454,9 @@ let delete_shallow_directory dir = ...@@ -454,9 +454,9 @@ let delete_shallow_directory dir =
| None -> forbidden () | None -> forbidden ()
) )
let election_setup_mutex = Lwt_mutex.create () let election_setup_mutex = Lwt_mutex.create ()
let handle_setup f cont uuid x = let handle_setup f cont uuid x =
match_lwt get_user () with match_lwt get_user () with
| Some u -> | Some u ->
let uuid_s = Uuidm.to_string uuid in let uuid_s = Uuidm.to_string uuid in
...@@ -473,7 +473,7 @@ let delete_shallow_directory dir = ...@@ -473,7 +473,7 @@ let delete_shallow_directory dir =
) )
| None -> forbidden () | None -> forbidden ()
let () = let () =
Any.register Any.register
~service:election_setup_group ~service:election_setup_group
(handle_setup (handle_setup
...@@ -482,7 +482,7 @@ let delete_shallow_directory dir = ...@@ -482,7 +482,7 @@ let delete_shallow_directory dir =
(* we keep it as a string since it contains a type *) (* we keep it as a string since it contains a type *)
se.se_group <- x) election_setup) se.se_group <- x) election_setup)
let () = let () =
Any.register Any.register
~service:election_setup_metadata ~service:election_setup_metadata
(handle_setup (handle_setup
...@@ -491,7 +491,7 @@ let delete_shallow_directory dir = ...@@ -491,7 +491,7 @@ let delete_shallow_directory dir =
if metadata.e_owner <> Some u then failwith "wrong owner"; if metadata.e_owner <> Some u then failwith "wrong owner";
se.se_metadata <- metadata) election_setup) se.se_metadata <- metadata) election_setup)
let () = let () =
Html5.register Html5.register
~service:election_setup_questions ~service:election_setup_questions
(fun uuid () -> (fun uuid () ->
...@@ -505,14 +505,14 @@ let delete_shallow_directory dir = ...@@ -505,14 +505,14 @@ let delete_shallow_directory dir =
| None -> forbidden () | None -> forbidden ()
) )
let () = let () =
Any.register Any.register
~service:election_setup_questions_post ~service:election_setup_questions_post
(handle_setup (handle_setup
(fun se x _ -> (fun se x _ ->
se.se_questions <- template_of_string x) election_setup_questions) se.se_questions <- template_of_string x) election_setup_questions)
let () = let () =
Redirection.register Redirection.register
~service:election_setup_trustee_add ~service:election_setup_trustee_add
(fun uuid () -> (fun uuid () ->
...@@ -533,7 +533,7 @@ let delete_shallow_directory dir = ...@@ -533,7 +533,7 @@ let delete_shallow_directory dir =
| None -> forbidden () | None -> forbidden ()
) )
let () = let () =
Html5.register Html5.register
~service:election_setup_credentials ~service:election_setup_credentials
(fun token () -> (fun token () ->
...@@ -542,7 +542,7 @@ let delete_shallow_directory dir = ...@@ -542,7 +542,7 @@ let delete_shallow_directory dir =
T.election_setup_credentials token uuid se () T.election_setup_credentials token uuid se ()
) )
let () = let () =
File.register File.register
~service:election_setup_credentials_download ~service:election_setup_credentials_download
~content_type:"text/plain" ~content_type:"text/plain"
...@@ -551,12 +551,12 @@ let delete_shallow_directory dir = ...@@ -551,12 +551,12 @@ let delete_shallow_directory dir =
return (!spool_dir / uuid ^ ".public_creds.txt") return (!spool_dir / uuid ^ ".public_creds.txt")
) )
let wrap_handler f = let wrap_handler f =
try_lwt f () try_lwt f ()
with with
| e -> T.generic_error_page (Printexc.to_string e) () >>= Html5.send | e -> T.generic_error_page (Printexc.to_string e) () >>= Html5.send
let handle_credentials_post token creds = let handle_credentials_post token creds =
lwt uuid = Ocsipersist.find election_credtokens token in lwt uuid = Ocsipersist.find election_credtokens token in
lwt se = Ocsipersist.find election_stable uuid in lwt se = Ocsipersist.find election_stable uuid in
let module G = (val Group.of_string se.se_group : GROUP) in let module G = (val Group.of_string se.se_group : GROUP) in
...@@ -583,21 +583,21 @@ let delete_shallow_directory dir = ...@@ -583,21 +583,21 @@ let delete_shallow_directory dir =
in in
Redirection.send (preapply election_setup_credentials token) Redirection.send (preapply election_setup_credentials token)
let () = let () =
Any.register Any.register
~service:election_setup_credentials_post ~service:election_setup_credentials_post
(fun token creds -> (fun token creds ->
let s = Lwt_stream.of_string creds in let s = Lwt_stream.of_string creds in
wrap_handler (fun () -> handle_credentials_post token s)) wrap_handler (fun () -> handle_credentials_post token s))
let () = let () =
Any.register Any.register
~service:election_setup_credentials_post_file ~service:election_setup_credentials_post_file
(fun token creds -> (fun token creds ->
let s = Lwt_io.chars_of_file creds.Ocsigen_extensions.tmp_filename in let s = Lwt_io.chars_of_file creds.Ocsigen_extensions.tmp_filename in
wrap_handler (fun () -> handle_credentials_post token s)) wrap_handler (fun () -> handle_credentials_post token s))
let () = let () =
Html5.register Html5.register
~service:election_setup_trustee ~service:election_setup_trustee
(fun token () -> (fun token () ->
...@@ -606,7 +606,7 @@ let delete_shallow_directory dir = ...@@ -606,7 +606,7 @@ let delete_shallow_directory dir =
T.election_setup_trustee token uuid se () T.election_setup_trustee token uuid se ()
) )
let () = let () =
Any.register Any.register
~service:election_setup_trustee_post ~service:election_setup_trustee_post
(fun token public_key -> (fun token public_key ->
...@@ -629,7 +629,7 @@ let delete_shallow_directory dir = ...@@ -629,7 +629,7 @@ let delete_shallow_directory dir =
) )
) )
let () = let () =
Any.register Any.register
~service:election_setup_create ~service:election_setup_create
(fun uuid () -> (fun uuid () ->
...@@ -729,7 +729,7 @@ let delete_shallow_directory dir = ...@@ -729,7 +729,7 @@ let delete_shallow_directory dir =
end end
) )
let () = let () =
Any.register Any.register
~service:election_home ~service:election_home
(fun (uuid, ()) () -> (fun (uuid, ()) () ->
...@@ -738,7 +738,7 @@ let delete_shallow_directory dir = ...@@ -738,7 +738,7 @@ let delete_shallow_directory dir =
let module W = (val w : WEB_ELECTION) in let module W = (val w : WEB_ELECTION) in
W.Z.home () ()) W.Z.home () ())
let () = let () =
Any.register Any.register
~service:election_set_featured ~service:election_set_featured
(fun (uuid, ()) featured -> (fun (uuid, ()) featured ->
...@@ -750,7 +750,7 @@ let delete_shallow_directory dir = ...@@ -750,7 +750,7 @@ let delete_shallow_directory dir =
Redirection.send Redirection.send
(preapply election_admin (uuid, ()))) (preapply election_admin (uuid, ())))
let () = let () =
Any.register Any.register
~service:election_admin ~service:election_admin
(fun (uuid, ()) () -> (fun (uuid, ()) () ->
...@@ -761,7 +761,7 @@ let delete_shallow_directory dir = ...@@ -761,7 +761,7 @@ let delete_shallow_directory dir =
lwt is_featured = is_featured_election uuid_s in lwt is_featured = is_featured_election uuid_s in
W.Z.admin user is_featured () ()) W.Z.admin user is_featured () ())
let () = let () =
Any.register Any.register
~service:election_set_state ~service:election_set_state
(fun (uuid, ()) state -> (fun (uuid, ()) state ->
...@@ -774,7 +774,7 @@ let delete_shallow_directory dir = ...@@ -774,7 +774,7 @@ let delete_shallow_directory dir =
Redirection.send (preapply election_admin (uuid, ())) Redirection.send (preapply election_admin (uuid, ()))
| _ -> forbidden ()) | _ -> forbidden ())
let () = let () =
Any.register Any.register
~service:election_login ~service:election_login
(fun ((uuid, ()), service) () -> (fun ((uuid, ()), service) () ->
...@@ -783,7 +783,7 @@ let delete_shallow_directory dir = ...@@ -783,7 +783,7 @@ let delete_shallow_directory dir =
let module W = (val w : WEB_ELECTION) in let module W = (val w : WEB_ELECTION) in
W.Z.login service ()) W.Z.login service ())
let () = let () =
Any.register Any.register
~service:election_logout ~service:election_logout
(fun (uuid, ()) () -> (fun (uuid, ()) () ->
...@@ -792,7 +792,7 @@ let delete_shallow_directory dir = ...@@ -792,7 +792,7 @@ let delete_shallow_directory dir =
let module W = (val w : WEB_ELECTION) in let module W = (val w : WEB_ELECTION) in
W.Z.logout () ()) W.Z.logout () ())
let () = let () =
Any.register Any.register
~service:election_update_credential ~service:election_update_credential
(fun (uuid, ()) () -> (fun (uuid, ()) () ->
...@@ -802,7 +802,7 @@ let delete_shallow_directory dir = ...@@ -802,7 +802,7 @@ let delete_shallow_directory dir =
lwt user = get_user () in lwt user = get_user () in
W.Z.election_update_credential user () ()) W.Z.election_update_credential user () ())
let () = let () =
Any.register Any.register
~service:election_update_credential_post ~service:election_update_credential_post
(fun (uuid, ()) x -> (fun (uuid, ()) x ->
...@@ -812,7 +812,7 @@ let delete_shallow_directory dir = ...@@ -812,7 +812,7 @@ let delete_shallow_directory dir =
lwt user = get_user () in lwt user = get_user () in
W.Z.election_update_credential_post user () x) W.Z.election_update_credential_post user () x)
let () =