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_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
+  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 ())

src/web/web_site_auth.mli

@@ -2,5 +2,3 @@ open Web_serializable_t
 open Web_signatures
 
 val configure : auth_config list -> unit
-
-include AUTH_SERVICES

src/web/web_site_auth_state.ml

-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 [])

src/web/web_templates.ml

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

src/web/web_templates.mli

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