Initial commit of account self service

glondu · Dec 5, 2018 · beeddbb · beeddbb
1 parent 05f77b2
commit beeddbb
Show file tree

Hide file tree

Showing 18 changed files with 455 additions and 5 deletions.
diff --git a/INSTALL.md b/INSTALL.md
@@ -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

diff --git a/demo/ocsigenserver.conf.in b/demo/ocsigenserver.conf.in
@@ -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"/>

diff --git a/ext/captcha/captcha b/ext/captcha/captcha
@@ -0,0 +1,23 @@
+#!/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);
diff --git a/src/web/server.mllib b/src/web/server.mllib
@@ -27,5 +27,6 @@ Web_state
 Web_templates
 Web_auth
 Web_election
+Web_challenge
 Web_site
 Web_main
diff --git a/src/web/web_auth.ml b/src/web/web_auth.ml
@@ -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

diff --git a/src/web/web_auth.mli b/src/web/web_auth.mli
@@ -1 +1,30 @@
-(* 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
diff --git a/src/web/web_challenge.ml b/src/web/web_challenge.ml
@@ -0,0 +1,136 @@
+(**************************************************************************)
+(*                                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)
diff --git a/src/web/web_challenge.mli b/src/web/web_challenge.mli
@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                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
diff --git a/src/web/web_common.ml b/src/web/web_common.ml
@@ -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)

diff --git a/src/web/web_common.mli b/src/web/web_common.mli
@@ -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

diff --git a/src/web/web_serializable_builtin_t.ml b/src/web/web_serializable_builtin_t.ml
@@ -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
diff --git a/src/web/web_serializable_builtin_t.mli b/src/web/web_serializable_builtin_t.mli
@@ -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