auth_password.ml 5.34 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 Platform
Stephane Glondu's avatar
Stephane Glondu committed
24
open Common
25
26
open Web_signatures
open Web_common
27
28
29
30
31

type config = { db : string }

let name = "password"

32
let parse_config ~attributes =
33
  match attributes with
34
35
  | ["db", db] -> Some {db}
  | _ -> None
36

37
38
39
module type CONFIG = sig
  val db : string
end
40

41
42
43
44
45
46
47
48
49
50
51
let load_db name file =
  (* FIXME: not cooperative *)
  List.fold_left (fun accu line ->
    match line with
    | username :: salt :: password :: _ ->
      SMap.add username (salt, password) accu
    | _ -> failwith ("error while parsing db file for " ^ name)
  ) SMap.empty (Csv.load file)

let ( / ) = Filename.concat

52
module Make (C : CONFIG) (N : NAME) (S : AUTH_SERVICES) (L : AUTH_LINKS) : AUTH_HANDLERS = struct
53

Stephane Glondu's avatar
Stephane Glondu committed
54
55
  let scope = Eliom_common.default_session_scope

Stephane Glondu's avatar
Stephane Glondu committed
56
  let service = Eliom_service.Http.service
57
    ~path:N.path
58
59
    ~get_params:Eliom_parameter.unit
    ()
60

61
  let db =
62
63
64
65
66
67
68
69
70
71
    ref @@ match N.kind with
    | `Site -> `Production (load_db N.name C.db)
    | `Election dir ->
      (* hash the user-input name to avoid all kinds of injection *)
      let fname = dir / sha256_hex C.db in
      try
        `Production (load_db N.name fname)
      with _ ->
        (* Maybe we should filter the kind of error...? *)
        `Bootstrap fname
72

Stephane Glondu's avatar
Stephane Glondu committed
73
  let login_cont = Eliom_reference.eref ~scope None
74

75
76
77
78
  let production_service_handler db =
    let post_params = Eliom_parameter.(
      string "username" ** string "password"
    ) in
Stephane Glondu's avatar
Stephane Glondu committed
79
    let service = Eliom_service.Http.post_coservice
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
      ~csrf_safe:true
      ~csrf_scope:scope
      ~fallback:service
      ~post_params ()
    in
    let () = Eliom_registration.Any.register ~service ~scope
      (fun () (user_name, password) ->
        if (
          try
            let salt, hashed = SMap.find user_name db in
            sha256_hex (salt ^ password) = hashed
          with Not_found -> false
        ) then (
          match_lwt Eliom_reference.get login_cont with
          | Some cont ->
            Eliom_reference.unset login_cont >>
            cont user_name ()
          | None -> fail_http 400
        ) else forbidden ())
    in
100
    Web_templates.password ~service (module S : AUTH_SERVICES) (module L : AUTH_LINKS) ()
101
102
103

  let bootstrap_service_handler () =
    let post_params = Eliom_parameter.file "password_db" in
Stephane Glondu's avatar
Stephane Glondu committed
104
    let upload_service = Eliom_service.Http.post_coservice
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
      ~csrf_safe:true
      ~csrf_scope:scope
      ~fallback:service
      ~post_params ()
    in
    let () = Eliom_registration.Any.register ~service:upload_service ~scope
      (fun () password_db ->
        match !db with
        | `Bootstrap db_fname ->
          let fname = password_db.Ocsigen_extensions.tmp_filename in
          let the_db = load_db N.name fname in
          (* loading was successful, we copy the file for future reference *)
          lwt () =
            Lwt_io.(with_file Output db_fname (fun oc ->
              with_file Input fname (fun ic ->
                read_chars ic |> write_chars oc
              )
            ))
          in
          db := `Production the_db;
          Eliom_registration.Redirection.send service
        | `Production _ -> forbidden ()
      )
    in
129
    Web_templates.upload_password_db ~service:upload_service (module S : AUTH_SERVICES) (module L : AUTH_LINKS) ()
130

131
132
  let () = Eliom_registration.Html5.register ~service
    (fun () () ->
133
134
135
      match !db with
      | `Bootstrap _ -> bootstrap_service_handler ()
      | `Production db -> production_service_handler db
136
    )
137

138
139
  let login cont () =
    Eliom_reference.set login_cont (Some cont) >>
140
    Eliom_registration.Redirection.send service
141

142
143
  let logout cont () = cont () ()

144
end
145

146
147
148
149
150
151
152
153
154
155
156
157
158
let make {db} =
  let module C = struct let db = db end in
  (module Make (C) : AUTH_SERVICE)

type c = config

module A : AUTH_SYSTEM = struct
  type config = c
  let name = name
  let parse_config = parse_config
  let make = make
end

159
let () = Web_auth.register_auth_system (module A : AUTH_SYSTEM)