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

Per instance account management

parent 1ecdbae5
Pipeline #55301 passed with stages
in 17 minutes and 3 seconds
......@@ -44,7 +44,8 @@
<!-- <contact uri="mailto:contact@example.org"/> -->
<server mail="noreply@example.org"/>
<auth name="demo"><dummy/></auth>
<auth name="local"><password db="demo/password_db.csv" allowsignups="true"/></auth>
<auth name="local"><password db="demo/password_db.csv"/></auth>
<auth name="public"><password db="_RUNDIR_/password_db.csv" allowsignups="true"/></auth>
<!-- <auth name="google"><oidc server="https://accounts.google.com" client_id="client-id" client_secret="client-secret"/></auth> -->
<source file="../belenios.tar.gz"/>
<default-group file="demo/groups/default.json"/>
......
......@@ -17,6 +17,8 @@ mkdir -p \
$BELENIOS_RUNDIR/spool \
$BELENIOS_TMPDIR/run
touch $BELENIOS_RUNDIR/password_db.csv
sed \
-e "s@_OCAML_STDLIBDIR_@$OCAML_STDLIBDIR@g" \
-e "s@_TMPDIR_@$BELENIOS_TMPDIR@g" \
......
......@@ -25,8 +25,6 @@ open Web_serializable_j
open Web_common
open Web_services
type auth_config = (string * string) list
type result = Eliom_registration.Html.result
type post_login_handler =
......@@ -39,25 +37,25 @@ let auth_env = Eliom_reference.eref ~scope None
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, cont) ->
| Some (uuid, a, cont) ->
let%lwt () = Eliom_reference.unset auth_env in
let authenticate name =
let user = { user_domain = service; user_name = name } in
let user = { user_domain = a.auth_instance; user_name = name } in
match uuid with
| None -> Eliom_reference.set Web_state.site_user (Some user)
| Some uuid -> Eliom_reference.set Web_state.election_user (Some (uuid, user))
in
let%lwt () = f uuid config authenticate in
let%lwt () = f uuid a authenticate in
cont ()
type pre_login_handler = auth_config -> result Lwt.t
let pre_login_handlers = ref []
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
let get_pre_login_handler uuid cont a =
let%lwt () = Eliom_reference.set auth_env (Some (uuid, a, cont)) in
match List.assoc_opt a.auth_system !pre_login_handlers with
| Some handler -> handler a
| None -> fail_http 404
let register_pre_login_handler auth_system handler =
......@@ -65,7 +63,7 @@ let register_pre_login_handler auth_system handler =
let rec find_auth_instance x = function
| [] -> None
| { auth_instance = i; auth_system = s; auth_config = c } :: _ when i = x -> Some (s, c)
| { auth_instance = i; _ } as y :: _ when i = x -> Some y
| _ :: xs -> find_auth_instance x xs
let get_cont login_or_logout x =
......@@ -104,13 +102,13 @@ let login_handler service kind =
in
match service with
| Some s ->
let%lwt auth_system, config =
let%lwt a =
match find_auth_instance s c with
| Some x -> return x
| None -> fail_http 404
in
let cont = get_cont `Login kind in
get_pre_login_handler s uuid auth_system cont config
get_pre_login_handler uuid cont a
| None ->
match c with
| [s] -> Eliom_registration.(Redirection.send (Redirection (myself (Some s.auth_instance))))
......
......@@ -21,8 +21,6 @@
open Web_serializable_t
type auth_config = (string * string) list
type result = Eliom_registration.Html.result
type pre_login_handler = auth_config -> result Lwt.t
......
......@@ -92,8 +92,8 @@ let cas_handler ticket () =
let () = Eliom_registration.Any.register ~service:login_cas cas_handler
let cas_login_handler config =
match List.assoc_opt "server" config with
let cas_login_handler a =
match List.assoc_opt "server" a.Web_serializable_t.auth_config with
| Some server ->
let%lwt () = Eliom_reference.set cas_server (Some server) in
let cas_login = Eliom_service.extern
......
......@@ -108,8 +108,8 @@ let split_prefix_path url =
let i = String.rindex url '/' in
String.sub url 0 i, [String.sub url (i+1) (n-i-1)]
let oidc_login_handler config =
let get x = List.assoc_opt x config in
let oidc_login_handler a =
let get x = List.assoc_opt x a.auth_config in
match get "server", get "client_id", get "client_secret" with
| Some server, Some client_id, Some client_secret ->
let%lwt ocfg = get_oidc_configuration server in
......
......@@ -40,12 +40,12 @@ let check_password_with_file db name password =
| _ -> return false
let password_handler () (name, password) =
Web_auth.run_post_login_handler "password" (fun uuid config authenticate ->
Web_auth.run_post_login_handler "password" (fun uuid a authenticate ->
let%lwt ok =
match uuid with
| None ->
begin
match List.assoc_opt "db" config with
match List.assoc_opt "db" a.auth_config with
| Some db -> check_password_with_file db name password
| _ -> failwith "invalid configuration for admin site"
end
......@@ -64,11 +64,11 @@ let does_allow_signups c =
| Some x -> bool_of_string x
| None -> false
let get_password_db_fname () =
let get_password_db_fname service =
let rec find = function
| [] -> None
| { auth_system = "password"; auth_config = c; _ } :: _
when does_allow_signups c -> List.assoc_opt "db" c
| { auth_system = "password"; auth_config = c; auth_instance = i } :: _
when i = service && does_allow_signups c -> List.assoc_opt "db" c
| _ :: xs -> find xs
in find !Web_config.site_auth_config
......@@ -114,39 +114,39 @@ let is_username =
| Some _ -> true
| None -> false
let add_account ~username ~password ~email =
if is_username username then
let add_account user ~password ~email =
if is_username user.user_name then
match%lwt Web_signup.cracklib_check password with
| Some e -> return (Error (BadPassword e))
| None ->
match get_password_db_fname () with
match get_password_db_fname user.user_domain with
| None -> forbidden ()
| Some db_fname ->
Lwt_mutex.with_lock password_db_mutex
(do_add_account ~db_fname ~username ~password ~email)
(do_add_account ~db_fname ~username:user.user_name ~password ~email)
else return (Error BadUsername)
let change_password ~username ~password =
let change_password user ~password =
match%lwt Web_signup.cracklib_check password with
| Some e -> return (Error e)
| None ->
match get_password_db_fname () with
match get_password_db_fname user.user_domain with
| None -> forbidden ()
| Some db_fname ->
let%lwt () =
Lwt_mutex.with_lock password_db_mutex
(do_change_password ~db_fname ~username ~password)
(do_change_password ~db_fname ~username:user.user_name ~password)
in return (Ok ())
let () =
Web_auth.register_pre_login_handler "password"
(fun config ->
let allowsignups = does_allow_signups config in
Web_templates.login_password ~allowsignups >>= Eliom_registration.Html.send
(fun { auth_config; auth_instance = service; _ } ->
let allowsignups = does_allow_signups auth_config in
Web_templates.login_password ~service ~allowsignups >>= Eliom_registration.Html.send
)
let lookup_account ~username ~email =
match get_password_db_fname () with
let lookup_account ~service ~username ~email =
match get_password_db_fname service with
| None -> return None
| Some db ->
let%lwt db = Lwt_preemptive.detach Csv.load db in
......
......@@ -19,11 +19,12 @@
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Web_serializable_t
open Web_common
(** Password-protected admin account management *)
val add_account : username:string -> password:string -> email:string -> (unit, add_account_error) result Lwt.t
val change_password : username:string -> password:string -> (unit, string) result Lwt.t
val add_account : user -> password:string -> email:string -> (unit, add_account_error) result Lwt.t
val change_password : user -> password:string -> (unit, string) result Lwt.t
val lookup_account : username:string -> email:string -> (string * string) option Lwt.t
val lookup_account : service:string -> username:string -> email:string -> (string * string) option Lwt.t
......@@ -208,16 +208,17 @@ let site_cont x =
type privacy_cont =
| ContAdmin
| ContSignup
| ContSignup of string
let privacy_cont_of_string = function
| "admin" -> ContAdmin
| "signup" -> ContSignup
let privacy_cont_of_string x =
match Pcre.split ~pat:"/" x with
| ["admin"] -> ContAdmin
| ["signup"; service] -> ContSignup service
| _ -> invalid_arg "privacy_cont_of_string"
let string_of_privacy_cont = function
| ContAdmin -> "admin"
| ContSignup -> "signup"
| ContSignup service -> "signup/" ^ service
let privacy_cont x =
Eliom_parameter.user_type
......
......@@ -99,7 +99,7 @@ val site_cont :
type privacy_cont =
| ContAdmin
| ContSignup
| ContSignup of string
val privacy_cont :
string ->
......
......@@ -113,13 +113,13 @@ let password_post = create ~path:No_path ~meth:(Post (unit, string "username" **
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 = create ~path:(Path ["signup"; ""]) ~meth:(Get (string "service" ** opt (captcha_error "error"))) ()
let signup_captcha_post = create_attached_post ~fallback:signup_captcha ~post_params:(string "challenge" ** string "response" ** string "email") ()
let signup_captcha_img = create ~path:(Path ["signup"; "captcha"]) ~meth:(Get (string "challenge")) ()
let signup_login = create ~path:(Path ["signup"; "login"]) ~meth:(Get (string "token")) ()
let signup = create ~path:(Path ["signup"; "account"]) ~meth:(Get unit) ()
let signup_post = create_attached_post ~fallback:signup ~post_params:(string "username" ** string "password") ()
let changepw_captcha = create ~path:(Path ["signup"; "changepw"]) ~meth:(Get (opt (captcha_error "error"))) ()
let changepw_captcha = create ~path:(Path ["signup"; "changepw"]) ~meth:(Get (string "service" ** opt (captcha_error "error"))) ()
let changepw_captcha_post = create_attached_post ~fallback:changepw_captcha ~post_params:(string "challenge" ** string "response" ** string "email" ** string "username") ()
let changepw_post = create_attached_post ~fallback:signup ~post_params:(string "password") ()
......@@ -84,6 +84,7 @@ type link_kind =
| ChangePassword of string
type link = {
service : string;
address : string;
l_expiration_time : datetime;
kind : link_kind;
......@@ -100,11 +101,11 @@ let filter_links_by_time table =
let filter_links_by_address address table =
SMap.filter (fun _ x -> x.address = address) table
let send_confirmation_link address =
let send_confirmation_link ~service address =
let%lwt token = generate_token ~length:20 () in
let l_expiration_time = datetime_add (now ()) (day 1) in
let kind = CreateAccount in
let link = {address; l_expiration_time; kind} in
let link = {service; address; l_expiration_time; kind} in
let nlinks = filter_links_by_time (filter_links_by_address address !links) in
links := SMap.add token link nlinks;
let uri =
......@@ -133,11 +134,11 @@ Belenios Server" address uri
let%lwt () = send_email address "Belenios account creation" message in
Lwt.return_unit
let send_changepw_link ~address ~username =
let send_changepw_link ~service ~address ~username =
let%lwt token = generate_token ~length:20 () in
let l_expiration_time = datetime_add (now ()) (day 1) in
let kind = ChangePassword username in
let link = {address; l_expiration_time; kind} in
let link = {service; address; l_expiration_time; kind} in
let nlinks = filter_links_by_time (filter_links_by_address address !links) in
links := SMap.add token link nlinks;
let uri =
......@@ -172,7 +173,7 @@ let confirm_link token =
| None -> Lwt.return None
| Some x ->
links := SMap.remove token !links;
Lwt.return (Some (x.address, x.kind))
Lwt.return (Some (x.service, x.address, x.kind))
let cracklib =
let x = "cracklib-check" in (x, [| x |])
......
......@@ -32,9 +32,9 @@ type link_kind =
| CreateAccount
| ChangePassword of string
val send_confirmation_link : string -> unit Lwt.t
val send_changepw_link : address:string -> username:string -> unit Lwt.t
val send_confirmation_link : service:string -> string -> unit Lwt.t
val send_changepw_link : service:string -> address:string -> username:string -> unit Lwt.t
val confirm_link : string -> (string * link_kind) option Lwt.t
val confirm_link : string -> (string * string * link_kind) option Lwt.t
val cracklib_check : string -> string option Lwt.t
......@@ -360,7 +360,7 @@ let () =
let%lwt () = Eliom_reference.set Web_state.show_cookie_disclaimer false in
let cont = match cont with
| ContAdmin -> Redirection admin
| ContSignup -> Redirection (preapply signup_captcha None)
| ContSignup service -> Redirection (preapply signup_captcha (service, None))
in
return cont
)
......@@ -2110,21 +2110,21 @@ let captcha_throttle = Captcha_throttle.create ~rate:1 ~max:5 ~n:1
let () =
Html.register ~service:signup_captcha
(fun error () ->
(fun (service, error) () ->
let%lwt gdpr = Eliom_reference.get Web_state.show_cookie_disclaimer in
if gdpr then T.privacy_notice ContSignup else
if gdpr then T.privacy_notice (ContSignup service) else
if%lwt Captcha_throttle.wait captcha_throttle 0 then
let%lwt challenge = Web_signup.create_captcha () in
T.signup_captcha error challenge
T.signup_captcha ~service error challenge
else
let service = preapply signup_captcha None in
let service = preapply signup_captcha (service, None) in
T.generic_page ~title:"Account creation" ~service
"You cannot create an account now. Please try later." ()
)
let () =
Any.register ~service:signup_captcha_post
(fun _ (challenge, (response, email)) ->
(fun (service, _) (challenge, (response, email)) ->
let%lwt error =
let%lwt ok = Web_signup.check_captcha ~challenge ~response in
if ok then
......@@ -2133,30 +2133,30 @@ let () =
in
match error with
| None ->
let%lwt () = Web_signup.send_confirmation_link email in
let%lwt () = Web_signup.send_confirmation_link ~service email in
let message =
Printf.sprintf
"An e-mail was sent to %s with a confirmation link. Please click on it to complete account creation." email
in
T.generic_page ~title:"Account creation" message () >>= Html.send
| _ -> redir_preapply signup_captcha error ()
| _ -> redir_preapply signup_captcha (service, error) ()
)
let () =
Html.register ~service:changepw_captcha
(fun error () ->
(fun (service, error) () ->
if%lwt Captcha_throttle.wait captcha_throttle 1 then
let%lwt challenge = Web_signup.create_captcha () in
T.signup_changepw error challenge
T.signup_changepw ~service error challenge
else
let service = preapply changepw_captcha None in
let service = preapply changepw_captcha (service, None) in
T.generic_page ~title:"Change password" ~service
"You cannot change your password now. Please try later." ()
)
let () =
Any.register ~service:changepw_captcha_post
(fun _ (challenge, (response, (email, username))) ->
(fun (service, _) (challenge, (response, (email, username))) ->
let%lwt error =
let%lwt ok = Web_signup.check_captcha ~challenge ~response in
if ok then return None
......@@ -2165,21 +2165,21 @@ let () =
match error with
| None ->
let%lwt () =
match%lwt Web_auth_password.lookup_account ~email ~username with
match%lwt Web_auth_password.lookup_account ~service ~email ~username with
| None ->
return (
Printf.ksprintf Ocsigen_messages.warning
"Unsuccessful attempt to change the password of %S (%S)"
username email
"Unsuccessful attempt to change the password of %S (%S) for service %s"
username email service
)
| Some (username, address) ->
Web_signup.send_changepw_link ~address ~username
Web_signup.send_changepw_link ~service ~address ~username
in
let message =
"If possible, an e-mail was sent with a confirmation link. Please click on it to change your password."
in
T.generic_page ~title:"Change password" message () >>= Html.send
| _ -> redir_preapply changepw_captcha error ()
| _ -> redir_preapply changepw_captcha (service, error) ()
)
let () =
......@@ -2189,33 +2189,31 @@ let () =
let () =
Any.register ~service:signup_login
(fun token () ->
let%lwt address = Web_signup.confirm_link token in
match address with
match%lwt Web_signup.confirm_link token with
| None -> forbidden ()
| Some address ->
let%lwt () = Eliom_reference.set Web_state.signup_address (Some address) in
| Some env ->
let%lwt () = Eliom_reference.set Web_state.signup_env (Some env) in
redir_preapply signup () ()
)
let () =
Any.register ~service:signup
(fun () () ->
let%lwt address = Eliom_reference.get Web_state.signup_address in
match address with
match%lwt Eliom_reference.get Web_state.signup_env with
| None -> forbidden ()
| Some (address, Web_signup.CreateAccount) -> T.signup address >>= Html.send
| Some (address, Web_signup.ChangePassword username) -> T.changepw ~username ~address >>= Html.send
| Some (_, address, Web_signup.CreateAccount) -> T.signup address >>= Html.send
| Some (_, address, Web_signup.ChangePassword username) -> T.changepw ~username ~address >>= Html.send
)
let () =
Any.register ~service:signup_post
(fun () (username, password) ->
let%lwt email = Eliom_reference.get Web_state.signup_address in
match email with
| Some (email, Web_signup.CreateAccount) ->
(match%lwt Web_auth_password.add_account ~username ~password ~email with
match%lwt Eliom_reference.get Web_state.signup_env with
| Some (service, email, Web_signup.CreateAccount) ->
let user = { user_name = username; user_domain = service } in
(match%lwt Web_auth_password.add_account user ~password ~email with
| Ok () ->
let%lwt () = Eliom_reference.unset Web_state.signup_address in
let%lwt () = Eliom_reference.unset Web_state.signup_env in
T.generic_page ~title:"Account creation" ~service:admin
"The account has been created." () >>= Html.send
| Error UsernameTaken ->
......@@ -2239,11 +2237,12 @@ let () =
let () =
Any.register ~service:changepw_post
(fun () password ->
match%lwt Eliom_reference.get Web_state.signup_address with
| Some (_, Web_signup.ChangePassword username) ->
(match%lwt Web_auth_password.change_password ~username ~password with
match%lwt Eliom_reference.get Web_state.signup_env with
| Some (service, _, Web_signup.ChangePassword username) ->
let user = { user_name = username; user_domain = service } in
(match%lwt Web_auth_password.change_password user ~password with
| Ok () ->
let%lwt () = Eliom_reference.unset Web_state.signup_address in
let%lwt () = Eliom_reference.unset Web_state.signup_env in
T.generic_page ~title:"Change password" ~service:admin
"The password has been changed." () >>= Html.send
| Error e ->
......
......@@ -51,4 +51,4 @@ let get_default_language () =
let language = Eliom_reference.eref_from_fun ~scope get_default_language
let signup_address = Eliom_reference.eref ~scope None
let signup_env = Eliom_reference.eref ~scope None
......@@ -32,4 +32,4 @@ val cast_confirmed : (string, Web_common.error) result option Eliom_reference.er
val language : string Eliom_reference.eref
val signup_address : (string * Web_signup.link_kind) option Eliom_reference.eref
val signup_env : (string * string * Web_signup.link_kind) option Eliom_reference.eref
......@@ -2479,7 +2479,7 @@ let login_dummy () =
] in
base ~title ~content ()
let login_password ~allowsignups =
let login_password ~service ~allowsignups =
let%lwt language = Eliom_reference.get Web_state.language in
let module L = (val Web_i18n.get_lang language) in
let signup =
......@@ -2487,9 +2487,9 @@ let login_password ~allowsignups =
div [
br ();
pcdata "You can also ";
a ~service:signup_captcha [pcdata "create an account"] None;
a ~service:signup_captcha [pcdata "create an account"] (service, None);
pcdata ", or ";
a ~service:changepw_captcha [pcdata "change your password"] None;
a ~service:changepw_captcha [pcdata "change your password"] (service, None);
pcdata " (if you forgot it, for example).";
]
else pcdata ""
......@@ -2527,7 +2527,7 @@ let format_captcha_error = function
| Some BadCaptcha -> div [pcdata "Bad security code!"]
| Some BadAddress -> div [pcdata "Bad e-mail address!"]
let signup_captcha error challenge =
let signup_captcha ~service error challenge =
let form =
post_form ~service:signup_captcha_post
(fun (lchallenge, (lresponse, lemail)) ->
......@@ -2547,13 +2547,13 @@ let signup_captcha error challenge =
input ~input_type:`Submit ~value:"Submit" string;
];
]
) None
) (service, None)
in
let error = format_captcha_error error in
let content = [error; form] in
base ~title:"Create an account" ~content ()
let signup_changepw error challenge =
let signup_changepw ~service error challenge =
let form =
post_form ~service:changepw_captcha_post
(fun (lchallenge, (lresponse, (lemail, lusername))) ->
......@@ -2576,7 +2576,7 @@ let signup_changepw error challenge =
input ~input_type:`Submit ~value:"Submit" string;
];
]
) None
) (service, None)
in
let error = format_captcha_error error in
let content = [error; form] in
......
......@@ -72,10 +72,10 @@ val login_choose :
unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val login_dummy : unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val login_password : allowsignups:bool -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val login_password : service:string -> allowsignups:bool -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val signup_captcha : captcha_error option -> string -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val signup_changepw : captcha_error option -> string -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val signup_captcha : service:string -> captcha_error option -> string -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val signup_changepw : service:string -> captcha_error option -> string -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val signup : string -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val changepw : username:string -> address:string -> [> `Html ] Eliom_content.Html.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