Commit 57769b38 authored by Stephane Glondu's avatar Stephane Glondu

Make continuations more explicit and drop Web_state.cont

parent 58081fc5
Pipeline #54804 passed with stages
in 11 minutes and 38 seconds
......@@ -23,7 +23,6 @@ open Lwt
open Eliom_service
open Web_serializable_j
open Web_common
open Web_state
open Web_services
type auth_config = (string * string) list
......@@ -37,20 +36,10 @@ let scope = Eliom_common.default_session_scope
let auth_env = Eliom_reference.eref ~scope None
let default_cont uuid () =
match%lwt cont_pop () with
| Some f -> f ()
| None ->
match uuid with
| None ->
Eliom_registration.(Redirection.send (Redirection Web_services.admin))
| Some u ->
Eliom_registration.(Redirection.send (Redirection (preapply Web_services.election_home (u, ()))))
let run_post_login_handler auth_system f =
match%lwt Eliom_reference.get auth_env with
| None -> Printf.ksprintf failwith "%s handler was invoked without environment" auth_system
| Some (uuid, service, config) ->
| Some (uuid, service, config, cont) ->
let%lwt () = Eliom_reference.unset auth_env in
let authenticate name =
let user = { user_domain = service; user_name = name } in
......@@ -59,14 +48,14 @@ let run_post_login_handler auth_system f =
| Some uuid -> Eliom_reference.set Web_state.election_user (Some (uuid, user))
in
let%lwt () = f uuid config authenticate in
default_cont uuid ()
cont ()
type pre_login_handler = auth_config -> result Lwt.t
let pre_login_handlers = ref []
let get_pre_login_handler service uuid auth_system config =
let%lwt () = Eliom_reference.set auth_env (Some (uuid, service, config)) in
let get_pre_login_handler service uuid auth_system cont config =
let%lwt () = Eliom_reference.set auth_env (Some (uuid, service, config, cont)) in
match List.assoc_opt auth_system !pre_login_handlers with
| Some handler -> handler config
| None -> fail_http 404
......@@ -79,20 +68,35 @@ let rec find_auth_instance x = function
| { auth_instance = i; auth_system = s; auth_config = c } :: _ when i = x -> Some (s, c)
| _ :: xs -> find_auth_instance x xs
let login_handler service uuid =
let get_cont login_or_logout x =
let open Eliom_registration in
let redir = match x with
| `Election uuid -> Redirection (preapply election_cast uuid)
| `Site ContSiteHome -> Redirection home
| `Site ContSiteAdmin -> Redirection admin
| `Site (ContSiteElection uuid) ->
match login_or_logout with
| `Login -> Redirection (preapply election_admin uuid)
| `Logout -> Redirection (preapply election_home (uuid, ()))
in
fun () -> Redirection.send redir
let login_handler service kind =
let uuid = match kind with
| `Site _ -> None
| `Election uuid -> Some uuid
in
let myself service =
match uuid with
| None -> preapply site_login service
| Some u -> preapply election_login ((u, ()), service)
match kind with
| `Site cont -> preapply site_login (service, cont)
| `Election uuid -> preapply election_login ((uuid, ()), service)
in
let%lwt user = match uuid with
| None -> Eliom_reference.get Web_state.site_user
| Some uuid -> Web_state.get_election_user uuid
in
match user with
| Some _ ->
let%lwt () = cont_push (fun () -> Eliom_registration.(Redirection.send (Redirection (myself service)))) in
Web_templates.already_logged_in () >>= Eliom_registration.Html.send
| Some _ -> get_cont `Login kind ()
| None ->
let%lwt c = match uuid with
| None -> return !Web_config.site_auth_config
......@@ -105,32 +109,31 @@ let login_handler service uuid =
| Some x -> return x
| None -> fail_http 404
in
get_pre_login_handler s uuid auth_system config
let cont = get_cont `Login kind in
get_pre_login_handler s uuid auth_system cont config
| None ->
match c with
| [s] -> Eliom_registration.(Redirection.send (Redirection (myself (Some s.auth_instance))))
| _ ->
let builder =
match uuid with
| None -> fun s ->
preapply Web_services.site_login (Some s)
| Some u -> fun s ->
preapply Web_services.election_login ((u, ()), Some s)
match kind with
| `Site cont -> fun s ->
preapply Web_services.site_login (Some s, cont)
| `Election uuid -> fun s ->
preapply Web_services.election_login ((uuid, ()), Some s)
in
Web_templates.login_choose (List.map (fun x -> x.auth_instance) c) builder () >>=
Eliom_registration.Html.send
let logout_handler () =
let logout_handler cont =
let%lwt () = Eliom_reference.unset Web_state.site_user in
match%lwt cont_pop () with
| Some f -> f ()
| None -> Eliom_registration.(Redirection.send (Redirection Web_services.home))
get_cont `Logout (`Site cont) ()
let () = Eliom_registration.Any.register ~service:site_login
(fun service () -> login_handler service None)
(fun (service, cont) () -> login_handler service (`Site cont))
let () = Eliom_registration.Any.register ~service:logout
(fun () () -> logout_handler ())
(fun cont () -> logout_handler cont)
let () = Eliom_registration.Any.register ~service:election_login
(fun ((uuid, ()), service) () -> login_handler service (Some uuid))
(fun ((uuid, ()), service) () -> login_handler service (`Election uuid))
......@@ -180,6 +180,29 @@ let uuid x =
~to_string:raw_string_of_uuid
x
type site_cont =
| ContSiteHome
| ContSiteAdmin
| ContSiteElection of uuid
let site_cont_of_string x =
match Pcre.split ~pat:"/" x with
| ["home"] -> ContSiteHome
| ["admin"] -> ContSiteAdmin
| ["elections"; uuid] -> ContSiteElection (uuid_of_raw_string uuid)
| _ -> invalid_arg "site_login_cont_of_string"
let string_of_site_cont = function
| ContSiteHome -> "home"
| ContSiteAdmin -> "admin"
| ContSiteElection uuid -> Printf.sprintf "elections/%s" (raw_string_of_uuid uuid)
let site_cont x =
Eliom_parameter.user_type
~of_string:site_cont_of_string
~to_string:string_of_site_cont
x
type privacy_cont =
| ContAdmin
| ContSignup
......
......@@ -83,6 +83,17 @@ val uuid :
[ `One of uuid ] Eliom_parameter.param_name)
Eliom_parameter.params_type
type site_cont =
| ContSiteHome
| ContSiteAdmin
| ContSiteElection of uuid
val site_cont :
string ->
(site_cont, [ `WithoutSuffix ],
[ `One of site_cont ] Eliom_parameter.param_name)
Eliom_parameter.params_type
type privacy_cont =
| ContAdmin
| ContSignup
......
......@@ -28,8 +28,8 @@ let uuid_and_token = uuid "uuid" ** string "token"
let home = create ~path:(Path [""]) ~meth:(Get unit) ()
let admin = create ~path:(Path ["admin"]) ~meth:(Get unit) ()
let privacy_notice_accept = create ~path:(Path ["accept-privacy"]) ~csrf_safe:true ~meth:(Post (privacy_cont "cont", unit)) ()
let site_login = create ~path:(Path ["login"]) ~meth:(Get (opt (string "service"))) ()
let logout = create ~path:(Path ["logout"]) ~meth:(Get unit) ()
let site_login = create ~path:(Path ["login"]) ~meth:(Get (opt (string "service") ** site_cont "cont")) ()
let logout = create ~path:(Path ["logout"]) ~meth:(Get (site_cont "cont")) ()
let source_code = create ~path:(Path ["belenios.tar.gz"]) ~meth:(Get unit) ()
......@@ -77,7 +77,7 @@ let election_draft_import_trustees = create ~path:(Path ["draft"; "import-truste
let election_draft_import_trustees_post = create_attached_post ~fallback:election_draft_import_trustees ~post_params:(string "from") ()
let election_home = create ~path:(Path ["elections"]) ~meth:(Get (suffix (uuid "uuid" ** suffix_const ""))) ()
let set_cookie_disclaimer = create ~path:No_path ~meth:(Get unit) ()
let set_cookie_disclaimer = create ~path:No_path ~meth:(Get (site_cont "cont")) ()
let election_admin = create ~path:(Path ["election"; "admin"]) ~meth:(Get (uuid "uuid")) ()
let election_regenpwd = create ~path:(Path ["election"; "regenpwd"]) ~meth:(Get (uuid "uuid")) ()
let election_regenpwd_post = create_attached_post ~fallback:election_regenpwd ~post_params:(string "user") ()
......@@ -111,7 +111,7 @@ let election_dir = create ~path:(Path ["elections"]) ~meth:(Get (suffix (uuid "u
let dummy_post = create ~path:No_path ~meth:(Post (unit, string "username")) ()
let password_post = create ~path:No_path ~meth:(Post (unit, string "username" ** string "password")) ()
let set_language = create ~path:No_path ~meth:(Get (string "lang")) ()
let set_language = create ~path:No_path ~meth:(Get (string "lang" ** site_cont "cont")) ()
let signup_captcha = create ~path:(Path ["signup"; ""]) ~meth:(Get (opt (captcha_error "error"))) ()
let signup_captcha_post = create_attached_post ~fallback:signup_captcha ~post_params:(string "challenge" ** string "response" ** string "email") ()
......
......@@ -336,10 +336,7 @@ let delete_election uuid =
return_unit
let () = Any.register ~service:home
(fun () () ->
let%lwt () = Eliom_reference.unset Web_state.cont in
Redirection.send (Redirection admin)
)
(fun () () -> Redirection.send (Redirection admin))
let get_elections_by_owner_sorted u =
let%lwt elections = Web_persist.get_elections_by_owner u in
......@@ -377,8 +374,6 @@ let () = Html.register ~service:admin
(fun () () ->
let%lwt gdpr = Eliom_reference.get Web_state.show_cookie_disclaimer in
if gdpr then T.privacy_notice ContAdmin else
let cont () = Redirection.send (Redirection admin) in
let%lwt () = Eliom_reference.set Web_state.cont [cont] in
let%lwt site_user = Eliom_reference.get Web_state.site_user in
let%lwt elections =
match site_user with
......@@ -1209,8 +1204,6 @@ let () =
try%lwt
let%lwt w = find_election uuid in
let%lwt () = Eliom_reference.unset Web_state.ballot in
let cont = redir_preapply election_home (uuid, ()) in
let%lwt () = Eliom_reference.set Web_state.cont [cont] in
match%lwt Eliom_reference.get Web_state.cast_confirmed with
| Some result ->
let%lwt () = Eliom_reference.unset Web_state.cast_confirmed in
......@@ -1227,19 +1220,20 @@ let () =
L.come_back_later ()
>>= Html.send)
let get_cont_state cont =
let redir = match cont with
| ContSiteHome -> Redirection home
| ContSiteAdmin -> Redirection admin
| ContSiteElection uuid -> Redirection (preapply election_home (uuid, ()))
in
fun () -> Redirection.send redir
let () =
Any.register ~service:set_cookie_disclaimer
(fun () () ->
(fun cont () ->
let%lwt () = Eliom_reference.set Web_state.show_cookie_disclaimer false in
let%lwt cont = Web_state.cont_pop () in
match cont with
| Some f -> f ()
| None ->
let%lwt lang = Eliom_reference.get Web_state.language in
let module L = (val Web_i18n.get_lang lang) in
T.generic_page ~title:L.cookies_are_blocked
L.please_enable_them ()
>>= Html.send)
get_cont_state cont ()
)
let () =
Any.register ~service:election_admin
......@@ -1263,9 +1257,7 @@ let () =
in
T.election_admin w metadata state get_tokens_decrypt () >>= Html.send
| _ ->
let cont = redir_preapply election_admin uuid in
let%lwt () = Eliom_reference.set Web_state.cont [cont] in
redir_preapply site_login None ()
redir_preapply site_login (None, ContSiteElection uuid) ()
)
let election_set_state state uuid () =
......@@ -1381,8 +1373,6 @@ let () =
Any.register ~service:election_cast
(fun uuid () ->
let%lwt w = find_election uuid in
let cont = redir_preapply election_cast uuid in
let%lwt () = Eliom_reference.set Web_state.cont [cont] in
match%lwt Eliom_reference.get Web_state.ballot with
| Some b -> T.cast_confirmation w (sha256_b64 b) () >>= Html.send
| None -> T.cast_raw w () >>= Html.send)
......@@ -1399,12 +1389,10 @@ let submit_ballot ballot =
| Some _ -> redir_preapply election_draft_questions uuid ()
| None ->
let%lwt user = Web_state.get_election_user uuid in
let cont = redir_preapply election_cast uuid in
let%lwt () = Eliom_reference.set Web_state.cont [cont] in
let%lwt () = Eliom_reference.set Web_state.ballot (Some ballot) in
match user with
| None -> redir_preapply election_login ((uuid, ()), None) ()
| Some _ -> cont ()
| Some _ -> redir_preapply election_cast uuid ()
let () =
Any.register ~service:election_submit_ballot
......@@ -1860,12 +1848,10 @@ let () =
let () =
Any.register ~service:set_language
(fun lang () ->
(fun (lang, cont) () ->
let%lwt () = Eliom_reference.set Web_state.language lang in
let%lwt cont = Web_state.cont_pop () in
match cont with
| Some f -> f ()
| None -> Redirection.send (Redirection home))
get_cont_state cont ()
)
let () =
Any.register ~service:election_draft_threshold_set
......
......@@ -33,23 +33,6 @@ let get_election_user uuid =
| Some (u, x) when u = uuid -> return (Some x)
| _ -> return None
let cont = Eliom_reference.eref ~scope []
let cont_push f =
let open Eliom_reference in
let%lwt fs = get cont in
set cont (f :: fs)
let cont_pop () =
let open Eliom_reference in
let%lwt fs = get cont in
match fs with
| f :: fs ->
let%lwt () = set cont fs in
return (Some f)
| [] -> return None
let ballot = Eliom_reference.eref ~scope None
let cast_confirmed = Eliom_reference.eref ~scope None
......
......@@ -20,7 +20,6 @@
(**************************************************************************)
open Web_serializable_t
open Web_signatures
val show_cookie_disclaimer : bool Eliom_reference.eref
......@@ -28,10 +27,6 @@ val site_user : user option Eliom_reference.eref
val election_user : (uuid * user) option Eliom_reference.eref
val get_election_user : uuid -> user option Lwt.t
val cont : (unit -> content) list Eliom_reference.eref
val cont_push : (unit -> content) -> unit Lwt.t
val cont_pop : unit -> (unit -> content) option Lwt.t
val ballot : string option Eliom_reference.eref
val cast_confirmed : [ `Error of Web_common.error | `Valid of string ] option Eliom_reference.eref
......
......@@ -46,12 +46,16 @@ let static x =
let format_user ~site u =
em [pcdata (if site then string_of_user u else u.user_name)]
let login_box () =
let login_box ?cont () =
let style = "float: right; text-align: right;" ^ admin_background in
let%lwt user = Eliom_reference.get Web_state.site_user in
let auth_systems = List.map (fun x -> x.auth_instance) !Web_config.site_auth_config in
let login x = Eliom_service.preapply site_login x in
let logout () = Eliom_service.preapply logout () in
let cont = match cont with
| None -> ContSiteHome
| Some x -> x
in
let login service = Eliom_service.preapply site_login (Some service, cont) in
let logout () = Eliom_service.preapply logout cont in
let body =
match user with
| Some user ->
......@@ -72,11 +76,10 @@ let login_box () =
pcdata "Not logged in.";
];
let auth_systems =
auth_systems |>
List.map (fun name ->
a ~a:[a_id ("login_" ^ name)]
~service:(login (Some name)) [pcdata name] ()
) |> List.join (pcdata ", ")
a ~a:[a_id ("login_" ^ name)]
~service:(login name) [pcdata name] ()
) auth_systems |> List.join (pcdata ", ")
in
div (
[pcdata "Log in: ["] @ auth_systems @ [pcdata "]"]
......@@ -208,7 +211,7 @@ let admin ~elections () =
contact;
]
] in
let%lwt login_box = login_box () in
let%lwt login_box = login_box ~cont:ContSiteAdmin () in
base ~title ~login_box ~content ()
| Some (draft, elections, tallied, archived) ->
let draft =
......@@ -1705,7 +1708,7 @@ let election_home election state () =
let languages =
div ~a:[a_class ["languages"]]
(list_concat (pcdata " ") @@ List.map (fun lang ->
a ~service:set_language [pcdata lang] lang
a ~service:set_language [pcdata lang] (lang, ContSiteElection uuid)
) available_languages)
in
let%lwt scd = Eliom_reference.get Web_state.show_cookie_disclaimer in
......@@ -1717,7 +1720,7 @@ let election_home election state () =
pcdata L.by_using_you_accept;
unsafe_a !Web_config.gdpr_uri L.privacy_policy;
pcdata ". ";
a ~service:set_cookie_disclaimer [pcdata L.accept] ();
a ~service:set_cookie_disclaimer [pcdata L.accept] (ContSiteElection uuid);
]
else pcdata ""
in
......@@ -2032,7 +2035,7 @@ let election_admin election metadata state get_tokens_decrypt () =
div_archive;
div_delete;
] in
let%lwt login_box = login_box () in
let%lwt login_box = login_box ~cont:(ContSiteElection uuid) () in
base ~title ~login_box ~content ()
let update_credential election () =
......@@ -2073,7 +2076,7 @@ let update_credential election () =
let content = [
form;
] in
let%lwt login_box = login_box () in
let%lwt login_box = login_box ~cont:(ContSiteElection uuid) () in
base ~title:params.e_name ~login_box ~content ~uuid ()
let regenpwd uuid () =
......@@ -2090,7 +2093,7 @@ let regenpwd uuid () =
in
let content = [ form ] in
let title = "Regenerate and mail password" in
let%lwt login_box = login_box () in
let%lwt login_box = login_box ~cont:(ContSiteElection uuid) () in
base ~title ~login_box ~content ~uuid ()
let cast_raw election () =
......@@ -2357,7 +2360,7 @@ let pretty_records election records () =
];
table;
] in
let%lwt login_box = login_box () in
let%lwt login_box = login_box ~cont:(ContSiteElection uuid) () in
base ~title ~login_box ~content ()
let tally_trustees election trustee_id token () =
......@@ -2435,16 +2438,6 @@ let tally_trustees election trustee_id token () =
] in
base ~title ~content ~uuid ()
let already_logged_in () =
let title = "Already logged in" in
let content = [
div [
pcdata "You are already logged in as an administrator or on another election. You have to ";
a ~service:logout [pcdata "log out"] ();
pcdata " first."];
] in
base ~title ~content ()
let login_choose auth_systems service () =
let auth_systems =
auth_systems |>
......
......@@ -63,9 +63,6 @@ val pretty_records : 'a election -> (string * string) list -> unit -> [> `Html ]
val tally_trustees : 'a election -> int -> string -> unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val already_logged_in :
unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val login_choose :
string list ->
(string -> (unit, unit, Eliom_service.get, 'a, 'b, 'c, 'd,
......
......@@ -449,9 +449,12 @@ pris en compte.
logout_element = browser.find_element_by_id(logout_link_css_id)
logout_element.click()
# She arrives back on the logged out home page. She checks that a login link is present
login_link_id = "login_local"
login_element = browser.find_element_by_id(login_link_id)
# She arrives on the election home page. She checks that the "Start" button is present
start_button_expected_label = "Start"
start_button_css_selector = "#main button"
start_button_element = browser.find_element_by_css_selector(start_button_css_selector)
start_button_real_label = start_button_element.get_attribute('innerText')
assert start_button_expected_label in start_button_real_label, 'Expected label "' + start_button_expected_label + '" not found in element label "' + start_button_real_label + "'"
def administrator_regenerates_passwords_for_some_voters(self):
......
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