web_auth.ml 5.26 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

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

45
46
47
48
49
type logged_user = {
  user_user : user;
  user_handlers : (module AUTH_HANDLERS);
}

50
module Make (N : NAME) = struct
51

Stephane Glondu's avatar
Stephane Glondu committed
52
53
  let scope = Eliom_common.default_session_scope

54
55
  let auth_instances = Hashtbl.create 10
  let auth_instance_names = ref []
56

57
58
59
  (* Forward reference, will be set to eponymous template *)
  let login_choose = ref (fun () -> assert false)

60
61
62
63
64
65
66
67
68
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
  let register templates xs =
    let module T = (val templates : LOGIN_TEMPLATES) in
    login_choose := T.choose;
    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
         let config = X.parse_config ~instance ~attributes in
         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
         let module A = (val auth : AUTH_SERVICE) (N) (T) in
         let i = (module A : AUTH_HANDLERS) in
         Hashtbl.add auth_instances instance i;
         auth_instance_names := instance :: !auth_instance_names
       )
      ) xs

  let user = Eliom_reference.eref ~scope None

94
95
96
97
98
99
100
  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 () ->
101
102
          Printf.sprintf "[%s] %s logged in"
            N.name (string_of_user user_user)
103
104
105
106
107
108
109
110
        ) >>
        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

111
112
  module Services : AUTH_SERVICES = struct

113
114
    let auth_realm = N.name

115
    let get_auth_systems () = !auth_instance_names
116

117
118
119
120
    let get_user () =
      match_lwt Eliom_reference.get user with
      | Some u -> return (Some u.user_user)
      | None -> return None
121

122
123
  end

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
  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 () ()

139
140
  module Handlers : AUTH_HANDLERS_PUBLIC = struct

141
    let do_login service cont () = login_handler service cont
142

Stephane Glondu's avatar
Stephane Glondu committed
143
144
145
146
    let do_logout cont () =
      match_lwt Eliom_reference.get user with
      | Some u ->
        security_log (fun () ->
147
148
          Printf.sprintf "[%s] %s logged out"
            N.name (string_of_user u.user_user)
Stephane Glondu's avatar
Stephane Glondu committed
149
150
151
152
153
154
        ) >>
        Eliom_reference.unset user >>
        let module A = (val u.user_handlers) in
        A.logout cont ()
      | None -> cont () ()

155
156
  end

157
end