web_auth.ml 5.99 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
23
open Util
Stephane Glondu's avatar
Stephane Glondu committed
24
open Serializable_t
Stephane Glondu's avatar
Stephane Glondu committed
25
open Signatures
Stephane Glondu's avatar
Stephane Glondu committed
26
open Web_serializable_t
27
28
29
open Web_signatures
open Web_common

Stephane Glondu's avatar
Stephane Glondu committed
30
31
let string_of_user {user_domain; user_name} =
  user_domain ^ ":" ^ user_name
32

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
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
  )

type auth_instance = {
  auth_system : string;
  auth_instance : string;
  auth_config : (string * string) list;
}

51
52
53
54
55
type logged_user = {
  user_user : user;
  user_handlers : (module AUTH_HANDLERS);
}

56
57
58
59
module type CONFIG = sig
  include NAME
  val instances : auth_instance list
end
60

61
module Make (N : CONFIG) = struct
62

Stephane Glondu's avatar
Stephane Glondu committed
63
64
  let scope = Eliom_common.default_session_scope

65
66
  let auth_instances = Hashtbl.create 10
  let auth_instance_names = ref []
67

Stephane Glondu's avatar
Stephane Glondu committed
68
  let user = Eliom_reference.eref ~scope None
69

70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
  (* Forward reference, will be set to eponymous template *)
  let login_choose = ref (fun () -> assert false)

  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 successfully logged into %s"
            (string_of_user user_user) N.name
        ) >>
        Eliom_reference.set user (Some logged_user) >>
        cont () ()
      in
      let module A = (val user_handlers : AUTH_HANDLERS) in
      A.login cont ()
    with Not_found -> fail_http 404

  let login_handler service cont =
    let cont () () =
      match service with
      | Some name -> do_login_using name cont
      | None ->
        match !auth_instance_names with
        | [name] -> do_login_using name cont
        | _ -> !login_choose () >>= 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 () ()

105
106
  module Services : AUTH_SERVICES = struct

107
    let get_auth_systems () = !auth_instance_names
108

109
110
111
112
    let get_user () =
      match_lwt Eliom_reference.get user with
      | Some u -> return (Some u.user_user)
      | None -> return None
113

114
    let login = Eliom_service.service
115
      ~path:(N.path @ ["login"])
116
117
118
      ~get_params:Eliom_parameter.(opt (string "service"))
      ()

119
120
    let do_login cont () = login_handler None cont

121
    let logout = Eliom_service.service
122
      ~path:(N.path @ ["logout"])
123
124
125
      ~get_params:Eliom_parameter.unit
      ()

Stephane Glondu's avatar
Stephane Glondu committed
126
127
128
129
130
131
132
133
134
135
136
    let do_logout cont () =
      match_lwt Eliom_reference.get user with
      | Some u ->
        security_log (fun () ->
          string_of_user u.user_user ^ " logged out"
        ) >>
        Eliom_reference.unset user >>
        let module A = (val u.user_handlers) in
        A.logout cont ()
      | None -> cont () ()

137
138
  end

139
140
  module Register (C : CONT_SERVICE) (T : TEMPLATES) : EMPTY = struct

141
    let () = login_choose := T.login_choose
142

143
144
145
146
147
148
149
150
151
152
    let () = 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
153
      ) else (
154
155
156
157
        let auth_system = Hashtbl.find auth_systems name in
        let module X = (val auth_system : AUTH_SYSTEM) in
        let config = X.parse_config ~instance ~attributes in
        let auth = X.make config in
158
        let module N = struct
159
160
          let name = instance
          let path = N.path @ ["auth"; instance]
161
        end in
162
163
        let module A = (val auth : AUTH_SERVICE) (N) (T) in
        let i = (module A : AUTH_HANDLERS) in
164
165
        Hashtbl.add auth_instances instance i;
        auth_instance_names := instance :: !auth_instance_names
166
      )
167
    ) N.instances
168

169
    let () = Eliom_registration.Any.register
170
171
      ~service:Services.login
      (fun service () ->
172
173
174
        let cont () () =
          C.cont () >>= Eliom_registration.Redirection.send
        in login_handler service cont
175
176
      )

177
    let () = Eliom_registration.Any.register
178
179
      ~service:Services.logout
      (fun () () ->
Stephane Glondu's avatar
Stephane Glondu committed
180
        let cont () () =
181
          C.cont () >>= Eliom_registration.Redirection.send
Stephane Glondu's avatar
Stephane Glondu committed
182
        in Services.do_logout cont ()
183
184
185
      )

  end
186
187

end