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

63
64
  let auth_instances = Hashtbl.create 10
  let auth_instance_names = ref []
65

66
67
68
69
  let user = Eliom_reference.eref
    ~scope:Eliom_common.default_session_scope
    None

70
71
  module Services : AUTH_SERVICES = struct

72
    let get_auth_systems () = !auth_instance_names
73

74
75
76
77
    let get_user () =
      match_lwt Eliom_reference.get user with
      | Some u -> return (Some u.user_user)
      | None -> return None
78

79
    let login = Eliom_service.service
80
      ~path:(N.path @ ["login"])
81
82
83
84
      ~get_params:Eliom_parameter.(opt (string "service"))
      ()

    let logout = Eliom_service.service
85
      ~path:(N.path @ ["logout"])
86
87
88
89
90
      ~get_params:Eliom_parameter.unit
      ()

  end

91
92
  module Register (C : CONT_SERVICE) (T : TEMPLATES) : EMPTY = struct

93
94
95
96
97
98
99
100
101
102
    let on_success user_domain user_handlers user_name () =
      security_log (fun () ->
        Printf.sprintf "%s successfully logged on %s using %s"
          user_name N.name user_domain
      ) >>
      let user_user = {user_domain; user_name} in
      let logged_user = {user_user; user_handlers} in
      Eliom_reference.set user (Some logged_user) >>
      C.cont () >>= Eliom_registration.Redirection.send

103
104
105
106
107
108
109
110
111
112
    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
113
      ) else (
114
115
116
117
        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
118
        let module N = struct
119
120
          let name = instance
          let path = N.path @ ["auth"; instance]
121
        end in
122
123
        let module A = (val auth : AUTH_SERVICE) (N) (T) in
        let i = (module A : AUTH_HANDLERS) in
124
125
        Hashtbl.add auth_instances instance i;
        auth_instance_names := instance :: !auth_instance_names
126
      )
127
    ) N.instances
128

129
    let () = Eliom_registration.Any.register
130
131
      ~service:Services.login
      (fun service () ->
132
133
        let use name =
          try
134
            let i = Hashtbl.find auth_instances name in
135
136
            let module A = (val i : AUTH_HANDLERS) in
            A.login (on_success name i) ()
137
          with Not_found -> fail_http 404
138
        in
139
140
141
        match service with
        | Some name -> use name
        | None ->
142
          match !auth_instance_names with
143
          | [name] -> use name
144
          | _ -> T.login_choose () >>= Eliom_registration.Html5.send
145
146
      )

147
    let () = Eliom_registration.Any.register
148
149
150
151
152
153
      ~service:Services.logout
      (fun () () ->
        lwt u = Eliom_reference.get user in
        (* should ballot be unset here or not? *)
        Eliom_reference.unset user >>
        match u with
154
155
156
157
158
159
160
161
162
163
164
        | Some u ->
          security_log (fun () ->
            string_of_user u.user_user ^ " logged out"
          ) >>
          let module A = (val u.user_handlers) in
          let cont () () =
            C.cont () >>= Eliom_registration.Redirection.send
          in
          A.logout cont ()
        | _ ->
          C.cont () >>= Eliom_registration.Redirection.send
165
166
167
      )

  end
168
169

end