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