Commit e981da31 authored by Stephane Glondu's avatar Stephane Glondu

Switch to lwt.ppx for web server code

parent 88661520
<**/*.{ml,mli,byte,native,odoc}>: debug, annot, package(uuidm), package(atdgen), package(yojson)
<src/platform/native/*>: package(zarith), package(calendar), package(cryptokit)
<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), package(lwt.ppx), package(csv)
<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
......
......@@ -62,7 +62,7 @@ let scope = Eliom_common.default_session_scope
let auth_env = Eliom_reference.eref ~scope None
let default_cont uuid () =
match_lwt cont_pop () with
match%lwt cont_pop () with
| Some f -> f ()
| None ->
match uuid with
......@@ -74,7 +74,7 @@ let default_cont uuid () =
(** Dummy authentication *)
let dummy_handler () name =
match_lwt Eliom_reference.get auth_env with
match%lwt Eliom_reference.get auth_env with
| None -> failwith "dummy handler was invoked without environment"
| Some (uuid, service) ->
let logout () =
......@@ -90,8 +90,8 @@ let () = Eliom_registration.Any.register ~service:dummy_post dummy_handler
(** Password authentication *)
let password_handler () (name, password) =
lwt uuid, service =
match_lwt Eliom_reference.get auth_env with
let%lwt uuid, service =
match%lwt Eliom_reference.get auth_env with
| None -> failwith "password handler was invoked without environment"
| Some x -> return x
in
......@@ -104,8 +104,8 @@ let password_handler () (name, password) =
underscorize u
in
let table = Ocsipersist.open_table table in
lwt salt, hashed =
try_lwt Ocsipersist.find table name
let%lwt salt, hashed =
try%lwt Ocsipersist.find table name
with Not_found -> fail_http 401
in
if sha256_hex (salt ^ password) = hashed then
......@@ -160,28 +160,28 @@ let get_cas_validation server ticket =
let service = preapply cas_validate (Lazy.force cas_self, ticket) in
Eliom_uri.make_string_uri ~absolute:true ~service ()
in
lwt reply = Ocsigen_http_client.get_url url in
let%lwt reply = Ocsigen_http_client.get_url url in
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
let%lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
return (parse_cas_validation info)
| None -> return (`Error `Http)
let cas_handler ticket () =
lwt uuid, service =
match_lwt Eliom_reference.get auth_env with
let%lwt uuid, service =
match%lwt Eliom_reference.get auth_env with
| None -> failwith "cas handler was invoked without environment"
| Some x -> return x
in
match ticket with
| Some x ->
lwt server =
match_lwt Eliom_reference.get cas_server with
let%lwt server =
match%lwt Eliom_reference.get cas_server with
| None -> failwith "cas handler was invoked without a server"
| Some x -> return x
in
(match_lwt get_cas_validation server x with
(match%lwt get_cas_validation server x with
| `Yes (Some name) ->
let logout () =
Eliom_reference.unset user >>
......@@ -241,10 +241,10 @@ let oidc_get_userinfo ocfg info =
let headers = Http_headers.(
add (name "Authorization") ("Bearer " ^ access_token) empty
) in
lwt reply = Ocsigen_http_client.get_url ~headers url in
let%lwt reply = Ocsigen_http_client.get_url ~headers url in
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
let x = oidc_userinfo_of_string info in
return (Some (match x.oidc_email with Some x -> x | None -> x.oidc_sub))
......@@ -258,17 +258,17 @@ let oidc_get_name ocfg client_id client_secret code =
"redirect_uri", Lazy.force oidc_self;
"grant_type", "authorization_code";
] in
lwt reply = Ocsigen_http_client.post_urlencoded_url ~content ocfg.token_endpoint in
let%lwt reply = Ocsigen_http_client.post_urlencoded_url ~content ocfg.token_endpoint in
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
oidc_get_userinfo ocfg info
| None -> return None
let oidc_handler params () =
lwt uuid, service =
match_lwt Eliom_reference.get auth_env with
let%lwt uuid, service =
match%lwt Eliom_reference.get auth_env with
| None -> failwith "oidc handler was invoked without environment"
| Some x -> return x
in
......@@ -276,15 +276,15 @@ let oidc_handler params () =
let state = try Some (List.assoc "state" params) with Not_found -> None in
match code, state with
| Some code, Some state ->
lwt ocfg, client_id, client_secret, st =
match_lwt Eliom_reference.get oidc_state with
let%lwt ocfg, client_id, client_secret, st =
match%lwt Eliom_reference.get oidc_state with
| None -> failwith "oidc handler was invoked without a state"
| Some x -> return x
in
Eliom_reference.unset oidc_state >>
Eliom_reference.unset auth_env >>
if state <> st then fail_http 401 else
(match_lwt oidc_get_name ocfg client_id client_secret code with
(match%lwt oidc_get_name ocfg client_id client_secret code with
| Some name ->
let logout () =
Eliom_reference.unset user >>
......@@ -299,10 +299,10 @@ let () = Eliom_registration.Any.register ~service:login_oidc oidc_handler
let get_oidc_configuration server =
let url = server ^ "/.well-known/openid-configuration" in
lwt reply = Ocsigen_http_client.get_url url in
let%lwt reply = Ocsigen_http_client.get_url url in
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
return (oidc_configuration_of_string info)
| None -> fail_http 404
......@@ -315,8 +315,8 @@ let split_prefix_path url =
let oidc_login_handler config () =
match config with
| [server; client_id; client_secret] ->
lwt ocfg = get_oidc_configuration server in
lwt state = generate_token () in
let%lwt ocfg = get_oidc_configuration server in
let%lwt state = generate_token () in
Eliom_reference.set oidc_state (Some (ocfg, client_id, client_secret, state)) >>
let prefix, path = split_prefix_path ocfg.authorization_endpoint in
let auth_endpoint = Http.external_service ~prefix ~path
......@@ -348,7 +348,7 @@ let login_handler service uuid =
| None -> preapply site_login service
| Some u -> preapply election_login ((u, ()), service)
in
match_lwt Eliom_reference.get user with
match%lwt Eliom_reference.get user with
| Some _ ->
cont_push (fun () -> Eliom_registration.Redirection.send (myself service)) >>
Web_templates.already_logged_in () >>= Eliom_registration.Html5.send
......@@ -357,10 +357,10 @@ let login_handler service uuid =
| None -> ""
| Some u -> Uuidm.to_string u
in
lwt c = Web_persist.get_auth_config uuid_or_empty in
let%lwt c = Web_persist.get_auth_config uuid_or_empty in
match service with
| Some s ->
lwt auth_system, config =
let%lwt auth_system, config =
try return @@ List.assoc s c
with Not_found -> fail_http 404
in
......@@ -380,10 +380,10 @@ let login_handler service uuid =
Eliom_registration.Html5.send
let logout_handler () =
match_lwt Eliom_reference.get user with
match%lwt Eliom_reference.get user with
| Some u -> u.logout ()
| None ->
match_lwt cont_pop () with
match%lwt cont_pop () with
| Some f -> f ()
| None -> Eliom_registration.Redirection.send Web_services.home
......
......@@ -46,7 +46,7 @@ module MakeLwtRandom (X : LWT_RNG) = struct
let random q =
let size = Z.bit_length q / 8 + 1 in
lwt rng = X.rng in
let%lwt rng = X.rng in
let r = random_string rng size in
return Z.(of_bits r mod q)
......@@ -86,12 +86,12 @@ let explain_error = function
let security_logfile = ref None
let open_security_log f =
lwt () =
let%lwt () =
match !security_logfile with
| Some ic -> Lwt_io.close ic
| None -> return ()
in
lwt ic = Lwt_io.(
let%lwt ic = Lwt_io.(
open_file ~flags:Unix.(
[O_WRONLY; O_APPEND; O_CREAT]
) ~perm:0o600 ~mode:output f
......@@ -112,10 +112,10 @@ let security_log s =
) ic
let fail_http status =
raise_lwt (
[%lwt raise (
Ocsigen_extensions.Ocsigen_http_error
(Ocsigen_cookies.empty_cookieset, status)
)
)]
let forbidden () = fail_http 403
......@@ -182,7 +182,7 @@ let token_length = 14
let prng = lazy (pseudo_rng (random_string secure_rng 16))
let random_char () =
lwt rng =
let%lwt rng =
if Lazy.is_val prng then return (Lazy.force prng) else
Lwt_preemptive.detach (fun () -> Lazy.force prng) ()
in
......@@ -192,7 +192,7 @@ let generate_token () =
let res = Bytes.create token_length in
let rec loop i =
if i < token_length then (
lwt digit = random_char () in
let%lwt digit = random_char () in
let digit = digit mod 58 in
Bytes.set res i b58_digits.[digit];
loop (i+1)
......@@ -214,7 +214,7 @@ let send_email recipient subject body =
~subject body
in
let rec loop () =
try_lwt
try%lwt
Lwt_preemptive.detach Netsendmail.sendmail contents
with Unix.Unix_error (Unix.EAGAIN, _, _) ->
Lwt_unix.sleep 1. >> loop ()
......
......@@ -45,8 +45,8 @@ module Make (D : ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELE
let cred_table = Ocsipersist.open_table ("creds_" ^ uuid_u)
let inject_cred cred =
try_lwt
lwt _ = Ocsipersist.find cred_table cred in
try%lwt
let%lwt _ = Ocsipersist.find cred_table cred in
failwith "trying to add duplicate credential"
with Not_found ->
Ocsipersist.add cred_table cred None
......@@ -61,15 +61,15 @@ module Make (D : ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELE
let url2 = Eliom_uri.make_string_uri ~absolute:true
~service:Web_services.election_home x |> rewrite_prefix
in
lwt language = Eliom_reference.get Web_state.language in
let%lwt language = Eliom_reference.get Web_state.language in
let module L = (val Web_i18n.get_lang language) in
let body = Printf.sprintf L.mail_confirmation user title hash url1 url2 in
send_email email subject body
let do_cast rawballot (user, date) =
let voters = Lwt_io.lines_of_file (!spool_dir / uuid / "voters.txt") in
lwt voters = Lwt_stream.to_list voters in
lwt email, login =
let%lwt voters = Lwt_stream.to_list voters in
let%lwt email, login =
let rec loop = function
| x :: xs ->
let email, login = split_identity x in
......@@ -78,27 +78,27 @@ module Make (D : ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELE
in loop voters
in
let user = string_of_user user in
lwt state = Web_persist.get_election_state uuid in
let%lwt state = Web_persist.get_election_state uuid in
let voting_open = state = `Open in
if not voting_open then fail ElectionClosed else return () >>
if String.contains rawballot '\n' then (
fail (Serialization (Invalid_argument "multiline ballot"))
) else return () >>
lwt ballot =
let%lwt ballot =
try Lwt.return (ballot_of_string G.read rawballot)
with e -> fail (Serialization e)
in
lwt credential =
let%lwt credential =
match ballot.signature with
| Some s -> Lwt.return (G.to_string s.s_public_key)
| None -> fail MissingCredential
in
lwt old_cred =
try_lwt Ocsipersist.find cred_table credential
let%lwt old_cred =
try%lwt Ocsipersist.find cred_table credential
with Not_found -> fail InvalidCredential
and old_record =
try_lwt
lwt x = Ocsipersist.find records_table user in
try%lwt
let%lwt x = Ocsipersist.find records_table user in
Lwt.return (Some x)
with Not_found -> Lwt.return None
in
......@@ -144,7 +144,7 @@ module Make (D : ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELE
) >> fail ReusedCredential
let do_update_cred ~old ~new_ =
match_lwt Ocsipersist.fold_step (fun k v x ->
match%lwt Ocsipersist.fold_step (fun k v x ->
if sha256_hex k = old then (
match v with
| Some _ -> fail UsedCredential
......@@ -185,7 +185,7 @@ module Make (D : ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELE
let cast rawballot (user, date) =
Lwt_mutex.with_lock mutex (fun () ->
lwt r = do_cast rawballot (user, date) in
let%lwt r = do_cast rawballot (user, date) in
do_write_ballots () >>
do_write_records () >>
return r
......@@ -193,7 +193,7 @@ module Make (D : ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELE
let update_cred ~old ~new_ =
Lwt_mutex.with_lock mutex (fun () ->
lwt r = do_update_cred ~old ~new_ in
let%lwt r = do_update_cred ~old ~new_ in
do_write_creds () >> return r
)
......@@ -205,7 +205,7 @@ module Make (D : ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB_ELE
)
let compute_encrypted_tally () =
lwt num_tallied, tally =
let%lwt num_tallied, tally =
Ocsipersist.fold_step
(fun _ rawballot (n, accu) ->
let ballot = ballot_of_string G.read rawballot in
......
......@@ -64,16 +64,16 @@ let () =
(** Parse configuration from other sources *)
let file_exists x =
try_lwt
try%lwt
Lwt_unix.(access x [R_OK]) >>
return true
with _ ->
return false
lwt source_file =
let%lwt source_file =
match !source_file with
| Some f ->
lwt b = file_exists f in
let%lwt b = file_exists f in
if b then (
return f
) else (
......
......@@ -29,7 +29,7 @@ open Web_common
let ( / ) = Filename.concat
let get_election_result uuid =
try_lwt
try%lwt
Lwt_io.chars_of_file (!spool_dir / uuid / "result.json") |>
Lwt_stream.to_string >>= fun x ->
return @@ Some (result_of_string (Yojson.Safe.from_lexbuf ~stream:true) x)
......@@ -46,7 +46,7 @@ type election_state =
let election_states = Ocsipersist.open_table "election_states"
let get_election_state x =
try_lwt Ocsipersist.find election_states x
try%lwt Ocsipersist.find election_states x
with Not_found -> return `Archived
let set_election_state x s =
......@@ -61,7 +61,7 @@ let set_election_date uuid d =
))
let get_election_date uuid =
try_lwt
try%lwt
Lwt_io.chars_of_file (!spool_dir / uuid / "dates.json") |>
Lwt_stream.to_string >>= fun x ->
let dates = election_dates_of_string x in
......@@ -72,7 +72,7 @@ let get_election_date uuid =
let election_pds = Ocsipersist.open_table "election_pds"
let get_partial_decryptions x =
try_lwt Ocsipersist.find election_pds x
try%lwt Ocsipersist.find election_pds x
with Not_found -> return []
let set_partial_decryptions x pds =
......@@ -81,16 +81,16 @@ let set_partial_decryptions x pds =
let auth_configs = Ocsipersist.open_table "auth_configs"
let get_auth_config x =
try_lwt Ocsipersist.find auth_configs x
try%lwt Ocsipersist.find auth_configs x
with Not_found -> return []
let set_auth_config x c =
Ocsipersist.add auth_configs x c
let get_raw_election uuid =
try_lwt
try%lwt
let lines = Lwt_io.lines_of_file (!spool_dir / uuid / "election.json") in
begin match_lwt Lwt_stream.to_list lines with
begin match%lwt Lwt_stream.to_list lines with
| x :: _ -> return @@ Some x
| [] -> return_none
end
......@@ -106,7 +106,7 @@ let empty_metadata = {
let return_empty_metadata = return empty_metadata
let get_election_metadata uuid =
try_lwt
try%lwt
Lwt_io.chars_of_file (!spool_dir / uuid / "metadata.json") |>
Lwt_stream.to_string >>= fun x ->
return @@ metadata_of_string x
......@@ -116,16 +116,16 @@ let get_elections_by_owner user =
Lwt_unix.files_of_directory !spool_dir |>
Lwt_stream.filter_s (fun x ->
if x = "." || x = ".." then return false else
lwt metadata = get_election_metadata x in
let%lwt metadata = get_election_metadata x in
match metadata.e_owner with
| Some o -> return (o = user)
| None -> return false
) |> Lwt_stream.to_list
let get_voters uuid =
try_lwt
try%lwt
let lines = Lwt_io.lines_of_file (!spool_dir / uuid / "voters.txt") in
lwt lines = Lwt_stream.to_list lines in
let%lwt lines = Lwt_stream.to_list lines in
return @@ Some lines
with _ -> return_none
......@@ -156,7 +156,7 @@ end
module BallotsCache = Ocsigen_cache.Make (BallotsCacheTypes)
let raw_get_ballots_archived uuid =
try_lwt
try%lwt
let ballots = Lwt_io.lines_of_file (!spool_dir / uuid / "ballots.jsons") in
Lwt_stream.fold (fun b accu ->
let hash = sha256_b64 b in
......@@ -168,9 +168,9 @@ let archived_ballots_cache =
new BallotsCache.cache raw_get_ballots_archived 10
let get_ballot_hashes ~uuid =
match_lwt get_election_state uuid with
match%lwt get_election_state uuid with
| `Archived ->
lwt ballots = archived_ballots_cache#find uuid in
let%lwt ballots = archived_ballots_cache#find uuid in
Ballots.bindings ballots |> List.map fst |> return
| _ ->
let table = Ocsipersist.open_table ("ballots_" ^ underscorize uuid) in
......@@ -179,11 +179,11 @@ let get_ballot_hashes ~uuid =
) table [] >>= (fun x -> return @@ List.rev x)
let get_ballot_by_hash ~uuid ~hash =
match_lwt get_election_state uuid with
match%lwt get_election_state uuid with
| `Archived ->
lwt ballots = archived_ballots_cache#find uuid in
let%lwt ballots = archived_ballots_cache#find uuid in
(try Some (Ballots.find hash ballots) with Not_found -> None) |> return
| _ ->
let table = Ocsipersist.open_table ("ballots_" ^ underscorize uuid) in
try_lwt Ocsipersist.find table hash >>= (fun x -> return @@ Some x)
try%lwt Ocsipersist.find table hash >>= (fun x -> return @@ Some x)
with Not_found -> return_none
This diff is collapsed.
......@@ -37,7 +37,7 @@ let show_cookie_disclaimer = Eliom_reference.eref ~scope true
let user = Eliom_reference.eref ~scope None
let get_site_user () =
match_lwt Eliom_reference.get user with
match%lwt Eliom_reference.get user with
| None -> return None
| Some u ->
match u.uuid with
......@@ -49,7 +49,7 @@ let get_site_user () =
| Some _ -> return None
let get_election_user uuid =
match_lwt Eliom_reference.get user with
match%lwt Eliom_reference.get user with
| None -> return None
| Some u ->
match u.uuid with
......@@ -68,12 +68,12 @@ let cont = Eliom_reference.eref ~scope []
let cont_push f =
let open Eliom_reference in
lwt fs = get cont in
let%lwt fs = get cont in
set cont (f :: fs)
let cont_pop () =
let open Eliom_reference in
lwt fs = get cont in
let%lwt fs = get cont in
match fs with
| f :: fs -> set cont fs >> return (Some f)
| [] -> return None
......
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment