web_auth.ml 5.81 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
(*  Copyright © 2012-2014 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/>.                                       *)
(**************************************************************************)

22
open Lwt
Stephane Glondu's avatar
Stephane Glondu committed
23
open Serializable_t
Stephane Glondu's avatar
Stephane Glondu committed
24
open Signatures
25
open Common
Stephane Glondu's avatar
Stephane Glondu committed
26
open Web_serializable_t
27 28 29
open Web_signatures
open Web_common

30 31 32 33 34 35 36 37 38 39 40 41
let auth_systems = Hashtbl.create 10

let register_auth_system auth_system =
  let module X = (val auth_system : AUTH_SYSTEM) in
  if Hashtbl.mem auth_systems X.name then (
    Printf.ksprintf failwith
      "multiple authentication systems with name %s"
      X.name
  ) else (
    Hashtbl.add auth_systems X.name auth_system
  )

42 43
type logged_user = {
  user_user : user;
44
  user_handlers : (module AUTH_INSTANCE_HANDLERS);
45 46
}

47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
module MakeLinks (N : NAME) = struct
  let login, logout =
    match N.kind with
    | `Site ->
       (fun x -> Eliom_service.preapply Web_services.site_login x),
       (Eliom_service.preapply Web_services.site_logout ())
    | `Election (uuid, _) ->
       (fun x ->
        Eliom_service.preapply
          Web_services.election_login
          ((uuid, ()), x)),
       (Eliom_service.preapply
          Web_services.election_logout
          (uuid, ()))
end

63
module Make (N : NAME) = struct
64

65 66 67
  module L = MakeLinks (N)
  let links = (module L : AUTH_LINKS)

Stephane Glondu's avatar
Stephane Glondu committed
68 69
  let scope = Eliom_common.default_session_scope

70 71
  let auth_instances = Hashtbl.create 10
  let auth_instance_names = ref []
72

73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
  let user = Eliom_reference.eref ~scope None

  let do_login_using user_domain cont =
    try
      let user_handlers = Hashtbl.find auth_instances user_domain in
      let cont user_name () =
        let user_user = {user_domain; user_name} in
        let logged_user = {user_user; user_handlers} in
        security_log (fun () ->
          Printf.sprintf "[%s] %s logged in"
            N.name (string_of_user user_user)
        ) >>
        Eliom_reference.set user (Some logged_user) >>
        cont () ()
      in
88
      let module A = (val user_handlers : AUTH_INSTANCE_HANDLERS) in
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
      A.login cont ()
    with Not_found -> fail_http 404

  module Services : AUTH_SERVICES = struct

    let auth_realm = N.name

    let get_auth_systems () = !auth_instance_names

    let get_user () =
      match_lwt Eliom_reference.get user with
      | Some u -> return (Some u.user_user)
      | None -> return None

  end

105 106
  let auth_services = (module Services : AUTH_SERVICES)

107
  let configure xs =
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
    List.iter
      (fun auth_instance ->
       let {
         auth_system = name;
         auth_instance = instance;
         auth_config = attributes;
       } = auth_instance in
       if Hashtbl.mem auth_instances instance then (
         Printf.ksprintf
           failwith
           "multiple instances with name %s"
           instance
       ) else (
         let auth_system = Hashtbl.find auth_systems name in
         let module X = (val auth_system : AUTH_SYSTEM) in
123 124 125 126 127 128 129 130 131
         let config =
           match X.parse_config ~attributes with
           | Some x -> x
           | None ->
              Printf.ksprintf
                failwith
                "invalid configuration for instance %s of auth/%s"
                instance X.name
         in
132 133 134 135 136 137
         let auth = X.make config in
         let module N = struct
           let name = instance
           let path = N.path @ ["auth"; instance]
           let kind = N.kind
         end in
138 139
         let module A = (val auth : AUTH_MAKE_INSTANCE) (N) (Services) in
         let i = (module A : AUTH_INSTANCE_HANDLERS) in
140 141 142 143 144
         Hashtbl.add auth_instances instance i;
         auth_instance_names := instance :: !auth_instance_names
       )
      ) xs

145
  module Handlers : AUTH_HANDLERS = struct
146

147
    let login service cont () =
Stephane Glondu's avatar
Stephane Glondu committed
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162
      let cont () () =
        match service with
        | Some name -> do_login_using name cont
        | None ->
          match !auth_instance_names with
          | [name] -> do_login_using name cont
          | _ ->
             Web_templates.choose auth_services links () >>=
             Eliom_registration.Html5.send
      in
      match_lwt Eliom_reference.get user with
      | Some u ->
        let module A = (val u.user_handlers) in
        A.logout cont ()
      | None -> cont () ()
163

164
    let logout cont () =
Stephane Glondu's avatar
Stephane Glondu committed
165 166 167
      match_lwt Eliom_reference.get user with
      | Some u ->
        security_log (fun () ->
168 169
          Printf.sprintf "[%s] %s logged out"
            N.name (string_of_user u.user_user)
Stephane Glondu's avatar
Stephane Glondu committed
170 171 172 173 174 175
        ) >>
        Eliom_reference.unset user >>
        let module A = (val u.user_handlers) in
        A.logout cont ()
      | None -> cont () ()

176 177
  end

178
end