web_auth.ml 15.2 KB
Newer Older
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2018 Inria                                           *)
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
(*                                                                        *)
(*  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 23 24
open Lwt
open Eliom_service
open Platform
25
open Serializable_builtin_t
26
open Web_serializable_j
27
open Web_common
28
open Web_state
29
open Web_services
30

31 32
let ( / ) = Filename.concat

33
let next_lf str i =
34
  String.index_from_opt str i '\n'
35

36 37 38 39 40
let scope = Eliom_common.default_session_scope

let auth_env = Eliom_reference.eref ~scope None

let default_cont uuid () =
41
  match%lwt cont_pop () with
42 43 44 45
  | Some f -> f ()
  | None ->
     match uuid with
     | None ->
Stephane Glondu's avatar
Stephane Glondu committed
46
        Eliom_registration.(Redirection.send (Redirection Web_services.admin))
47
     | Some u ->
Stephane Glondu's avatar
Stephane Glondu committed
48
        Eliom_registration.(Redirection.send (Redirection (preapply Web_services.election_home (u, ()))))
49

50 51
(** Dummy authentication *)

52
let dummy_handler () name =
53
  match%lwt Eliom_reference.get auth_env with
54
  | None -> failwith "dummy handler was invoked without environment"
55
  | Some (uuid, service, _) ->
56 57
     let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
     let%lwt () = Eliom_reference.unset auth_env in
58 59 60 61
     default_cont uuid ()

let () = Eliom_registration.Any.register ~service:dummy_post dummy_handler

62 63
(** Password authentication *)

64 65
let check_password_with_file db name password =
  let%lwt db = Lwt_preemptive.detach Csv.load db in
66 67 68 69 70 71 72 73 74
  match
    List.find_opt (function
        | username :: _ :: _ :: _ -> username = name
        | _ -> false
      ) db
  with
  | Some (_ :: salt :: hashed :: _) ->
     return (sha256_hex (salt ^ password) = hashed)
  | _ -> return false
75

76
let password_handler () (name, password) =
77
  let%lwt uuid, service, config =
78
    match%lwt Eliom_reference.get auth_env with
79 80 81
    | None -> failwith "password handler was invoked without environment"
    | Some x -> return x
  in
82
  let%lwt ok =
83
    match uuid with
84 85
    | None ->
       begin
86 87
         match List.assoc_opt "db" config with
         | Some db -> check_password_with_file db name password
88 89 90
         | _ -> failwith "invalid configuration for admin site"
       end
    | Some uuid ->
91 92 93
       let uuid_s = raw_string_of_uuid uuid in
       let db = !spool_dir / uuid_s / "passwords.csv" in
       check_password_with_file db name password
94
  in
95
  if ok then
96 97
    let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
    let%lwt () = Eliom_reference.unset auth_env in
98 99 100 101 102 103
    default_cont uuid ()
  else
    fail_http 401

let () = Eliom_registration.Any.register ~service:password_post password_handler

104 105 106 107 108
let does_allow_signups c =
  match List.assoc_opt "allowsignups" c with
  | Some x -> bool_of_string x
  | None -> false

109 110 111
let get_password_db_fname () =
  let rec find = function
    | [] -> None
112 113
    | { auth_system = "password"; auth_config = c; _ } :: _
         when does_allow_signups c -> List.assoc_opt "db" c
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
    | _ :: xs -> find xs
  in find !site_auth_config

let allowsignups () = get_password_db_fname () <> None

let password_db_mutex = Lwt_mutex.create ()

let do_add_account ~db_fname ~username ~password ~email () =
  let%lwt db = Lwt_preemptive.detach Csv.load db_fname in
  let%lwt salt = generate_token ~length:8 () in
  let hashed = sha256_hex (salt ^ password) in
  let rec append accu = function
    | [] -> Some (List.rev ([username; salt; hashed; email] :: accu))
    | ((username' :: _ :: _ :: _) as x) :: xs ->
       if username = username' then None else append (x :: accu) xs
    | _ :: _ -> None
  in
  match append [] db with
  | None -> Lwt.return false
  | Some db ->
     let db = List.map (String.concat ",") db in
     let%lwt () = write_file db_fname db in
     Lwt.return true

138 139 140 141 142
let username_rex = "^[A-Z0-9._%+-]+$"

let is_username =
  let rex = Pcre.regexp ~flags:[`CASELESS] username_rex in
  fun x ->
143 144 145
  match pcre_exec_opt ~rex x with
  | Some _ -> true
  | None -> false
146

147
let add_account ~username ~password ~email =
148
  if is_username username then
149 150 151 152 153 154 155 156 157 158
    match%lwt Web_signup.cracklib_check password with
    | Some e -> return (Some (BadPassword e))
    | None ->
       match get_password_db_fname () with
       | None -> forbidden ()
       | Some db_fname ->
          if%lwt Lwt_mutex.with_lock password_db_mutex
               (do_add_account ~db_fname ~username ~password ~email)
          then return None
          else return (Some UsernameTaken)
159
  else return (Some BadUsername)
160

161 162
(** CAS authentication *)

163 164
let cas_server = Eliom_reference.eref ~scope None

Stephane Glondu's avatar
Stephane Glondu committed
165 166 167
let login_cas = Eliom_service.create
  ~path:(Eliom_service.Path ["auth"; "cas"])
  ~meth:(Eliom_service.Get Eliom_parameter.(opt (string "ticket")))
168 169 170 171 172 173 174 175 176
  ()

let cas_self =
  (* lazy so rewrite_prefix is called after server initialization *)
  lazy (Eliom_uri.make_string_uri
          ~absolute:true
          ~service:(preapply login_cas None)
          () |> rewrite_prefix)

177 178 179 180 181 182 183 184 185 186 187 188 189 190
let parse_cas_validation info =
  match next_lf info 0 with
  | Some i ->
     (match String.sub info 0 i with
     | "yes" -> `Yes
        (match next_lf info (i+1) with
        | Some j -> Some (String.sub info (i+1) (j-i-1))
        | None -> None)
     | "no" -> `No
     | _ -> `Error `Parsing)
  | None -> `Error `Parsing

let get_cas_validation server ticket =
  let url =
Stephane Glondu's avatar
Stephane Glondu committed
191
    let cas_validate = Eliom_service.extern
192 193
      ~prefix:server
      ~path:["validate"]
Stephane Glondu's avatar
Stephane Glondu committed
194
      ~meth:(Eliom_service.Get Eliom_parameter.(string "service" ** string "ticket"))
195 196 197 198 199
      ()
    in
    let service = preapply cas_validate (Lazy.force cas_self, ticket) in
    Eliom_uri.make_string_uri ~absolute:true ~service ()
  in
200
  let%lwt reply = Ocsigen_http_client.get_url url in
201 202
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
203
     let%lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
204
     let%lwt () = Ocsigen_stream.finalize stream `Success in
205 206 207
     return (parse_cas_validation info)
  | None -> return (`Error `Http)

208
let cas_handler ticket () =
209
  let%lwt uuid, service, _ =
210
    match%lwt Eliom_reference.get auth_env with
211 212 213 214 215
    | None -> failwith "cas handler was invoked without environment"
    | Some x -> return x
  in
  match ticket with
  | Some x ->
216 217
     let%lwt server =
       match%lwt Eliom_reference.get cas_server with
218 219 220
       | None -> failwith "cas handler was invoked without a server"
       | Some x -> return x
     in
221
     (match%lwt get_cas_validation server x with
222
     | `Yes (Some name) ->
223
        let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
224 225 226
        default_cont uuid ()
     | `No -> fail_http 401
     | `Yes None | `Error _ -> fail_http 502)
227
  | None ->
228 229
     let%lwt () = Eliom_reference.unset cas_server in
     let%lwt () = Eliom_reference.unset auth_env in
230 231 232 233 234
     default_cont uuid ()

let () = Eliom_registration.Any.register ~service:login_cas cas_handler

let cas_login_handler config () =
235 236
  match List.assoc_opt "server" config with
  | Some server ->
237
     let%lwt () = Eliom_reference.set cas_server (Some server) in
Stephane Glondu's avatar
Stephane Glondu committed
238
     let cas_login = Eliom_service.extern
239 240
       ~prefix:server
       ~path:["login"]
Stephane Glondu's avatar
Stephane Glondu committed
241
       ~meth:(Eliom_service.Get Eliom_parameter.(string "service"))
242 243
       ()
     in
244
     let service = preapply cas_login (Lazy.force cas_self) in
Stephane Glondu's avatar
Stephane Glondu committed
245
     Eliom_registration.(Redirection.send (Redirection service))
246 247
  | _ -> failwith "cas_login_handler invoked with bad config"

248 249 250 251
(** OpenID Connect (OIDC) authentication *)

let oidc_state = Eliom_reference.eref ~scope None

Stephane Glondu's avatar
Stephane Glondu committed
252 253 254
let login_oidc = Eliom_service.create
  ~path:(Eliom_service.Path ["auth"; "oidc"])
  ~meth:(Eliom_service.Get Eliom_parameter.any)
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
  ()

let oidc_self =
  lazy (Eliom_uri.make_string_uri
          ~absolute:true
          ~service:(preapply login_oidc [])
          () |> rewrite_prefix)

let oidc_get_userinfo ocfg info =
  let info = oidc_tokens_of_string info in
  let access_token = info.oidc_access_token in
  let url = ocfg.userinfo_endpoint in
  let headers = Http_headers.(
    add (name "Authorization") ("Bearer " ^ access_token) empty
  ) in
270
  let%lwt reply = Ocsigen_http_client.get_url ~headers url in
271 272
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
273
     let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
274
     let%lwt () = Ocsigen_stream.finalize stream `Success in
275 276 277 278 279 280 281 282 283 284 285 286
     let x = oidc_userinfo_of_string info in
     return (Some (match x.oidc_email with Some x -> x | None -> x.oidc_sub))
  | None -> return None

let oidc_get_name ocfg client_id client_secret code =
  let content = [
    "code", code;
    "client_id", client_id;
    "client_secret", client_secret;
    "redirect_uri", Lazy.force oidc_self;
    "grant_type", "authorization_code";
  ] in
287
  let%lwt reply = Ocsigen_http_client.post_urlencoded_url ~content ocfg.token_endpoint in
288 289
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
290
    let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
291
    let%lwt () = Ocsigen_stream.finalize stream `Success in
292 293 294 295
    oidc_get_userinfo ocfg info
  | None -> return None

let oidc_handler params () =
296
  let%lwt uuid, service, _ =
297
    match%lwt Eliom_reference.get auth_env with
298 299 300
    | None -> failwith "oidc handler was invoked without environment"
    | Some x -> return x
  in
301 302
  let code = List.assoc_opt "code" params in
  let state = List.assoc_opt "state" params in
303 304
  match code, state with
  | Some code, Some state ->
305 306
    let%lwt ocfg, client_id, client_secret, st =
      match%lwt Eliom_reference.get oidc_state with
307 308 309
      | None -> failwith "oidc handler was invoked without a state"
      | Some x -> return x
    in
310 311
    let%lwt () = Eliom_reference.unset oidc_state in
    let%lwt () = Eliom_reference.unset auth_env in
312
    if state <> st then fail_http 401 else
313
    (match%lwt oidc_get_name ocfg client_id client_secret code with
314
    | Some name ->
315
       let%lwt () = Eliom_reference.set user (Some {uuid; service; name}) in
316 317 318 319 320 321 322 323
       default_cont uuid ()
    | None -> fail_http 401)
  | _, _ -> default_cont uuid ()

let () = Eliom_registration.Any.register ~service:login_oidc oidc_handler

let get_oidc_configuration server =
  let url = server ^ "/.well-known/openid-configuration" in
324
  let%lwt reply = Ocsigen_http_client.get_url url in
325 326
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
327
     let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
328
     let%lwt () = Ocsigen_stream.finalize stream `Success in
329 330 331 332 333 334 335 336 337
     return (oidc_configuration_of_string info)
  | None -> fail_http 404

let split_prefix_path url =
  let n = String.length url in
  let i = String.rindex url '/' in
  String.sub url 0 i, [String.sub url (i+1) (n-i-1)]

let oidc_login_handler config () =
338 339 340
  let get x = List.assoc_opt x config in
  match get "server", get "client_id", get "client_secret" with
  | Some server, Some client_id, Some client_secret ->
341 342
     let%lwt ocfg = get_oidc_configuration server in
     let%lwt state = generate_token () in
343
     let%lwt () = Eliom_reference.set oidc_state (Some (ocfg, client_id, client_secret, state)) in
344
     let prefix, path = split_prefix_path ocfg.authorization_endpoint in
Stephane Glondu's avatar
Stephane Glondu committed
345 346
     let auth_endpoint = Eliom_service.extern ~prefix ~path
       ~meth:(Eliom_service.Get Eliom_parameter.(string "redirect_uri" **
347
           string "response_type" ** string "client_id" **
Stephane Glondu's avatar
Stephane Glondu committed
348
           string "scope" ** string "state" ** string "prompt"))
349 350 351 352 353
       ()
     in
     let service = preapply auth_endpoint
       (Lazy.force oidc_self, ("code", (client_id, ("openid email", (state, "consent")))))
     in
Stephane Glondu's avatar
Stephane Glondu committed
354
     Eliom_registration.(Redirection.send (Redirection service))
355 356
  | _ -> failwith "oidc_login_handler invoked with bad config"

357 358
(** Generic authentication *)

359
let get_login_handler service uuid auth_system config =
360
  let%lwt () = Eliom_reference.set auth_env (Some (uuid, service, config)) in
361
  match auth_system with
Stephane Glondu's avatar
Stephane Glondu committed
362
  | "dummy" -> Web_templates.login_dummy () >>= Eliom_registration.Html.send
363
  | "cas" -> cas_login_handler config ()
Stephane Glondu's avatar
Stephane Glondu committed
364
  | "password" -> Web_templates.login_password () >>= Eliom_registration.Html.send
365
  | "oidc" -> oidc_login_handler config ()
366 367
  | _ -> fail_http 404

368
let rec find_auth_instance x = function
369 370
  | [] -> None
  | { auth_instance = i; auth_system = s; auth_config = c } :: _ when i = x -> Some (s, c)
371 372
  | _ :: xs -> find_auth_instance x xs

373 374 375 376 377 378
let login_handler service uuid =
  let myself service =
    match uuid with
    | None -> preapply site_login service
    | Some u -> preapply election_login ((u, ()), service)
  in
379
  match%lwt Eliom_reference.get user with
Stephane Glondu's avatar
Stephane Glondu committed
380
  | Some _ ->
381
     let%lwt () = cont_push (fun () -> Eliom_registration.(Redirection.send (Redirection (myself service)))) in
Stephane Glondu's avatar
Stephane Glondu committed
382
     Web_templates.already_logged_in () >>= Eliom_registration.Html.send
383
  | None ->
384 385 386 387
     let%lwt c = match uuid with
       | None -> return !site_auth_config
       | Some u -> Web_persist.get_auth_config u
     in
388 389
     match service with
     | Some s ->
390
        let%lwt auth_system, config =
391 392 393
          match find_auth_instance s c with
          | Some x -> return x
          | None -> fail_http 404
394 395 396 397
        in
        get_login_handler s uuid auth_system config
     | None ->
        match c with
398
        | [s] -> Eliom_registration.(Redirection.send (Redirection (myself (Some s.auth_instance))))
399 400 401 402 403 404 405 406
        | _ ->
           let builder =
             match uuid with
             | None -> fun s ->
               preapply Web_services.site_login (Some s)
             | Some u -> fun s ->
               preapply Web_services.election_login ((u, ()), Some s)
           in
407
           Web_templates.login_choose (List.map (fun x -> x.auth_instance) c) builder () >>=
Stephane Glondu's avatar
Stephane Glondu committed
408
           Eliom_registration.Html.send
409 410

let logout_handler () =
411
  let%lwt () = Eliom_reference.unset Web_state.user in
412 413
  match%lwt cont_pop () with
  | Some f -> f ()
Stephane Glondu's avatar
Stephane Glondu committed
414
  | None -> Eliom_registration.(Redirection.send (Redirection Web_services.home))
415

416 417
let () = Eliom_registration.Any.register ~service:site_login
  (fun service () -> login_handler service None)
418

Stephane Glondu's avatar
Stephane Glondu committed
419
let () = Eliom_registration.Any.register ~service:logout
420
  (fun () () -> logout_handler ())
421

422 423
let () = Eliom_registration.Any.register ~service:election_login
  (fun ((uuid, ()), service) () -> login_handler service (Some uuid))