Commit 3482da56 authored by Stephane Glondu's avatar Stephane Glondu

Redesign authentication

 - there is now a single Eliom reference holding the logged in user
 - per-election authentication is no longer handled by a submodule of
   WEB_ELECTION
 - the database of passwords for password authentication can only be
   initialized for the site from the configuration file
parent 3055f97a
......@@ -11,7 +11,7 @@ Web_serializable_j
Web_common
Web_persist
Web_services
Web_site_auth_state
Web_auth_state
Web_templates
Web_auth
Auth_dummy
......
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2015 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Web_serializable_t
open Web_signatures
type user = {
uuid: Uuidm.t option;
service : string;
name : string;
logout : unit -> content;
}
let scope = Eliom_common.default_session_scope
let user : user option Eliom_reference.eref =
Eliom_reference.eref ~scope None
let get_site_user () =
match_lwt Eliom_reference.get user with
| None -> return None
| Some u ->
match u.uuid with
| None ->
return @@ Some {
user_domain = u.service;
user_name = u.name;
}
| Some _ -> return None
let get_election_user uuid =
match_lwt Eliom_reference.get user with
| None -> return None
| Some u ->
match u.uuid with
| None -> return None
| Some uuid' ->
if Uuidm.equal uuid uuid' then
return @@ Some {
user_domain = u.service;
user_name = u.name
}
else
return None
let get_config uuid =
let uuid_s =
match uuid with
| None -> ""
| Some u -> Uuidm.to_string u
in
Web_persist.get_auth_config uuid_s
let cont : (unit -> content) list Eliom_reference.eref =
Eliom_reference.eref ~scope []
let cont_push f =
let open Eliom_reference in
lwt fs = get cont in
set cont (f :: fs)
let cont_pop () =
let open Eliom_reference in
lwt fs = get cont in
match fs with
| f :: fs -> set cont fs >> return (Some f)
| [] -> return None
let dummy_post = Eliom_service.Http.post_coservice'
~post_params:(Eliom_parameter.string "username")
()
let password_post = Eliom_service.Http.post_coservice'
~post_params:Eliom_parameter.(string "username" ** string "password")
()
......@@ -54,8 +54,13 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
| Some xs -> xs
end
module Auth = Web_auth.Make (N)
let () = Auth.configure N.auth_config
let configure_auth () =
let auth_config =
List.map (fun {auth_system; auth_instance; auth_config} ->
auth_instance, (auth_system, List.map snd auth_config)
) N.auth_config
in
Web_persist.set_auth_config uuid auth_config
include D
include P
......
......@@ -119,7 +119,7 @@ let spool_dir =
let () = Web_site.source_file := source_file
let () = Web_site.spool_dir := spool_dir
let () = Web_site_auth.configure !auth_instances
let () = Web_site_auth.configure (List.rev !auth_instances)
lwt () =
Lwt_list.iter_s (fun dir ->
......
......@@ -86,3 +86,12 @@ let get_partial_decryptions x =
let set_partial_decryptions x pds =
Ocsipersist.add election_pds x pds
let auth_configs = Ocsipersist.open_table "auth_configs"
let get_auth_config x =
try_lwt Ocsipersist.find auth_configs x
with Not_found -> return []
let set_auth_config x c =
Ocsipersist.add auth_configs x c
......@@ -39,3 +39,6 @@ val get_featured_elections : unit -> string list Lwt.t
val get_partial_decryptions : string -> (int * string) list Lwt.t
val set_partial_decryptions : string -> (int * string) list -> unit Lwt.t
val get_auth_config : string -> (string * (string * string list)) list Lwt.t
val set_auth_config : string -> (string * (string * string list)) list -> unit Lwt.t
......@@ -80,9 +80,6 @@ let election_dir = service ~path:["elections"] ~get_params:(suffix (uuid "uuid"
let scope = Eliom_common.default_session_scope
let cont : (unit -> service_handler) Eliom_reference.eref =
Eliom_reference.eref ~scope (fun () () -> Eliom_registration.Redirection.send home)
let ballot : string option Eliom_reference.eref =
Eliom_reference.eref ~scope None
......
......@@ -113,10 +113,7 @@ module type WEB_ELECTION = sig
include WEB_PARAMS
module E : ELECTION with type elt = G.t and type 'a m = 'a Lwt.t
module B : WEB_BALLOT_BOX
module Auth : sig
module Services : AUTH_SERVICES
module Handlers : AUTH_HANDLERS
end
val configure_auth : unit -> unit Lwt.t
end
type election_files = {
......
This diff is collapsed.
......@@ -19,29 +19,251 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
module C = struct
let name = "site"
let path = []
let kind = `Site
end
open Lwt
open Eliom_service
open Platform
open Web_serializable_t
open Web_common
open Web_auth_state
open Web_services
module A = Web_auth.Make (C)
let configure = A.configure
include A.Services
let next_lf str i =
try Some (String.index_from str i '\n')
with Not_found -> None
open Eliom_registration
open Web_services
let configure x =
let auth_config =
List.map (fun {auth_system; auth_instance; auth_config} ->
auth_instance, (auth_system, List.map snd auth_config)
) x
in
Web_persist.set_auth_config "" auth_config |> Lwt_unix.run;
List.iter (fun {auth_system; auth_instance; auth_config} ->
match auth_system with
| "password" ->
let table = Ocsipersist.open_table "password_site" in
(match auth_config with
| [] -> ()
| ["db", file] ->
Ocsigen_messages.debug (fun () ->
Printf.sprintf "Loading passwords from file %s" file
);
let db = Csv.load file in
List.iter (function
| username :: salt :: password :: _ ->
Ocsipersist.add table username (salt, password) |> Lwt_unix.run
| _ -> failwith ("error while loading " ^ file)) db
| _ -> failwith "error in passwords configuration")
| _ -> ()
) x
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 Web_services.admin
| Some u ->
Eliom_registration.Redirection.send (preapply Web_services.election_home (u, ()))
let dummy_handler () name =
match_lwt Eliom_reference.get auth_env with
| None -> failwith "dummy handler was invoked without environment"
| Some (uuid, service) ->
let logout () =
Eliom_reference.unset user >>
default_cont uuid ()
in
Eliom_reference.set user (Some {uuid; service; name; logout}) >>
Eliom_reference.unset auth_env >>
default_cont uuid ()
let () = Eliom_registration.Any.register ~service:dummy_post dummy_handler
let password_handler () (name, password) =
lwt uuid, service =
match_lwt Eliom_reference.get auth_env with
| None -> failwith "password handler was invoked without environment"
| Some x -> return x
in
let table =
"password_" ^
match uuid with
| None -> "site"
| Some u ->
let u = Uuidm.to_string u in
for i = 0 to String.length u - 1 do
if u.[i] = '-' then u.[i] <- '_'
done; u
in
let table = Ocsipersist.open_table table in
lwt salt, hashed =
try_lwt Ocsipersist.find table name
with Not_found -> fail_http 401
in
if sha256_hex (salt ^ password) = hashed then
let logout () =
Eliom_reference.unset user >>
default_cont uuid ()
in
Eliom_reference.set user (Some {uuid; service; name; logout}) >>
Eliom_reference.unset auth_env >>
default_cont uuid ()
else
fail_http 401
let () = Eliom_registration.Any.register ~service:password_post password_handler
let cas_server = Eliom_reference.eref ~scope None
let login_cas = Eliom_service.Http.service
~path:["auth"; "cas"]
~get_params:Eliom_parameter.(opt (string "ticket"))
()
let cas_self =
(* lazy so rewrite_prefix is called after server initialization *)
lazy (Eliom_uri.make_string_uri
~absolute:true
~service:(preapply login_cas None)
() |> rewrite_prefix)
let cas_handler ticket () =
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
| None -> failwith "cas handler was invoked without a server"
| Some x -> return x
in
let validation =
let cas_validate = Http.external_service
~prefix:server
~path:["validate"]
~get_params:Eliom_parameter.(string "service" ** string "ticket")
()
in
let service = preapply cas_validate (Lazy.force cas_self, x) in
Eliom_uri.make_string_uri ~absolute:true ~service ()
in
lwt reply = Ocsigen_http_client.get_url validation in
(match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
(match next_lf info 0 with
| Some i ->
(match String.sub info 0 i with
| "yes" ->
(match next_lf info (i+1) with
| Some j ->
let name = String.sub info (i+1) (j-i-1) in
let logout () =
Eliom_reference.unset user >>
let cas_logout = Http.external_service
~prefix:server
~path:["logout"]
~get_params:Eliom_parameter.(string "service")
()
in
let service = preapply cas_logout (Lazy.force cas_self) in
Eliom_registration.Redirection.send service
in
Eliom_reference.set user (Some {uuid; service; name; logout}) >>
default_cont uuid ()
| None -> fail_http 502)
| "no" -> fail_http 401
| _ -> fail_http 502)
| None -> fail_http 502)
| None -> fail_http 502)
| None ->
Eliom_reference.unset cas_server >>
Eliom_reference.unset auth_env >>
default_cont uuid ()
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 cas_login = Http.external_service
~prefix:server
~path:["login"]
~get_params:Eliom_parameter.(string "service" ** opt (bool "renew"))
()
in
let service = preapply cas_login (Lazy.force cas_self, Some true) in
Eliom_registration.Redirection.send service
| _ -> failwith "cas_login_handler invoked with bad config"
let get_login_handler service uuid auth_system config =
Eliom_reference.set auth_env (Some (uuid, service)) >>
match auth_system with
| "dummy" -> Web_templates.login_dummy () >>= Eliom_registration.Html5.send
| "cas" -> cas_login_handler config ()
| "password" -> Web_templates.login_password () >>= Eliom_registration.Html5.send
| _ -> fail_http 404
let login_handler service uuid =
let myself service =
match uuid with
| None -> preapply site_login service
| Some u -> preapply election_login ((u, ()), service)
in
match_lwt Eliom_reference.get user with
| Some u ->
cont_push (fun () -> Eliom_registration.Redirection.send (myself service)) >>
Web_templates.already_logged_in () >>= Eliom_registration.Html5.send
| None ->
lwt c = get_config uuid in
match service with
| Some s ->
lwt auth_system, config =
try return @@ List.assoc s c
with Not_found -> fail_http 404
in
get_login_handler s uuid auth_system config
| None ->
match c with
| [s, _] -> Eliom_registration.Redirection.send (myself (Some s))
| _ ->
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)
in
Web_templates.login_choose (List.map fst c) builder () >>=
Eliom_registration.Html5.send
let logout_handler () =
match_lwt Eliom_reference.get user with
| Some u -> u.logout ()
| None ->
match_lwt cont_pop () with
| Some f -> f ()
| None -> Eliom_registration.Redirection.send Web_services.home
let login service () =
lwt cont = Eliom_reference.get Web_services.cont in
A.Handlers.login service cont ()
let () = Eliom_registration.Any.register ~service:site_login
(fun service () -> login_handler service None)
let logout () () =
lwt cont = Eliom_reference.get Web_services.cont in
A.Handlers.logout cont ()
let () = Eliom_registration.Any.register ~service:site_logout
(fun () () -> logout_handler ())
let () = Any.register ~service:site_login login
let () = Any.register ~service:site_logout logout
let () = Eliom_registration.Any.register ~service:election_login
(fun ((uuid, ()), service) () -> login_handler service (Some uuid))
let () = Web_site_auth_state.get_user := get_user
let () = Web_site_auth_state.get_auth_systems := get_auth_systems
let () = Eliom_registration.Any.register ~service:election_logout
(fun (_, ()) () -> logout_handler ())
......@@ -2,5 +2,3 @@ open Web_serializable_t
open Web_signatures
val configure : auth_config list -> unit
include AUTH_SERVICES
open Lwt
open Web_serializable_t
(* Forward references filled in by Web_site_auth, needed by Web_templates *)
let get_user : (unit -> user option Lwt.t) ref = ref (fun () -> return None)
let get_auth_systems : (unit -> string list Lwt.t) ref = ref (fun () -> return [])
......@@ -82,8 +82,10 @@ end
module Site_auth = struct
let auth_realm = "site"
let get_user () = !Web_site_auth_state.get_user ()
let get_auth_systems () = !Web_site_auth_state.get_auth_systems ()
let get_user () = Web_auth_state.get_site_user ()
let get_auth_systems () =
lwt l = Web_auth_state.get_config None in
return (List.map fst l)
end
let site_links = (module Site_links : AUTH_LINKS)
......@@ -561,7 +563,15 @@ let election_setup_trustee token uuid se () =
let election_login_box w =
let module W = (val w : WEB_ELECTION) in
let auth = (module W.Auth.Services : AUTH_SERVICES) in
let module A = struct
let auth_realm = Uuidm.to_string W.election.e_params.e_uuid
let get_user () =
Web_auth_state.get_election_user W.election.e_params.e_uuid
let get_auth_systems () =
lwt l = Web_auth_state.get_config (Some W.election.e_params.e_uuid) in
return @@ List.map fst l
end in
let auth = (module A : AUTH_SERVICES) in
let module L = struct
let login x =
Eliom_service.preapply
......@@ -583,7 +593,6 @@ let file w x =
let election_home w state () =
let module W = (val w : WEB_ELECTION) in
lwt user = W.Auth.Services.get_user () in
let params = W.election.e_params and m = W.metadata in
let voting_period =
match m.e_voting_starts_at, m.e_voting_ends_at with
......@@ -898,7 +907,7 @@ let cast_raw w () =
let cast_confirmation w hash () =
let module W = (val w : WEB_ELECTION) in
lwt user = W.Auth.Services.get_user () in
lwt user = Web_auth_state.get_election_user W.election.e_params.e_uuid in
let params = W.election.e_params in
let name = params.e_name in
let user_div = match user with
......@@ -1175,3 +1184,78 @@ let choose auth links () =
] in
lwt login_box = login_box auth links in
base ~title:"Log in" ~login_box ~content ()
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:site_logout [pcdata "log out"] ();
pcdata " first."];
] in
let login_box = pcdata "" in
base ~title ~login_box ~content ()
let login_choose auth_systems service () =
let auth_systems =
auth_systems |>
List.map (fun name ->
a ~service:(service name) [pcdata name] ()
) |> list_join (pcdata ", ")
in
let content = [
div [p (
[pcdata "Please log in: ["] @ auth_systems @ [pcdata "]"]
)]
] in
let login_box = pcdata "" in
base ~title:"Log in" ~login_box ~content ()
let login_dummy () =
let title, field_name, input_type =
"Dummy login", "Username:", `Text
in
let form = post_form ~service:Web_auth_state.dummy_post
(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 = [
form;
] in
let login_box = pcdata "" in
base ~title ~login_box ~content ()
let login_password () =
let form = post_form ~service:Web_auth_state.password_post
(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 = [
form;
] in
let login_box = pcdata "" in
base ~title:"Password login" ~login_box ~content ()
......@@ -83,3 +83,18 @@ val upload_password_db :
val choose :
(module AUTH_SERVICES) -> (module AUTH_LINKS) ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val already_logged_in :
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val login_choose :
string list ->
(string -> (unit, unit, [< Eliom_service.get_service_kind ],
[< Eliom_service.suff ], 'a, unit,
[< Eliom_service.registrable ],
[< Eliom_service.non_ocaml_service ])
Eliom_service.service) ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val login_dummy : unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val login_password : unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
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