web_auth.ml 12.9 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 Web_serializable_j
26
open Web_common
27
open Web_state
28
open Web_services
29

30 31 32
let next_lf str i =
  try Some (String.index_from str i '\n')
  with Not_found -> None
33

34 35 36 37 38 39
let configure x =
  let auth_config =
    List.map (fun {auth_system; auth_instance; auth_config} ->
      auth_instance, (auth_system, List.map snd auth_config)
    ) x
  in
40
  Web_persist.set_auth_config None auth_config |> Lwt_main.run
41 42 43 44 45 46

let scope = Eliom_common.default_session_scope

let auth_env = Eliom_reference.eref ~scope None

let default_cont uuid () =
47
  match%lwt cont_pop () with
48 49 50 51 52 53 54 55
  | Some f -> f ()
  | None ->
     match uuid with
     | None ->
        Eliom_registration.Redirection.send Web_services.admin
     | Some u ->
        Eliom_registration.Redirection.send (preapply Web_services.election_home (u, ()))

56 57
(** Dummy authentication *)

58
let dummy_handler () name =
59
  match%lwt Eliom_reference.get auth_env with
60
  | None -> failwith "dummy handler was invoked without environment"
61
  | Some (uuid, service, _) ->
62
     Eliom_reference.set user (Some {uuid; service; name}) >>
63 64 65 66 67
     Eliom_reference.unset auth_env >>
     default_cont uuid ()

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

68 69
(** Password authentication *)

70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
let check_password_with_file db name password =
  let%lwt db = Lwt_preemptive.detach Csv.load db in
  try
    begin
      match
        List.find (function
            | username :: _ :: _ :: _ -> username = name
            | _ -> false
          ) db
      with
      | _ :: salt :: hashed :: _ ->
         return (sha256_hex (salt ^ password) = hashed)
      | _ -> return false
    end
  with Not_found -> return false

86
let password_handler () (name, password) =
87
  let%lwt uuid, service, config =
88
    match%lwt Eliom_reference.get auth_env with
89 90 91
    | None -> failwith "password handler was invoked without environment"
    | Some x -> return x
  in
92
  let%lwt ok =
93
    match uuid with
94 95 96 97 98 99 100 101 102 103 104 105 106
    | None ->
       begin
         match config with
         | [db] -> check_password_with_file db name password
         | _ -> failwith "invalid configuration for admin site"
       end
    | Some uuid ->
       let table = "password_" ^ underscorize uuid in
       let table = Ocsipersist.open_table table in
       try%lwt
         let%lwt salt, hashed = Ocsipersist.find table name in
         return (sha256_hex (salt ^ password) = hashed)
       with Not_found -> return false
107
  in
108
  if ok then
109
    Eliom_reference.set user (Some {uuid; service; name}) >>
110 111 112 113 114 115 116
    Eliom_reference.unset auth_env >>
    default_cont uuid ()
  else
    fail_http 401

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

117 118
(** CAS authentication *)

119 120 121 122 123 124 125 126 127 128 129 130 131 132
let cas_server = Eliom_reference.eref ~scope None

let login_cas = Eliom_service.Http.service
  ~path:["auth"; "cas"]
  ~get_params:Eliom_parameter.(opt (string "ticket"))
  ()

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)

133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
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 =
    let cas_validate = Http.external_service
      ~prefix:server
      ~path:["validate"]
      ~get_params:Eliom_parameter.(string "service" ** string "ticket")
      ()
    in
    let service = preapply cas_validate (Lazy.force cas_self, ticket) in
    Eliom_uri.make_string_uri ~absolute:true ~service ()
  in
156
  let%lwt reply = Ocsigen_http_client.get_url url in
157 158
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
159
     let%lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
160 161 162 163
     Ocsigen_stream.finalize stream `Success >>
     return (parse_cas_validation info)
  | None -> return (`Error `Http)

164
let cas_handler ticket () =
165
  let%lwt uuid, service, _ =
166
    match%lwt Eliom_reference.get auth_env with
167 168 169 170 171
    | None -> failwith "cas handler was invoked without environment"
    | Some x -> return x
  in
  match ticket with
  | Some x ->
172 173
     let%lwt server =
       match%lwt Eliom_reference.get cas_server with
174 175 176
       | None -> failwith "cas handler was invoked without a server"
       | Some x -> return x
     in
177
     (match%lwt get_cas_validation server x with
178
     | `Yes (Some name) ->
179
        Eliom_reference.set user (Some {uuid; service; name}) >>
180 181 182
        default_cont uuid ()
     | `No -> fail_http 401
     | `Yes None | `Error _ -> fail_http 502)
183 184 185 186 187 188 189 190 191 192 193 194 195 196
  | None ->
     Eliom_reference.unset cas_server >>
     Eliom_reference.unset auth_env >>
     default_cont uuid ()

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

let cas_login_handler config () =
  match config with
  | [server] ->
     Eliom_reference.set cas_server (Some server) >>
     let cas_login = Http.external_service
       ~prefix:server
       ~path:["login"]
197
       ~get_params:Eliom_parameter.(string "service")
198 199
       ()
     in
200
     let service = preapply cas_login (Lazy.force cas_self) in
201 202 203
     Eliom_registration.Redirection.send service
  | _ -> failwith "cas_login_handler invoked with bad config"

204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225
(** OpenID Connect (OIDC) authentication *)

let oidc_state = Eliom_reference.eref ~scope None

let login_oidc = Eliom_service.Http.service
  ~path:["auth"; "oidc"]
  ~get_params:Eliom_parameter.any
  ()

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
226
  let%lwt reply = Ocsigen_http_client.get_url ~headers url in
227 228
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
229
     let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
230 231 232 233 234 235 236 237 238 239 240 241 242
     Ocsigen_stream.finalize stream `Success >>
     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
243
  let%lwt reply = Ocsigen_http_client.post_urlencoded_url ~content ocfg.token_endpoint in
244 245
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
246
    let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
247 248 249 250 251
    Ocsigen_stream.finalize stream `Success >>
    oidc_get_userinfo ocfg info
  | None -> return None

let oidc_handler params () =
252
  let%lwt uuid, service, _ =
253
    match%lwt Eliom_reference.get auth_env with
254 255 256 257 258 259 260
    | None -> failwith "oidc handler was invoked without environment"
    | Some x -> return x
  in
  let code = try Some (List.assoc "code" params) with Not_found -> None in
  let state = try Some (List.assoc "state" params) with Not_found -> None in
  match code, state with
  | Some code, Some state ->
261 262
    let%lwt ocfg, client_id, client_secret, st =
      match%lwt Eliom_reference.get oidc_state with
263 264 265 266 267 268
      | None -> failwith "oidc handler was invoked without a state"
      | Some x -> return x
    in
    Eliom_reference.unset oidc_state >>
    Eliom_reference.unset auth_env >>
    if state <> st then fail_http 401 else
269
    (match%lwt oidc_get_name ocfg client_id client_secret code with
270
    | Some name ->
271
       Eliom_reference.set user (Some {uuid; service; name}) >>
272 273 274 275 276 277 278 279
       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
280
  let%lwt reply = Ocsigen_http_client.get_url url in
281 282
  match reply.Ocsigen_http_frame.frame_content with
  | Some stream ->
283
     let%lwt info = Ocsigen_stream.(string_of_stream 10000 (get stream)) in
284 285 286 287 288 289 290 291 292 293 294 295
     Ocsigen_stream.finalize stream `Success >>
     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 () =
  match config with
  | [server; client_id; client_secret] ->
296 297
     let%lwt ocfg = get_oidc_configuration server in
     let%lwt state = generate_token () in
298 299 300 301 302 303 304 305 306 307 308 309 310 311
     Eliom_reference.set oidc_state (Some (ocfg, client_id, client_secret, state)) >>
     let prefix, path = split_prefix_path ocfg.authorization_endpoint in
     let auth_endpoint = Http.external_service ~prefix ~path
       ~get_params:Eliom_parameter.(string "redirect_uri" **
           string "response_type" ** string "client_id" **
           string "scope" ** string "state" ** string "prompt")
       ()
     in
     let service = preapply auth_endpoint
       (Lazy.force oidc_self, ("code", (client_id, ("openid email", (state, "consent")))))
     in
     Eliom_registration.Redirection.send service
  | _ -> failwith "oidc_login_handler invoked with bad config"

312 313
(** Generic authentication *)

314
let get_login_handler service uuid auth_system config =
315
  Eliom_reference.set auth_env (Some (uuid, service, config)) >>
316 317 318 319
  match auth_system with
  | "dummy" -> Web_templates.login_dummy () >>= Eliom_registration.Html5.send
  | "cas" -> cas_login_handler config ()
  | "password" -> Web_templates.login_password () >>= Eliom_registration.Html5.send
320
  | "oidc" -> oidc_login_handler config ()
321 322 323 324 325 326 327 328
  | _ -> fail_http 404

let login_handler service uuid =
  let myself service =
    match uuid with
    | None -> preapply site_login service
    | Some u -> preapply election_login ((u, ()), service)
  in
329
  match%lwt Eliom_reference.get user with
Stephane Glondu's avatar
Stephane Glondu committed
330
  | Some _ ->
331 332 333
     cont_push (fun () -> Eliom_registration.Redirection.send (myself service)) >>
     Web_templates.already_logged_in () >>= Eliom_registration.Html5.send
  | None ->
334
     let%lwt c = Web_persist.get_auth_config uuid in
335 336
     match service with
     | Some s ->
337
        let%lwt auth_system, config =
338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
          try return @@ List.assoc s c
          with Not_found -> fail_http 404
        in
        get_login_handler s uuid auth_system config
     | None ->
        match c with
        | [s, _] -> Eliom_registration.Redirection.send (myself (Some s))
        | _ ->
           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
           Web_templates.login_choose (List.map fst c) builder () >>=
           Eliom_registration.Html5.send

let logout_handler () =
357 358 359 360
  Eliom_reference.unset Web_state.user >>
  match%lwt cont_pop () with
  | Some f -> f ()
  | None -> Eliom_registration.Redirection.send Web_services.home
361

362 363
let () = Eliom_registration.Any.register ~service:site_login
  (fun service () -> login_handler service None)
364

Stephane Glondu's avatar
Stephane Glondu committed
365
let () = Eliom_registration.Any.register ~service:logout
366
  (fun () () -> logout_handler ())
367

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