Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

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

Use per-election authentication

 - base template is abstracted over login_box
 - per-election templates and services (except those related to
   update_credentials) refer to per-election auth services
 - login templates are parametrized over AUTH_SERVICES
parent bffc83d8
......@@ -33,7 +33,7 @@ module type CONFIG = sig
val server : string
end
module Make (C : CONFIG) (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
module Make (C : CONFIG) (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = struct
let scope = Eliom_common.default_session_scope
......
......@@ -35,7 +35,7 @@ let parse_config ~instance ~attributes =
"invalid configuration for instance %s of auth/%s"
instance name
module Make (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
module Make (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = struct
let scope = Eliom_common.default_session_scope
......@@ -63,7 +63,7 @@ module Make (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
cont user_name ()
| None -> fail_http 400
)
in T.login_dummy ~service ()
in T.dummy ~service ()
)
let login cont () =
......
......@@ -40,7 +40,7 @@ module type CONFIG = sig
val db : string
end
module Make (C : CONFIG) (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
module Make (C : CONFIG) (N : NAME) (T : LOGIN_TEMPLATES) : AUTH_HANDLERS = struct
let scope = Eliom_common.default_session_scope
......@@ -84,7 +84,7 @@ module Make (C : CONFIG) (N : NAME) (T : TEMPLATES) : AUTH_HANDLERS = struct
cont user_name ()
| None -> fail_http 400
) else forbidden ())
in T.login_password ~service ()
in T.password ~service ()
)
let login cont () =
......
......@@ -81,21 +81,6 @@ module Make (N : CONFIG) = struct
A.login cont ()
with Not_found -> fail_http 404
let login_handler service cont =
let cont () () =
match service with
| Some name -> do_login_using name cont
| None ->
match !auth_instance_names with
| [name] -> do_login_using name cont
| _ -> !login_choose () >>= Eliom_registration.Html5.send
in
match_lwt Eliom_reference.get user with
| Some u ->
let module A = (val u.user_handlers) in
A.logout cont ()
| None -> cont () ()
module Services : AUTH_SERVICES = struct
let get_auth_systems () = !auth_instance_names
......@@ -117,6 +102,21 @@ module Make (N : CONFIG) = struct
end
let login_handler service cont =
let cont () () =
match service with
| Some name -> do_login_using name cont
| None ->
match !auth_instance_names with
| [name] -> do_login_using name cont
| _ -> !login_choose () >>= Eliom_registration.Html5.send
in
match_lwt Eliom_reference.get user with
| Some u ->
let module A = (val u.user_handlers) in
A.logout cont ()
| None -> cont () ()
module Handlers : AUTH_HANDLERS_PUBLIC = struct
let do_login cont () = login_handler None cont
......@@ -135,9 +135,9 @@ module Make (N : CONFIG) = struct
end
module Register (S : SITE) (T : TEMPLATES) : EMPTY = struct
module Register (S : SITE) (T : LOGIN_TEMPLATES) : EMPTY = struct
let () = login_choose := T.login_choose
let () = login_choose := T.choose
let () = List.iter (fun auth_instance ->
let {
......
......@@ -36,5 +36,5 @@ end
module Make (C : CONFIG) : sig
module Services : AUTH_SERVICES
module Handlers : AUTH_HANDLERS_PUBLIC
module Register (S : SITE) (T : TEMPLATES) : EMPTY
module Register (S : SITE) (T : LOGIN_TEMPLATES) : EMPTY
end
......@@ -76,6 +76,7 @@ let make config =
module G = (val Election.finite_field group : Election.FF_GROUP)
module M = MakeLwtRandom(struct let rng = make_rng () end)
module E = Election.MakeElection(G)(M)
module H = Auth.Handlers
let election = {e_params; e_pks = None; e_fingerprint}
let metadata = config.metadata
......@@ -244,7 +245,6 @@ let make config =
module S : ELECTION_SERVICES = struct
include Auth.Services
include Auth.Handlers
let make_path x = base_path @ x
let root = make_path [""]
......@@ -305,12 +305,12 @@ let make config =
module Register (S : SITE) (T : TEMPLATES) : EMPTY = struct
open Eliom_registration
let () = let module X : EMPTY = Auth.Register (S) (T) in ()
let () = let module X : EMPTY = Auth.Register (S) (T.Login (W.S)) in ()
module T = T.Election (W)
let if_eligible acl f () x =
lwt user = S.get_user () in
lwt user = W.S.get_user () in
if acl config.metadata user then
f user x
else
......@@ -330,7 +330,7 @@ let make config =
| Some result ->
Eliom_reference.unset cast_confirmed >>
T.cast_confirmed ~result ()
| None -> T.home ~user ()
| None -> T.home ()
)
)
......@@ -452,7 +452,7 @@ let make config =
| Some the_ballot ->
begin
Eliom_reference.unset ballot >>
match_lwt S.get_user () with
match_lwt W.S.get_user () with
| Some u ->
let b = check_acl W.metadata.e_voters u in
if b then (
......@@ -469,7 +469,7 @@ let make config =
Eliom_reference.unset ballot >>
Eliom_reference.set cast_confirmed (Some result) >>
let cont () () = Redirection.send W.S.home in
S.do_logout cont ()
W.H.do_logout cont ()
) else forbidden ()
| None -> forbidden ()
end
......@@ -488,7 +488,7 @@ let make config =
service
in
let can_vote = can_vote W.metadata user in
T.cast_confirmation ~confirm ~user ~can_vote ()
T.cast_confirmation ~confirm ~can_vote ()
let () = Html5.register
~service:W.S.election_cast
......@@ -517,7 +517,7 @@ let make config =
Eliom_reference.set S.cont cont >>
Eliom_reference.set ballot (Some the_ballot) >>
match user with
| None -> S.do_login cont ()
| None -> W.H.do_login cont ()
| Some u -> cont () ()
)
)
......
......@@ -214,7 +214,6 @@ end
module type ELECTION_TEMPLATES = sig
val home :
user:user option ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val update_credential :
......@@ -230,7 +229,6 @@ module type ELECTION_TEMPLATES = sig
[< Eliom_service.suff ], 'c, unit,
[< Eliom_service.registrable ], 'd)
Eliom_service.service) ->
user:user option ->
can_vote:bool ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
......@@ -256,6 +254,7 @@ end
module type WEB_ELECTION = sig
include WEB_ELECTION_RO
module B : WEB_BALLOT_BOX
module H : AUTH_HANDLERS_PUBLIC
end
module type SITE_SERVICES = sig
......@@ -272,13 +271,9 @@ module type SITE = sig
val cont : (unit -> service_handler) Eliom_reference.eref
end
module type TEMPLATES = sig
module type LOGIN_TEMPLATES = sig
val home :
featured:(module WEB_ELECTION_RO) list ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val login_dummy :
val dummy :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< string Eliom_parameter.setoneradio ]
......@@ -287,7 +282,7 @@ module type TEMPLATES = sig
Eliom_service.service ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val login_password :
val password :
service:(unit, 'a, [< Eliom_service.post_service_kind ],
[< Eliom_service.suff ], 'b,
[< string Eliom_parameter.setoneradio ]
......@@ -298,9 +293,18 @@ module type TEMPLATES = sig
Eliom_service.service ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val login_choose :
val choose :
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
end
module type TEMPLATES = sig
val home :
featured:(module WEB_ELECTION_RO) list ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
module Login (S : AUTH_SERVICES) : LOGIN_TEMPLATES
module Election (W : WEB_ELECTION_RO) : ELECTION_TEMPLATES
end
......@@ -312,7 +316,7 @@ end
module type AUTH_SERVICE =
functor (N : NAME) ->
functor (T : TEMPLATES) ->
functor (T : LOGIN_TEMPLATES) ->
AUTH_HANDLERS
module type AUTH_SYSTEM = sig
......
......@@ -101,7 +101,7 @@ module Make (C : CONFIG) : SITE = struct
if W.featured then featured := election_ro :: !featured;
return election
let () = let module X : EMPTY = Auth.Register (S) (T) in ()
let () = let module X : EMPTY = Auth.Register (S) (T.Login (S)) in ()
let () = Any.register ~service:home
(fun () () ->
......
......@@ -19,6 +19,7 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Signatures
open Util
open Serializable_t
......@@ -35,10 +36,47 @@ let welcome_message = "Welcome!"
let format_user u =
em [pcdata (Web_auth.(string_of_user u))]
let make_login_box auth =
let module S = (val auth : AUTH_SERVICES) in
lwt user = S.get_user () in
return @@ div ~a:[a_style "float: right; text-align: right;"] (
match user with
| Some user ->
[
div [
pcdata "Logged in as ";
format_user user;
pcdata ".";
];
div [
a ~service:S.logout [pcdata "Log out"] ();
pcdata ".";
];
]
| None ->
[
div [
pcdata "Not logged in.";
];
let auth_systems = List.map (fun name ->
let service = Eliom_service.preapply S.login (Some name) in
a ~service [pcdata name] ()
) (S.get_auth_systems ()) in
div (
[ pcdata "Login: " ] @
list_join (pcdata ", ") auth_systems @
[ pcdata "." ]
);
]
)
module Make (S : SITE_SERVICES) : TEMPLATES = struct
let base ~title ~content =
lwt user = S.get_user () in
let site_login_box =
let auth = (module S : AUTH_SERVICES) in
fun () -> make_login_box auth
let base ~title ~login_box ~content =
Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang "en"]
(head (Eliom_content.Html5.F.title (pcdata title)) [])
(body [
......@@ -47,36 +85,7 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
div ~a:[a_style "float: left;"] [
a ~service:S.home [pcdata site_title] ();
];
div ~a:[a_style "float: right; text-align: right;"] (
match user with
| Some user ->
[
div [
pcdata "Logged in as ";
format_user user;
pcdata ".";
];
div [
a ~service:S.logout [pcdata "Log out"] ();
pcdata ".";
];
]
| None ->
[
div [
pcdata "Not logged in.";
];
let auth_systems = List.map (fun name ->
let service = Eliom_service.preapply S.login (Some name) in
a ~service [pcdata name] ()
) (S.get_auth_systems ()) in
div (
[ pcdata "Login: " ] @
list_join (pcdata ", ") auth_systems @
[ pcdata "." ]
);
]
);
login_box;
div ~a:[a_style "clear: both;"] [];
];
];
......@@ -118,63 +127,75 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
featured_box;
];
] in
base ~title:site_title ~content
lwt login_box = site_login_box () in
base ~title:site_title ~login_box ~content
let login_dummy ~service () =
let title, field_name, input_type =
"Dummy login", "Username:", `Text
in
let form = post_form ~service
(fun name ->
[
tablex [tbody [
tr [
th [label ~a:[a_for name] [pcdata field_name]];
td [string_input ~a:[a_maxlength 50] ~input_type ~name ()];
]]
];
div [
string_input ~input_type:`Submit ~value:"Login" ();
]
]) ()
in
let content = [
h1 [pcdata title];
form;
] in
base ~title ~content
module Login (S : AUTH_SERVICES) : LOGIN_TEMPLATES = struct
let login_password ~service () =
let form = post_form ~service
(fun (llogin, lpassword) ->
[
tablex [tbody [
tr [
th [label ~a:[a_for llogin] [pcdata "Username:"]];
td [string_input ~a:[a_maxlength 50] ~input_type:`Text ~name:llogin ()];
];
tr [
th [label ~a:[a_for lpassword] [pcdata "Password:"]];
td [string_input ~a:[a_maxlength 50] ~input_type:`Password ~name:lpassword ()];
let login_box =
let auth = (module S : AUTH_SERVICES) in
fun () -> make_login_box auth
let dummy ~service () =
let title, field_name, input_type =
"Dummy login", "Username:", `Text
in
let form = post_form ~service
(fun name ->
[
tablex [tbody [
tr [
th [label ~a:[a_for name] [pcdata field_name]];
td [string_input ~a:[a_maxlength 50] ~input_type ~name ()];
]]
];
]];
div [
string_input ~input_type:`Submit ~value:"Login" ();
]
]) ()
in
let content = [
h1 [pcdata "Password login"];
form;
] in
base ~title:"Password login" ~content
div [
string_input ~input_type:`Submit ~value:"Login" ();
]
]) ()
in
let content = [
h1 [pcdata title];
form;
] in
lwt login_box = login_box () in
base ~title ~login_box ~content
let login_choose () =
let content = [
h1 [pcdata "Log in"];
div [p [pcdata "Please choose one authentication system."]];
] in
base ~title:"Log in" ~content
let password ~service () =
let form = post_form ~service
(fun (llogin, lpassword) ->
[
tablex [tbody [
tr [
th [label ~a:[a_for llogin] [pcdata "Username:"]];
td [string_input ~a:[a_maxlength 50] ~input_type:`Text ~name:llogin ()];
];
tr [
th [label ~a:[a_for lpassword] [pcdata "Password:"]];
td [string_input ~a:[a_maxlength 50] ~input_type:`Password ~name:lpassword ()];
];
]];
div [
string_input ~input_type:`Submit ~value:"Login" ();
]
]) ()
in
let content = [
h1 [pcdata "Password login"];
form;
] in
lwt login_box = login_box () in
base ~title:"Password login" ~login_box ~content
let choose () =
let content = [
h1 [pcdata "Log in"];
div [p [pcdata "Please choose one authentication system."]];
] in
lwt login_box = login_box () in
base ~title:"Log in" ~login_box ~content
end
let format_date (date, _) =
CalendarLib.Printer.Precise_Fcalendar.sprint "%a, %d %b %Y %T %z" date
......@@ -188,9 +209,14 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
module Election (W : WEB_ELECTION_RO) = struct
let election_login_box =
let auth = (module W.S : AUTH_SERVICES) in
fun () -> make_login_box auth
let file x = Eliom_service.preapply W.S.election_dir x
let home ~user () =
let home () =
lwt user = W.S.get_user () in
let params = W.election.e_params and m = W.metadata in
lwt permissions =
match user with
......@@ -284,7 +310,8 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
br ();
audit_info;
] in
base ~title:params.e_name ~content
lwt login_box = election_login_box () in
base ~title:params.e_name ~login_box ~content
let update_credential () =
let params = W.election.e_params in
......@@ -324,7 +351,8 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
h1 [ pcdata params.e_name ];
form;
] in
base ~title:params.e_name ~content
lwt login_box = election_login_box () in
base ~title:params.e_name ~login_box ~content
let cast_raw () =
let params = W.election.e_params in
......@@ -356,9 +384,11 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
h3 [ pcdata "Submit by file" ];
form_upload;
] in
base ~title:params.e_name ~content
lwt login_box = site_login_box () in
base ~title:params.e_name ~login_box ~content
let cast_confirmation ~confirm ~user ~can_vote () =
let cast_confirmation ~confirm ~can_vote () =
lwt user = W.S.get_user () in
let params = W.election.e_params in
let name = params.e_name in
let user_div = match user with
......@@ -397,7 +427,8 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
pcdata ".";
];
] in
base ~title:name ~content
lwt login_box = election_login_box () in
base ~title:name ~login_box ~content
let cast_confirmed ~result () =
let params = W.election.e_params in
......@@ -419,7 +450,8 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
pcdata ".";
];
] in
base ~title:name ~content
lwt login_box = election_login_box () in
base ~title:name ~login_box ~content
end
......
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