Commit d17925d2 authored by Stephane Glondu's avatar Stephane Glondu

Do no longer use deprecated lwt constructs (>> and [%lwt ...])

parent 5cd038ef
......@@ -54,8 +54,8 @@ let dummy_handler () name =
match%lwt Eliom_reference.get auth_env with
| None -> failwith "dummy handler was invoked without environment"
| Some (uuid, service, _) ->
Eliom_reference.set user (Some {uuid; service; name}) >>
Eliom_reference.unset auth_env >>
let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
let%lwt () = Eliom_reference.unset auth_env in
default_cont uuid ()
let () = Eliom_registration.Any.register ~service:dummy_post dummy_handler
......@@ -98,8 +98,8 @@ let password_handler () (name, password) =
check_password_with_file db name password
in
if ok then
Eliom_reference.set user (Some {uuid; service; name}) >>
Eliom_reference.unset auth_env >>
let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
let%lwt () = Eliom_reference.unset auth_env in
default_cont uuid ()
else
fail_http 401
......@@ -149,7 +149,7 @@ let get_cas_validation server ticket =
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
let%lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
let%lwt () = Ocsigen_stream.finalize stream `Success in
return (parse_cas_validation info)
| None -> return (`Error `Http)
......@@ -168,13 +168,13 @@ let cas_handler ticket () =
in
(match%lwt get_cas_validation server x with
| `Yes (Some name) ->
Eliom_reference.set user (Some {uuid; service; name}) >>
let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
default_cont uuid ()
| `No -> fail_http 401
| `Yes None | `Error _ -> fail_http 502)
| None ->
Eliom_reference.unset cas_server >>
Eliom_reference.unset auth_env >>
let%lwt () = Eliom_reference.unset cas_server in
let%lwt () = Eliom_reference.unset auth_env in
default_cont uuid ()
let () = Eliom_registration.Any.register ~service:login_cas cas_handler
......@@ -182,7 +182,7 @@ let () = Eliom_registration.Any.register ~service:login_cas cas_handler
let cas_login_handler config () =
match config with
| [server] ->
Eliom_reference.set cas_server (Some server) >>
let%lwt () = Eliom_reference.set cas_server (Some server) in
let cas_login = Eliom_service.extern
~prefix:server
~path:["login"]
......@@ -219,7 +219,7 @@ let oidc_get_userinfo ocfg info =
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
let%lwt () = Ocsigen_stream.finalize stream `Success in
let x = oidc_userinfo_of_string info in
return (Some (match x.oidc_email with Some x -> x | None -> x.oidc_sub))
| None -> return None
......@@ -236,7 +236,7 @@ let oidc_get_name ocfg client_id client_secret code =
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
let%lwt () = Ocsigen_stream.finalize stream `Success in
oidc_get_userinfo ocfg info
| None -> return None
......@@ -255,12 +255,12 @@ let oidc_handler params () =
| None -> failwith "oidc handler was invoked without a state"
| Some x -> return x
in
Eliom_reference.unset oidc_state >>
Eliom_reference.unset auth_env >>
let%lwt () = Eliom_reference.unset oidc_state in
let%lwt () = Eliom_reference.unset auth_env in
if state <> st then fail_http 401 else
(match%lwt oidc_get_name ocfg client_id client_secret code with
| Some name ->
Eliom_reference.set user (Some {uuid; service; name}) >>
let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
default_cont uuid ()
| None -> fail_http 401)
| _, _ -> default_cont uuid ()
......@@ -273,7 +273,7 @@ let get_oidc_configuration server =
match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
let%lwt () = Ocsigen_stream.finalize stream `Success in
return (oidc_configuration_of_string info)
| None -> fail_http 404
......@@ -287,7 +287,7 @@ let oidc_login_handler config () =
| [server; client_id; client_secret] ->
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%lwt () = Eliom_reference.set oidc_state (Some (ocfg, client_id, client_secret, state)) in
let prefix, path = split_prefix_path ocfg.authorization_endpoint in
let auth_endpoint = Eliom_service.extern ~prefix ~path
~meth:(Eliom_service.Get Eliom_parameter.(string "redirect_uri" **
......@@ -304,7 +304,7 @@ let oidc_login_handler config () =
(** Generic authentication *)
let get_login_handler service uuid auth_system config =
Eliom_reference.set auth_env (Some (uuid, service, config)) >>
let%lwt () = Eliom_reference.set auth_env (Some (uuid, service, config)) in
match auth_system with
| "dummy" -> Web_templates.login_dummy () >>= Eliom_registration.Html.send
| "cas" -> cas_login_handler config ()
......@@ -320,7 +320,7 @@ let login_handler service uuid =
in
match%lwt Eliom_reference.get user with
| Some _ ->
cont_push (fun () -> Eliom_registration.(Redirection.send (Redirection (myself service)))) >>
let%lwt () = cont_push (fun () -> Eliom_registration.(Redirection.send (Redirection (myself service)))) in
Web_templates.already_logged_in () >>= Eliom_registration.Html.send
| None ->
let%lwt c = match uuid with
......@@ -349,7 +349,7 @@ let login_handler service uuid =
Eliom_registration.Html.send
let logout_handler () =
Eliom_reference.unset Web_state.user >>
let%lwt () = Eliom_reference.unset Web_state.user in
match%lwt cont_pop () with
| Some f -> f ()
| None -> Eliom_registration.(Redirection.send (Redirection Web_services.home))
......
......@@ -102,20 +102,19 @@ let open_security_log f =
let security_log s =
match !security_logfile with
| None -> return ()
| Some ic -> Lwt_io.atomic (fun ic ->
Lwt_io.write ic (
string_of_datetime (now ())
) >>
Lwt_io.write ic ": " >>
Lwt_io.write_line ic (s ()) >>
Lwt_io.flush ic
| Some ic ->
Lwt_io.atomic (fun ic ->
let%lwt () = Lwt_io.write ic (string_of_datetime (now ())) in
let%lwt () = Lwt_io.write ic ": " in
let%lwt () = Lwt_io.write_line ic (s ()) in
Lwt_io.flush ic
) ic
let fail_http status =
[%lwt raise (
Ocsigen_extensions.Ocsigen_http_error
(Ocsigen_cookies.empty_cookieset, status)
)]
Lwt.fail (
Ocsigen_extensions.Ocsigen_http_error
(Ocsigen_cookies.empty_cookieset, status)
)
let forbidden () = fail_http 403
......@@ -223,7 +222,8 @@ let send_email recipient subject body =
try%lwt
Lwt_preemptive.detach sendmail contents
with Unix.Unix_error (Unix.EAGAIN, _, _) ->
Lwt_unix.sleep 1. >> loop ()
let%lwt () = Lwt_unix.sleep 1. in
loop ()
in loop ()
let split_identity x =
......@@ -269,7 +269,7 @@ let extract_email =
let file_exists x =
try%lwt
Lwt_unix.(access x [R_OK]) >>
let%lwt () = Lwt_unix.(access x [R_OK]) in
return true
with _ ->
return false
......@@ -290,11 +290,14 @@ let read_file ?uuid x =
let write_file ?uuid x lines =
let fname = get_fname uuid x in
let fname_new = fname ^ ".new" in
Lwt_io.(
with_file Output fname_new (fun oc ->
Lwt_list.iter_s (write_line oc) lines
)
) >> Lwt_unix.rename fname_new fname
let%lwt () =
Lwt_io.(
with_file Output fname_new (fun oc ->
Lwt_list.iter_s (write_line oc) lines
)
)
in
Lwt_unix.rename fname_new fname
let cleanup_file f =
try%lwt Lwt_unix.unlink f
......
......@@ -65,10 +65,12 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
let user = string_of_user user 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 () >>
let%lwt () = if not voting_open then fail ElectionClosed else return_unit in
let%lwt () =
if String.contains rawballot '\n' then (
fail (Serialization (Invalid_argument "multiline ballot"))
) else return_unit
in
let%lwt ballot =
try Lwt.return (ballot_of_string G.read rawballot)
with e -> fail (Serialization e)
......@@ -90,9 +92,9 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
let%lwt b = Lwt_preemptive.detach E.check_ballot ballot in
if b then (
let%lwt hash = Web_persist.add_ballot uuid rawballot in
Web_persist.add_credential_mapping uuid credential (Some hash) >>
Web_persist.add_extended_record uuid user (date, credential) >>
send_confirmation_email false login email hash >>
let%lwt () = Web_persist.add_credential_mapping uuid credential (Some hash) in
let%lwt () = Web_persist.add_extended_record uuid user (date, credential) in
let%lwt () = send_confirmation_email false login email hash in
return hash
) else (
fail ProofCheck
......@@ -103,26 +105,41 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
let%lwt b = Lwt_preemptive.detach E.check_ballot ballot in
if b then (
let%lwt hash = Web_persist.replace_ballot uuid h rawballot in
Web_persist.add_credential_mapping uuid credential (Some hash) >>
Web_persist.add_extended_record uuid user (date, credential) >>
send_confirmation_email true login email hash >>
let%lwt () = Web_persist.add_credential_mapping uuid credential (Some hash) in
let%lwt () = Web_persist.add_extended_record uuid user (date, credential) in
let%lwt () = send_confirmation_email true login email hash in
return hash
) else (
fail ProofCheck
)
) else (
security_log (fun () ->
Printf.sprintf "%s attempted to revote with already used credential %s" user credential
) >> fail WrongCredential
let%lwt () =
security_log (fun () ->
Printf.sprintf
"%s attempted to revote with already used credential %s"
user credential
)
in
fail WrongCredential
)
| None, Some _ ->
security_log (fun () ->
Printf.sprintf "%s attempted to revote using a new credential %s" user credential
) >> fail RevoteNotAllowed
let%lwt () =
security_log (fun () ->
Printf.sprintf
"%s attempted to revote using a new credential %s"
user credential
)
in
fail RevoteNotAllowed
| Some _, None ->
security_log (fun () ->
Printf.sprintf "%s attempted to vote with already used credential %s" user credential
) >> fail ReusedCredential
let%lwt () =
security_log (fun () ->
Printf.sprintf
"%s attempted to vote with already used credential %s"
user credential
)
in
fail ReusedCredential
let mutex = Lwt_mutex.create ()
......
......@@ -298,8 +298,8 @@ let add_ballot uuid ballot =
let hash = sha256_b64 ballot in
let ballots_dir = !spool_dir / raw_string_of_uuid uuid / "ballots" in
let%lwt () = try%lwt Lwt_unix.mkdir ballots_dir 0o755 with _ -> return_unit in
write_file (ballots_dir / urlize hash) [ballot] >>
dump_ballots uuid >>
let%lwt () = write_file (ballots_dir / urlize hash) [ballot] in
let%lwt () = dump_ballots uuid in
return hash
let remove_ballot uuid hash =
......@@ -307,7 +307,7 @@ let remove_ballot uuid hash =
try%lwt Lwt_unix.unlink (ballots_dir / urlize hash) with _ -> return_unit
let replace_ballot uuid hash ballot =
remove_ballot uuid hash >>
let%lwt () = remove_ballot uuid hash in
add_ballot uuid ballot
let compute_encrypted_tally uuid =
......@@ -360,7 +360,7 @@ let dump_extended_records uuid rs =
Printf.sprintf "%s %S\n" (string_of_datetime d) u
) rs
in
write_file ~uuid "extended_records.jsons" extended_records >>
let%lwt () = write_file ~uuid "extended_records.jsons" extended_records in
write_file ~uuid (string_of_election_file ESRecords) records
let extended_records_cache =
......@@ -406,7 +406,7 @@ let dump_credential_mappings uuid xs =
) xs
in
let creds = List.map fst xs in
write_file ~uuid "credential_mappings.jsons" mappings >>
let%lwt () = write_file ~uuid "credential_mappings.jsons" mappings in
write_file ~uuid "public_creds.txt" creds
let credential_mappings_cache =
......
This diff is collapsed.
......@@ -73,7 +73,9 @@ let cont_pop () =
let open Eliom_reference in
let%lwt fs = get cont in
match fs with
| f :: fs -> set cont fs >> return (Some f)
| f :: fs ->
let%lwt () = set cont fs in
return (Some f)
| [] -> return None
......
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