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

src/web/server.mllib

@@ -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

src/web/web_auth_state.ml

+(**************************************************************************)
+(*                                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")
+  ()

src/web/web_election.ml

@@ -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

src/web/web_main.ml

@@ -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 ->

src/web/web_persist.ml

@@ -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

src/web/web_persist.mli

@@ -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

src/web/web_services.ml

@@ -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
 

src/web/web_signatures.mli

@@ -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 = {

src/web/web_site.ml

@@ -174,6 +174,7 @@ let import_election f =
             )) >>
             let election = do_register () in
             let module W = (val election : WEB_ELECTION) in
+            W.configure_auth () >>
             let () =
               Ocsigen_messages.debug (fun () ->
                 Printf.sprintf "Injecting credentials for %s" uuid
@@ -211,6 +212,7 @@ lwt () =
     let _, do_register = register_election params web_params in
     let election = do_register () in
     let module W = (val election : WEB_ELECTION) in
+    lwt () = W.configure_auth () in
     assert (uuid = Uuidm.to_string W.election.e_params.e_uuid);
     Ocsigen_messages.debug (fun () ->
       Printf.sprintf "Initialized election %s from persistent store" uuid
@@ -220,7 +222,7 @@ lwt () =
 
 let () = Any.register ~service:home
   (fun () () ->
-    Eliom_reference.unset cont >>
+    Eliom_reference.unset Web_auth_state.cont >>
     match_lwt Web_persist.get_main_election () with
     | None ->
       lwt featured =
@@ -236,9 +238,9 @@ let () = Any.register ~service:home
 
 let () = Html5.register ~service:admin
   (fun () () ->
-    let cont () () = Redirection.send admin in
-    Eliom_reference.set Web_services.cont cont >>
-    lwt site_user = Web_site_auth.get_user () in
+    let cont () = Redirection.send admin in
+    Eliom_reference.set Web_auth_state.cont [cont] >>
+    lwt site_user = Web_auth_state.get_site_user () in
     lwt elections =
       match site_user with
       | None -> return []
@@ -292,14 +294,14 @@ let () = String.register
 
 let () = Html5.register ~service:new_election
   (fun () () ->
-    match_lwt Web_site_auth.get_user () with
+    match_lwt Web_auth_state.get_site_user () with
     | None -> forbidden ()
     | Some _ -> T.new_election ()
   )
 
 let () = Any.register ~service:new_election_post
   (fun () (election, (metadata, (public_keys, public_creds))) ->
-    match_lwt Web_site_auth.get_user () with
+    match_lwt Web_auth_state.get_site_user () with
     | Some u ->
       let open Ocsigen_extensions in
       let files = {
@@ -329,7 +331,7 @@ let generate_uuid = Uuidm.v4_gen (Random.State.make_self_init ())
 
 let () = Redirection.register ~service:election_setup_new
   (fun () () ->
-   match_lwt Web_site_auth.get_user () with
+   match_lwt Web_auth_state.get_site_user () with
    | Some u ->
       let uuid = generate_uuid () in
       let uuid_s = Uuidm.to_string uuid in
@@ -369,7 +371,7 @@ let () = Redirection.register ~service:election_setup_new
 
 let () = Html5.register ~service:election_setup
   (fun uuid () ->
-   match_lwt Web_site_auth.get_user () with
+   match_lwt Web_auth_state.get_site_user () with
    | Some u ->
       let uuid_s = Uuidm.to_string uuid in
       lwt se = Ocsipersist.find election_stable uuid_s in
@@ -382,7 +384,7 @@ let () = Html5.register ~service:election_setup
 let election_setup_mutex = Lwt_mutex.create ()
 
 let handle_setup f cont uuid x =
-  match_lwt Web_site_auth.get_user () with
+  match_lwt Web_auth_state.get_site_user () with
   | Some u ->
      let uuid_s = Uuidm.to_string uuid in
      Lwt_mutex.with_lock election_setup_mutex (fun () ->
@@ -420,7 +422,7 @@ let () =
   Html5.register
     ~service:election_setup_questions
     (fun uuid () ->
-     match_lwt Web_site_auth.get_user () with
+     match_lwt Web_auth_state.get_site_user () with
      | Some u ->
         let uuid_s = Uuidm.to_string uuid in
         lwt se = Ocsipersist.find election_stable uuid_s in
@@ -441,7 +443,7 @@ let () =
   Html5.register
     ~service:election_setup_voters
     (fun uuid () ->
-      match_lwt Web_site_auth.get_user () with
+      match_lwt Web_auth_state.get_site_user () with
       | Some u ->
          let uuid_s = Uuidm.to_string uuid in
          lwt se = Ocsipersist.find election_stable uuid_s in
@@ -478,7 +480,7 @@ let () =
   Redirection.register
     ~service:election_setup_trustee_add
     (fun uuid () ->
-     match_lwt Web_site_auth.get_user () with
+     match_lwt Web_auth_state.get_site_user () with
      | Some u ->
         let uuid_s = Uuidm.to_string uuid in
         Lwt_mutex.with_lock election_setup_mutex (fun () ->
@@ -499,7 +501,7 @@ let () =
   Redirection.register
     ~service:election_setup_trustee_del
     (fun uuid () ->
-     match_lwt Web_site_auth.get_user () with
+     match_lwt Web_auth_state.get_site_user () with
      | Some u ->
         let uuid_s = Uuidm.to_string uuid in
         Lwt_mutex.with_lock election_setup_mutex (fun () ->
@@ -621,7 +623,7 @@ let () =
   Any.register
     ~service:election_setup_create
     (fun uuid () ->
-     match_lwt Web_site_auth.get_user () with
+     match_lwt Web_auth_state.get_site_user () with
      | None -> forbidden ()
      | Some u ->
         begin try_lwt
@@ -731,12 +733,12 @@ let () =
       let w = SMap.find uuid_s !election_table in
       let module W = (val w : WEB_ELECTION) in
       Eliom_reference.unset Web_services.ballot >>
-      let cont () () =
+      let cont () =
         Redirection.send
           (Eliom_service.preapply
              election_home (W.election.e_params.e_uuid, ()))
       in
-      Eliom_reference.set Web_services.cont cont >>
+      Eliom_reference.set Web_auth_state.cont [cont] >>
       match_lwt Eliom_reference.get Web_services.cast_confirmed with
       | Some result ->
          Eliom_reference.unset Web_services.cast_confirmed >>
@@ -763,7 +765,7 @@ let () =
     (fun (uuid, ()) () ->
      let uuid_s = Uuidm.to_string uuid in
      let w = SMap.find uuid_s !election_table in
-     lwt site_user = Web_site_auth.get_user () in
+     lwt site_user = Web_auth_state.get_site_user () in
      lwt is_featured = Web_persist.is_featured_election uuid_s in
      let module W = (val w : WEB_ELECTION) in
      let uuid = Uuidm.to_string W.election.e_params.e_uuid in
@@ -782,7 +784,7 @@ let () =
      let w = SMap.find uuid_s !election_table in
      let module W = (val w : WEB_ELECTION) in
      lwt () =
-       match_lwt Web_site_auth.get_user () with
+       match_lwt Web_auth_state.get_site_user () with
        | Some u when W.metadata.e_owner = Some u -> return ()
        | _ -> forbidden ()
      in
@@ -795,33 +797,13 @@ let () =
      Web_persist.set_election_state uuid_s state >>
      Redirection.send (preapply election_admin (uuid, ())))
 
-let () =
-  Any.register
-    ~service:election_login
-    (fun ((uuid, ()), service) () ->
-     let uuid_s = Uuidm.to_string uuid in
-     let w = SMap.find uuid_s !election_table in
-     let module W = (val w : WEB_ELECTION) in
-     lwt cont = Eliom_reference.get Web_services.cont in
-     W.Auth.Handlers.login service cont ())
-
-let () =
-  Any.register
-    ~service:election_logout
-    (fun (uuid, ()) () ->
-     let uuid_s = Uuidm.to_string uuid in
-     let w = SMap.find uuid_s !election_table in
-     let module W = (val w : WEB_ELECTION) in
-     lwt cont = Eliom_reference.get Web_services.cont in
-     W.Auth.Handlers.logout cont ())
-
 let () =
   Any.register
     ~service:election_update_credential
     (fun (uuid, ()) () ->
      let uuid_s = Uuidm.to_string uuid in
      let w = SMap.find uuid_s !election_table in
-     lwt site_user = Web_site_auth.get_user () in
+     lwt site_user = Web_auth_state.get_site_user () in
      let module W = (val w : WEB_ELECTION) in
      match site_user with
      | Some u ->
@@ -838,7 +820,7 @@ let () =
     (fun (uuid, ()) (old, new_) ->
      let uuid_s = Uuidm.to_string uuid in
      let w = SMap.find uuid_s !election_table in
-     lwt site_user = Web_site_auth.get_user () in
+     lwt site_user = Web_auth_state.get_site_user () in
      let module W = (val w : WEB_ELECTION) in
      match site_user with
      | Some u ->
@@ -862,12 +844,6 @@ let () =
       let w = SMap.find uuid_s !election_table in
       let module W = (val w : WEB_ELECTION) in
       Eliom_reference.unset Web_services.ballot >>
-      let cont () () =
-        Redirection.send
-          (Eliom_service.preapply
-             election_vote (W.election.e_params.e_uuid, ()))
-      in
-      Eliom_reference.set Web_services.cont cont >>
       Redirection.send
         (Eliom_service.preapply
            (Eliom_service.static_dir_with_params
@@ -882,12 +858,12 @@ let () =
       let uuid_s = Uuidm.to_string uuid in
       let w = SMap.find uuid_s !election_table in
       let module W = (val w : WEB_ELECTION) in
-      let cont () () =
+      let cont () =
         Redirection.send
           (Eliom_service.preapply
              election_cast (W.election.e_params.e_uuid, ()))
       in
-      Eliom_reference.set Web_services.cont cont >>
+      Eliom_reference.set Web_auth_state.cont [cont] >>
       match_lwt Eliom_reference.get Web_services.ballot with
       | Some b -> T.cast_confirmation w (sha256_b64 b) () >>= Html5.send
       | None -> T.cast_raw w () >>= Html5.send)
@@ -899,7 +875,7 @@ let () =
       let uuid_s = Uuidm.to_string uuid in
       let w = SMap.find uuid_s !election_table in
       let module W = (val w : WEB_ELECTION) in
-      lwt user = W.Auth.Services.get_user () in
+      lwt user = Web_auth_state.get_election_user uuid in
       lwt the_ballot = match ballot_raw, ballot_file with
         | Some ballot, None -> return ballot
         | None, Some fi ->
@@ -907,12 +883,12 @@ let () =
            Lwt_stream.to_string (Lwt_io.chars_of_file fname)
         | _, _ -> fail_http 400
       in
-      let cont () () =
+      let cont () =
         Redirection.send
           (Eliom_service.preapply
              Web_services.election_cast (W.election.e_params.e_uuid, ()))
       in
-      Eliom_reference.set Web_services.cont cont >>
+      Eliom_reference.set Web_auth_state.cont [cont] >>
       Eliom_reference.set Web_services.ballot (Some the_ballot) >>
       match user with
       | None ->
@@ -920,7 +896,7 @@ let () =
            (Eliom_service.preapply
               Web_services.election_login
               ((W.election.e_params.e_uuid, ()), None))
-      | Some u -> cont () ())
+      | Some u -> cont ())
 
 let () =
   Any.register
@@ -933,7 +909,7 @@ let () =
       | Some the_ballot ->
          begin
            Eliom_reference.unset Web_services.ballot >>
-           match_lwt W.Auth.Services.get_user () with
+           match_lwt Web_auth_state.get_election_user uuid with
            | Some u ->
               let record = string_of_user u, now () in
               lwt result =
@@ -1061,7 +1037,7 @@ let () =
       let w = SMap.find uuid_s !election_table in
       let module W = (val w) in
       lwt () =
-        match_lwt Web_site_auth.get_user () with
+        match_lwt Web_auth_state.get_site_user () with
         | Some u when W.metadata.e_owner = Some u -> return ()
         | _ -> forbidden ()
       in
@@ -1117,15 +1093,8 @@ let () =
     (fun (uuid, f) () ->
      let uuid_s = Uuidm.to_string uuid in
      let w = SMap.find uuid_s !election_table in
-     lwt site_user = Web_site_auth.get_user () in
+     lwt site_user = Web_auth_state.get_site_user () in
      let module W = (val w : WEB_ELECTION) in
-     let cont () () =
-       Redirection.send
-         (Eliom_service.preapply
-            election_dir
-            (W.election.e_params.e_uuid, f))
-     in
-     Eliom_reference.set Web_services.cont cont >>
      handle_pseudo_file w () f site_user)
 
 let () =
@@ -1136,7 +1105,7 @@ let () =
       let w = SMap.find uuid_s !election_table in
       let module W = (val w : WEB_ELECTION) in
       lwt () =
-        match_lwt Web_site_auth.get_user () with
+        match_lwt Web_auth_state.get_site_user () with
         | Some u when W.metadata.e_owner = Some u -> return ()
         | _ -> forbidden ()
       in

src/web/web_site_auth.ml

@@ -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