Commit beeddbb7 authored by Stephane Glondu's avatar Stephane Glondu

Initial commit of account self service

parent 05f77b26
......@@ -25,12 +25,13 @@ The non-OCaml prerequisites are:
* [aspcud](http://www.cs.uni-potsdam.de/wv/aspcud/) (optional)
* [ncurses](http://invisible-island.net/ncurses/)
* [uuidgen](https://www.kernel.org/pub/linux/utils/util-linux/)
* [GD-SecurityImage](https://metacpan.org/release/GD-SecurityImage)
These libraries and tools are pretty common, and might be directly part
of your operating system. On [Debian](http://www.debian.org/) and its
derivatives, they can be installed with the following command:
sudo apt install build-essential libgmp-dev libpcre3-dev pkg-config m4 libssl-dev libsqlite3-dev wget ca-certificates zip unzip aspcud libncurses-dev uuid-runtime zlib1g-dev
sudo apt install build-essential libgmp-dev libpcre3-dev pkg-config m4 libssl-dev libsqlite3-dev wget ca-certificates zip unzip aspcud libncurses-dev uuid-runtime zlib1g-dev libgd-securityimage-perl
If you are unfamiliar with OCaml or OPAM, we provide an
`opam-bootstrap.sh` shell script that creates a whole, hopefully
......
......@@ -44,7 +44,7 @@
<!-- <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"/></auth>
<auth name="local"><password db="demo/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"/>
......
#!/usr/bin/perl
# Inspired by GD::SecurityImage manpage
use strict;
use GD::SecurityImage;
use MIME::Base64 ();
my $image = GD::SecurityImage->new(
width => 80,
height => 30,
lines => 10,
gd_font => 'giant',
);
$image->random();
$image->create( normal => 'rect' );
my($image_data, $mime_type, $random_number) = $image->out;
print $mime_type;
print "\n";
print $random_number;
print "\n";
print MIME::Base64::encode($image_data);
......@@ -27,5 +27,6 @@ Web_state
Web_templates
Web_auth
Web_election
Web_challenge
Web_site
Web_main
......@@ -89,7 +89,7 @@ let password_handler () (name, password) =
| None ->
begin
match config with
| [db] -> check_password_with_file db name password
| db :: _ -> check_password_with_file db name password
| _ -> failwith "invalid configuration for admin site"
end
| Some uuid ->
......@@ -106,6 +106,41 @@ let password_handler () (name, password) =
let () = Eliom_registration.Any.register ~service:password_post password_handler
let get_password_db_fname () =
let rec find = function
| [] -> None
| (_, ("password", db :: allowsignups :: _)) :: _ when bool_of_string allowsignups -> Some db
| _ :: xs -> find xs
in find !site_auth_config
let allowsignups () = get_password_db_fname () <> None
let password_db_mutex = Lwt_mutex.create ()
let do_add_account ~db_fname ~username ~password ~email () =
let%lwt db = Lwt_preemptive.detach Csv.load db_fname in
let%lwt salt = generate_token ~length:8 () in
let hashed = sha256_hex (salt ^ password) in
let rec append accu = function
| [] -> Some (List.rev ([username; salt; hashed; email] :: accu))
| ((username' :: _ :: _ :: _) as x) :: xs ->
if username = username' then None else append (x :: accu) xs
| _ :: _ -> None
in
match append [] db with
| None -> Lwt.return false
| Some db ->
let db = List.map (String.concat ",") db in
let%lwt () = write_file db_fname db in
Lwt.return true
let add_account ~username ~password ~email =
match get_password_db_fname () with
| None -> forbidden ()
| Some db_fname ->
Lwt_mutex.with_lock password_db_mutex
(do_add_account ~db_fname ~username ~password ~email)
(** CAS authentication *)
let cas_server = Eliom_reference.eref ~scope None
......
(* empty interface *)
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2018 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/>. *)
(**************************************************************************)
(* This module registers login/logout handlers by side-effects. *)
(** Password-protected admin account management *)
(** Returns [true] if server configuration allows account creation. *)
val allowsignups : unit -> bool
(** Returns [true] if account creation succeeds. *)
val add_account : username:string -> password:string -> email:string -> bool Lwt.t
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2018 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 Platform
open Common
open Web_serializable_builtin_t
open Web_common
type captcha = {
content_type : string;
contents : string;
response : string;
c_expiration_time : datetime;
}
let captchas = ref SMap.empty
let filter_captchas_by_time table =
let now = now () in
SMap.filter (fun _ {c_expiration_time; _} ->
datetime_compare now c_expiration_time <= 0
) table
let format_content_type = function
| "png" -> "image/png"
| x -> Printf.ksprintf failwith "Unknown captcha type: %s" x
let captcha =
let x = "./ext/captcha/captcha" in (x, [| x |])
let create_captcha () =
let%lwt raw = Lwt_process.pread_lines captcha |> Lwt_stream.to_list in
match raw with
| content_type :: response :: contents ->
let content_type = format_content_type content_type in
let contents =
let open Cryptokit in
String.concat "\n" contents |> transform_string (Base64.decode ())
in
let challenge = sha256_b64 contents in
let c_expiration_time = datetime_add (now ()) (second 300.) in
let x = { content_type; contents; response; c_expiration_time } in
captchas := SMap.add challenge x !captchas;
Lwt.return challenge
| _ ->
Lwt.fail (Failure "Captcha generation failed")
let get challenge =
captchas := filter_captchas_by_time !captchas;
SMap.find_opt challenge !captchas
let get_captcha ~challenge =
match get challenge with
| None -> fail_http 404
| Some {content_type; contents; _} -> Lwt.return (contents, content_type)
let check_captcha ~challenge ~response =
match get challenge with
| None -> Lwt.return false
| Some x ->
captchas := SMap.remove challenge !captchas;
Lwt.return (response = x.response)
type link = {
address : string;
l_expiration_time : datetime;
}
let links = ref SMap.empty
let filter_links_by_time table =
let now = now () in
SMap.filter (fun _ {l_expiration_time; _} ->
datetime_compare now l_expiration_time <= 0
) table
let filter_links_by_address address table =
SMap.filter (fun _ x -> x.address = address) table
let send_confirmation_link address =
let%lwt token = generate_token ~length:20 () in
let l_expiration_time = datetime_add (now ()) (day 1) in
let link = {address; l_expiration_time} in
let nlinks = filter_links_by_time (filter_links_by_address address !links) in
links := SMap.add token link nlinks;
let uri =
Eliom_uri.make_string_uri ~absolute:true ~service:Web_services.signup_login
token |> rewrite_prefix
in
let message =
Printf.sprintf "\
Dear %s,
Your e-mail address has been used to create a local account on our Belenios
server. To confirm this creation, please click on the following link:
%s
or copy and paste it in a web browser.
Warning: this link is valid for 1 day, and previous links sent to this
address are no longer valid.
Best regards,
-- \n\
Belenios Server" address uri
in
let%lwt () = send_email address "Belenios account creation" message in
Lwt.return_unit
let confirm_link token =
links := filter_links_by_time !links;
match SMap.find_opt token !links with
| None -> Lwt.return None
| Some x ->
links := SMap.remove token !links;
Lwt.return (Some x.address)
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2018 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/>. *)
(**************************************************************************)
(** Returns a challenge string, used to identify the captcha in
following functions. *)
val create_captcha : unit -> string Lwt.t
(** Returns the image associated to a challenge. *)
val get_captcha : challenge:string -> (string * string) Lwt.t
val check_captcha : challenge:string -> response:string -> bool Lwt.t
val send_confirmation_link : string -> unit Lwt.t
val confirm_link : string -> string option Lwt.t
......@@ -188,6 +188,25 @@ let uuid x =
~to_string:raw_string_of_uuid
x
type captcha_error =
| BadCaptcha
| BadAddress
let captcha_error_of_string = function
| "captcha" -> BadCaptcha
| "address" -> BadAddress
| _ -> invalid_arg "captcha_error_of_string"
let string_of_captcha_error = function
| BadCaptcha -> "captcha"
| BadAddress -> "address"
let captcha_error x =
Eliom_parameter.user_type
~of_string:captcha_error_of_string
~to_string:string_of_captcha_error
x
let b58_digits = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
let prng = lazy (pseudo_rng (random_string secure_rng 16))
......@@ -325,7 +344,26 @@ let rmdir dir =
return_unit
let compile_auth_config {auth_system; auth_instance; auth_config} =
auth_instance, (auth_system, List.map snd auth_config)
match auth_system with
| "password" ->
let auth_config =
match auth_config with
| [] ->
(* election configuration *)
[]
| _ ->
(* site configuration *)
let db = List.assoc "db" auth_config in
let allowsignups =
match List.assoc_opt "allowsignups" auth_config with
| None -> false
| Some x -> bool_of_string x
in
[db; string_of_bool allowsignups]
in
auth_instance, (auth_system, auth_config)
| _ ->
auth_instance, (auth_system, List.map snd auth_config)
let urlize = String.map (function '+' -> '-' | '/' -> '_' | c -> c)
let unurlize = String.map (function '-' -> '+' | '_' -> '/' | c -> c)
......
......@@ -91,6 +91,16 @@ val uuid :
[ `One of uuid ] Eliom_parameter.param_name)
Eliom_parameter.params_type
type captcha_error =
| BadCaptcha
| BadAddress
val captcha_error :
string ->
(captcha_error, [ `WithoutSuffix ],
[ `One of captcha_error ] Eliom_parameter.param_name)
Eliom_parameter.params_type
val generate_token : ?length:int -> unit -> string Lwt.t
val string_of_user : user -> string
......
......@@ -53,6 +53,7 @@ let format_datetime ?(fmt = datetime_format) (a, _) =
type period = CalendarLib.Fcalendar.Precise.Period.t
let day = CalendarLib.Fcalendar.Precise.Period.day
let second = CalendarLib.Fcalendar.Precise.Period.second
let datetime_add (a, _) x =
CalendarLib.Fcalendar.Precise.add a x, None
......@@ -28,4 +28,5 @@ val format_datetime : ?fmt:string -> datetime -> string
type period
val day : int -> period
val second : float -> period
val datetime_add : datetime -> period -> datetime
......@@ -110,3 +110,10 @@ 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 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") ()
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") ()
......@@ -2013,6 +2013,74 @@ let () =
)
)
let () =
Html.register ~service:signup_captcha
(fun error () ->
let%lwt challenge = Web_challenge.create_captcha () in
T.signup_captcha error challenge
)
let () =
Any.register ~service:signup_captcha_post
(fun _ (challenge, (response, email)) ->
let%lwt error =
let%lwt ok = Web_challenge.check_captcha ~challenge ~response in
if ok then
if is_email email then return None else return (Some BadAddress)
else return (Some BadCaptcha)
in
match error with
| None ->
let%lwt () = Web_challenge.send_confirmation_link 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 ()
)
let () =
String.register ~service:signup_captcha_img
(fun challenge () -> Web_challenge.get_captcha challenge)
let () =
Any.register ~service:signup_login
(fun token () ->
let%lwt address = Web_challenge.confirm_link token in
match address with
| None -> forbidden ()
| Some address ->
let%lwt () = Eliom_reference.set Web_state.signup_address (Some address) in
redir_preapply signup () ()
)
let () =
Any.register ~service:signup
(fun () () ->
let%lwt address = Eliom_reference.get Web_state.signup_address in
match address with
| None -> forbidden ()
| Some address -> T.signup 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
| None -> forbidden ()
| Some email ->
let%lwt b = Web_auth.add_account ~username ~password ~email in
if b then
let%lwt () = Eliom_reference.unset Web_state.signup_address in
T.generic_page ~title:"Account creation" ~service:admin
"The account has been created." () >>= Html.send
else
T.generic_page ~title:"Account creation" ~service:signup
"The account creation failed. Usually, this is because the username is already taken. Please try again." () >>= Html.send
)
let extract_automatic_data_draft uuid_s =
let uuid = uuid_of_raw_string uuid_s in
match%lwt Web_persist.get_draft_election uuid with
......
......@@ -95,3 +95,5 @@ let get_default_language () =
String.sub lang 0 n
let language = Eliom_reference.eref_from_fun ~scope get_default_language
let signup_address = Eliom_reference.eref ~scope None
......@@ -42,3 +42,5 @@ val ballot : string option Eliom_reference.eref
val cast_confirmed : [ `Error of Web_common.error | `Valid of string ] option Eliom_reference.eref
val language : string Eliom_reference.eref
val signup_address : string option Eliom_reference.eref
......@@ -2498,6 +2498,66 @@ let login_password () =
] in
base ~title:L.password_login ~content ()
let signup_captcha_img challenge =
let src = make_uri ~service:signup_captcha_img challenge in
img ~src ~alt:"CAPTCHA" ()
let signup_captcha error challenge =
let form =
post_form ~service:signup_captcha_post
(fun (lchallenge, (lresponse, lemail)) ->
[
div [
pcdata "E-mail address: ";
input ~input_type:`Text ~name:lemail string;
];
div [
input ~input_type:`Hidden ~name:lchallenge ~value:challenge string;
pcdata "Please enter ";
signup_captcha_img challenge;
pcdata " in the following box: ";
input ~input_type:`Text ~name:lresponse string;
];
div [
input ~input_type:`Submit ~value:"Submit" string;
];
]
) None
in
let error = match error with
| None -> pcdata ""
| Some BadCaptcha -> div [pcdata "Bad security code!"]
| Some BadAddress -> div [pcdata "Bad e-mail address!"]
in
let content = [error; form] in
base ~title:"Create an account" ~content ()
let signup address =
let form =
post_form ~service:signup_post
(fun (lusername, lpassword) ->
[
div [
pcdata "Your e-mail address is: ";
pcdata address;
pcdata ".";
];
div [
pcdata "Please choose a username: ";
input ~input_type:`Text ~name:lusername string;
pcdata " and a password: ";
input ~input_type:`Password ~name:lpassword string;
pcdata ".";
];
div [
input ~input_type:`Submit ~value:"Submit" string;
];
]
) ()
in
let content = [form] in
base ~title:"Create an account" ~content ()
let booth () =
let%lwt language = Eliom_reference.get Web_state.language in
let module L = (val Web_i18n.get_lang language) in
......
......@@ -22,6 +22,7 @@
open Serializable_t
open Web_serializable_t
open Signatures
open Web_common
val admin_gdpr : unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val admin : elections:((uuid * string) list * (uuid * string) list * (uuid * string) list * (uuid * string) list) option -> unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
......@@ -76,6 +77,9 @@ val login_choose :
val login_dummy : unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val login_password : unit -> [> `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 : string -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val booth : unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val contact_footer : metadata -> string -> string
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