web_election.ml 17.7 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
(**************************************************************************)
(*                                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/>.                                       *)
(**************************************************************************)

open Signatures
23
open Web_signatures
24
25
26
27
open Lwt
open Util
open Serializable_builtin_t
open Serializable_t
Stephane Glondu's avatar
Stephane Glondu committed
28
open Web_serializable_t
29
30
open Web_common

31
32
33
34
35
36
let can_read m user =
  match m.e_readers with
  | None -> false
  | Some acls ->
    match user with
    | None -> List.mem `Any acls (* readers can be anonymous *)
37
    | Some u -> check_acl (Some acls) u
38
39
40
41
42
43
44

let can_vote m user =
  match m.e_voters with
  | None -> false
  | Some acls ->
    match user with
    | None -> false (* voters must log in *)
45
    | Some u -> check_acl (Some acls) u
46

Stephane Glondu's avatar
Stephane Glondu committed
47
48
49
50
51
module type REGISTRATION = sig
  module W : WEB_ELECTION
  module Register (S : SITE_SERVICES) (T : ELECTION_TEMPLATES) : EMPTY
end

52
let make {raw_election; metadata; featured; params_fname; public_keys_fname} =
53
54
55
56
57
58
59
60
61

  let e_fingerprint = sha256_b64 raw_election in
  let wrapped_params = Serializable_j.params_of_string
    Serializable_j.read_ff_pubkey raw_election
  in
  let {ffpk_g = g; ffpk_p = p; ffpk_q = q; ffpk_y = y} = wrapped_params.e_public_key in
  let group = {g; p; q} in
  let e_params = { wrapped_params with e_public_key = y } in

Stephane Glondu's avatar
Stephane Glondu committed
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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
  let module R : REGISTRATION = struct

    module W : WEB_ELECTION = struct
      module G = (val Election.finite_field group : Election.FF_GROUP)
      module M = MakeLwtRandom(struct let rng = make_rng () end)
      module E = Election.MakeElection(G)(M)

      let election = {e_params; e_pks = None; e_fingerprint}
      let metadata = metadata

      let public_keys_fname = public_keys_fname
      let params_fname = params_fname
      let featured = featured

      module B : WEB_BALLOT_BOX = struct

        let suffix = "_" ^ String.map (function
          | '-' -> '_'
          | c -> c
        ) (Uuidm.to_string e_params.e_uuid)

        module Ballots = struct
          type 'a m = 'a Lwt.t
          type elt = string
          type key = string
          let table = Ocsipersist.open_table ("ballots" ^ suffix)
          let cardinal = Ocsipersist.length table
          let fold f x = Ocsipersist.fold_step f table x
        end

        module Records = struct
          type 'a m = 'a Lwt.t
          type elt = Serializable_builtin_t.datetime * string
          type key = string
          let table = Ocsipersist.open_table ("records" ^ suffix)
          let cardinal = Ocsipersist.length table
          let fold f x = Ocsipersist.fold_step f table x
        end

        let cred_table = Ocsipersist.open_table ("creds" ^ suffix)

        let extract_creds () =
          Ocsipersist.fold_step (fun k v x ->
            return (SSet.add k x)
          ) cred_table SSet.empty

        let inject_creds creds =
          lwt existing_creds = extract_creds () in
          if SSet.is_empty existing_creds then (
            Ocsigen_messages.debug (fun () ->
              Printf.sprintf
                "Injecting credentials for %s"
                (Uuidm.to_string e_params.e_uuid)
            );
            SSet.fold (fun x unit ->
              unit >> Ocsipersist.add cred_table x None
            ) creds (return ())
119
          ) else (
Stephane Glondu's avatar
Stephane Glondu committed
120
121
122
123
124
125
            if SSet.(is_empty (diff creds existing_creds)) then (
              Lwt.return ()
            ) else (
              Ocsigen_messages.warning "public_creds.txt does not match db!";
              Lwt.return ()
            )
126
127
          )

Stephane Glondu's avatar
Stephane Glondu committed
128
129
130
131
132
133
134
135
136
137
        let do_cast rawballot (user, date) =
          let voting_open =
            let compare a b =
              let open CalendarLib.Fcalendar.Precise in
              match a, b with
              | Some a, Some b -> compare (fst a) (fst b)
              | _, _ -> -1
            in
            compare metadata.e_voting_starts_at (Some date) <= 0 &&
            compare (Some date) metadata.e_voting_ends_at < 0
Stephane Glondu's avatar
Stephane Glondu committed
138
          in
Stephane Glondu's avatar
Stephane Glondu committed
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
          if not voting_open then fail ElectionClosed else return () >>
          if String.contains rawballot '\n' then (
            fail (Serialization (Invalid_argument "multiline ballot"))
          ) else return () >>
          lwt ballot =
            try Lwt.return (
              Serializable_j.ballot_of_string
                Serializable_builtin_j.read_number rawballot
            ) with e -> fail (Serialization e)
          in
          lwt credential =
            match ballot.signature with
              | Some s -> Lwt.return (Z.to_string s.s_public_key)
              | None -> fail MissingCredential
          in
          lwt old_cred =
            try_lwt Ocsipersist.find cred_table credential
            with Not_found -> fail InvalidCredential
          and old_record =
            try_lwt
              lwt x = Ocsipersist.find Records.table user in
              Lwt.return (Some x)
            with Not_found -> Lwt.return None
          in
          match old_cred, old_record with
            | None, None ->
              (* first vote *)
166
167
168
169
170
171
172
173
174
175
176
              if E.check_ballot election ballot then (
                let hash = sha256_b64 rawballot in
                Ocsipersist.add cred_table credential (Some hash) >>
                Ocsipersist.add Ballots.table hash rawballot >>
                Ocsipersist.add Records.table user (date, credential) >>
                security_log (fun () ->
                  Printf.sprintf "%s successfully cast ballot %s" user hash
                ) >> return hash
              ) else (
                fail ProofCheck
              )
Stephane Glondu's avatar
Stephane Glondu committed
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
            | Some h, Some (_, old_credential) ->
              (* revote *)
              if credential = old_credential then (
                if E.check_ballot election ballot then (
                  lwt old_ballot = Ocsipersist.find Ballots.table h in
                  Ocsipersist.remove Ballots.table h >>
                  security_log (fun () ->
                    Printf.sprintf "%s successfully removed ballot %S" user old_ballot
                  ) >>
                  let hash = sha256_b64 rawballot in
                  Ocsipersist.add cred_table credential (Some hash) >>
                  Ocsipersist.add Ballots.table hash rawballot >>
                  Ocsipersist.add Records.table user (date, credential) >>
                  security_log (fun () ->
                    Printf.sprintf "%s successfully cast ballot %s" user hash
                  ) >> return hash
                ) else (
                  fail ProofCheck
                )
              ) else (
                security_log (fun () ->
                  Printf.sprintf "%s attempted to revote with already used credential %s" user credential
                ) >> fail WrongCredential
              )
            | None, Some _ ->
202
              security_log (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
                Printf.sprintf "%s attempted to revote using a new credential %s" user credential
              ) >> fail RevoteNotAllowed
            | Some _, None ->
              security_log (fun () ->
                Printf.sprintf "%s attempted to vote with already used credential %s" user credential
              ) >> fail ReusedCredential

        let do_update_cred ~old ~new_ =
          match_lwt Ocsipersist.fold_step (fun k v x ->
            if sha256_hex k = old then (
              match v with
                | Some _ -> fail UsedCredential
                | None -> return (Some k)
            ) else return x
          ) cred_table None with
          | None -> fail CredentialNotFound
          | Some x ->
            Ocsipersist.remove cred_table x >>
            Ocsipersist.add cred_table new_ None

        let mutex = Lwt_mutex.create ()

        let cast rawballot (user, date) =
          Lwt_mutex.with_lock mutex (fun () -> do_cast rawballot (user, date))

        let update_cred ~old ~new_ =
          Lwt_mutex.with_lock mutex (fun () -> do_update_cred ~old ~new_)
230

Stephane Glondu's avatar
Stephane Glondu committed
231
      end
232

Stephane Glondu's avatar
Stephane Glondu committed
233
234
235
236
237
238
239
240
241
242
243
244
      open Eliom_service
      open Eliom_parameter

      module S : ELECTION_SERVICES = struct

        let base_path = ["elections"; Uuidm.to_string election.e_params.e_uuid]
        let make_path x = base_path @ x
        let root = make_path [""]

        let home = service
          ~path:root
          ~get_params:unit
245
246
          ()

Stephane Glondu's avatar
Stephane Glondu committed
247
248
249
250
251
        let election_dir = service
          ~path:root
          ~priority:(-1)
          ~get_params:(suffix (election_file "file"))
          ()
252

Stephane Glondu's avatar
Stephane Glondu committed
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
        let election_booth = static_dir_with_params
          ~get_params:(string "election_url")
          ()

        let booth_path = ["booth"; "vote.html"]

        let root_rel_to_booth = root
          |> Eliom_uri.reconstruct_relative_url_path booth_path
          |> String.concat "/"

        let booth =
          preapply election_booth (booth_path, root_rel_to_booth)

        let election_update_credential = service
          ~path:(make_path ["update-cred"])
          ~get_params:unit
          ()

        let election_update_credential_post = post_service
          ~fallback:election_update_credential
          ~post_params:(string "old_credential" ** string "new_credential")
          ()

        let election_vote = service
          ~path:(make_path ["vote"])
          ~get_params:unit
          ()

        let election_cast = service
          ~path:(make_path ["cast"])
          ~get_params:unit
          ()

        let election_cast_post = post_service
          ~fallback:election_cast
          ~post_params:(opt (string "encrypted_vote") ** opt (file "encrypted_vote_file"))
          ()

      end
292
293
294
295
296
297

    end

    module Register (S : SITE_SERVICES) (T : ELECTION_TEMPLATES) : EMPTY = struct
      open Eliom_registration

Stephane Glondu's avatar
Stephane Glondu committed
298
299
300
301
      let ballot = Eliom_reference.eref
        ~scope:Eliom_common.default_session_scope
        (None : string option)

Stephane Glondu's avatar
Stephane Glondu committed
302
303
      let if_eligible acl f () x =
        lwt user = S.get_user () in
Stephane Glondu's avatar
Stephane Glondu committed
304
305
306
307
308
309
        if acl metadata user then
          f user x
        else
          forbidden ()

      let () = Html5.register ~service:W.S.home
Stephane Glondu's avatar
Stephane Glondu committed
310
        (if_eligible can_read
311
312
313
314
315
316
           (fun user () ->
             let module X = struct let s = W.S.home end in
             let x = (module X : SAVED_SERVICE) in
             Eliom_reference.set S.saved_service x >>
             T.home ~user ()
           )
317
318
319
320
321
322
323
324
325
        )

      let f_raw user () =
        return params_fname

      let f_keys user () =
        return public_keys_fname

      let f_creds user () =
Stephane Glondu's avatar
Stephane Glondu committed
326
        lwt creds = W.B.extract_creds () in
327
328
329
330
331
332
333
        let s = SSet.fold (fun x accu ->
          (fun () -> return (Ocsigen_stream.of_string (x^"\n"))) :: accu
        ) creds [] in
        return (List.rev s, "text/plain")

      let f_ballots user () =
        (* TODO: streaming *)
Stephane Glondu's avatar
Stephane Glondu committed
334
        lwt ballots = W.B.Ballots.fold (fun _ x xs ->
335
336
337
338
339
340
341
342
343
344
          return ((x^"\n")::xs)
        ) [] in
        let s = List.map (fun b () ->
          return (Ocsigen_stream.of_string b)
        ) ballots in
        return (s, "application/json")

      let f_records user () =
        match user with
        | Some u ->
345
          if metadata.e_owner = Some u then (
346
            (* TODO: streaming *)
Stephane Glondu's avatar
Stephane Glondu committed
347
            lwt ballots = W.B.Records.fold (fun u (d, _) xs ->
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
              let x = Printf.sprintf "%s %S\n"
                (Serializable_builtin_j.string_of_datetime d) u
              in return (x::xs)
            ) [] in
            let s = List.map (fun b () ->
              return (Ocsigen_stream.of_string b)
            ) ballots in
            return (s, "text/plain")
          ) else (
            forbidden ()
          )
        | _ -> forbidden ()

      let handle_pseudo_file u f =
        let open Eliom_registration in
        let file f =
Stephane Glondu's avatar
Stephane Glondu committed
364
          if_eligible can_read f u () >>=
365
366
          File.send ~content_type:"application/json"
        and stream f =
Stephane Glondu's avatar
Stephane Glondu committed
367
          if_eligible can_read f u () >>=
368
369
370
371
372
373
374
375
376
377
378
          Streamlist.send >>=
          (fun x -> return (cast_unknown_content_kind x))
        in
        match f with
        | ESRaw -> file f_raw
        | ESKeys -> file f_keys
        | ESCreds -> stream f_creds
        | ESBallots -> stream f_ballots
        | ESRecords -> stream f_records

      let () = Any.register
Stephane Glondu's avatar
Stephane Glondu committed
379
        ~service:W.S.election_dir
380
        (fun f () ->
Stephane Glondu's avatar
Stephane Glondu committed
381
382
383
          let module X = struct
            let s = Eliom_service.preapply W.S.election_dir f
          end in
384
385
386
387
388
389
          let x = (module X : SAVED_SERVICE) in
          Eliom_reference.set S.saved_service x >>
          handle_pseudo_file () f
        )

      let () = Html5.register
Stephane Glondu's avatar
Stephane Glondu committed
390
        ~service:W.S.election_update_credential
391
        (fun uuid () ->
392
          lwt user = S.get_user () in
393
394
          match user with
          | Some u ->
395
            if metadata.e_owner = Some u then (
396
397
398
399
400
401
402
403
              T.update_credential ()
            ) else (
              forbidden ()
            )
          | _ -> forbidden ()
        )

      let () = String.register
Stephane Glondu's avatar
Stephane Glondu committed
404
        ~service:W.S.election_update_credential_post
405
        (fun uuid (old, new_) ->
406
          lwt user = S.get_user () in
407
408
          match user with
          | Some u ->
409
            if metadata.e_owner = Some u then (
410
              try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
411
                W.B.update_cred ~old ~new_ >>
412
413
414
415
416
417
418
419
420
421
                return ("OK", "text/plain")
              with Error e ->
                return ("Error: " ^ explain_error e, "text/plain")
            ) else (
              forbidden ()
            )
          | _ -> forbidden ()
        )

      let () = Redirection.register
Stephane Glondu's avatar
Stephane Glondu committed
422
        ~service:W.S.election_vote
Stephane Glondu's avatar
Stephane Glondu committed
423
        (if_eligible can_read
424
425
           (fun user () ->
             Eliom_reference.unset ballot >>
Stephane Glondu's avatar
Stephane Glondu committed
426
             let module X = struct let s = W.S.election_vote end in
427
428
             let x = (module X : SAVED_SERVICE) in
             Eliom_reference.set S.saved_service x >>
Stephane Glondu's avatar
Stephane Glondu committed
429
             return W.S.booth
430
431
432
433
434
435
436
437
           )
        )

      let do_cast uuid () =
        match_lwt Eliom_reference.get ballot with
        | Some the_ballot ->
          begin
            Eliom_reference.unset ballot >>
438
            match_lwt S.get_user () with
439
            | Some u ->
440
              let b = check_acl metadata.e_voters u in
441
442
              if b then (
                let record =
443
                  Auth_common.string_of_user u,
444
445
446
447
                  (CalendarLib.Fcalendar.Precise.now (), None)
                in
                lwt result =
                  try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
448
                    lwt hash = W.B.cast the_ballot record in
449
450
451
452
453
454
455
456
457
458
459
460
                    return (`Valid hash)
                  with Error e -> return (`Error e)
                in
                Eliom_reference.unset ballot >>
                T.cast_confirmed ~result ()
              ) else forbidden ()
            | None -> forbidden ()
          end
        | None -> fail_http 404

      let ballot_received uuid user =
        let confirm () =
Stephane Glondu's avatar
Stephane Glondu committed
461
462
463
464
465
466
467
          let service = Eliom_service.post_coservice
            ~csrf_safe:true
            ~csrf_scope:Eliom_common.default_session_scope
            ~fallback:W.S.election_cast
            ~post_params:Eliom_parameter.unit
            ()
          in
468
469
470
471
472
473
474
475
476
477
          let () = Html5.register
            ~service
            ~scope:Eliom_common.default_session_scope
            do_cast
          in service
        in
        let can_vote = can_vote metadata user in
        T.cast_confirmation ~confirm ~user ~can_vote ()

      let () = Html5.register
Stephane Glondu's avatar
Stephane Glondu committed
478
        ~service:W.S.election_cast
Stephane Glondu's avatar
Stephane Glondu committed
479
        (if_eligible can_read
480
           (fun user () ->
Stephane Glondu's avatar
Stephane Glondu committed
481
482
             let uuid = W.election.e_params.e_uuid in
             let module X = struct let s = W.S.election_cast end in
483
484
485
486
487
488
489
490
491
             let x = (module X : SAVED_SERVICE) in
             Eliom_reference.set S.saved_service x >>
             match_lwt Eliom_reference.get ballot with
             | Some _ -> ballot_received uuid user
             | None -> T.cast_raw ()
           )
        )

      let () = Redirection.register
Stephane Glondu's avatar
Stephane Glondu committed
492
        ~service:W.S.election_cast_post
Stephane Glondu's avatar
Stephane Glondu committed
493
        (if_eligible can_read
494
495
496
497
498
499
500
501
502
           (fun user (ballot_raw, ballot_file) ->
             lwt the_ballot = match ballot_raw, ballot_file with
               | Some ballot, None -> return ballot
               | None, Some fi ->
                 let fname = fi.Ocsigen_extensions.tmp_filename in
                 Lwt_stream.to_string (Lwt_io.chars_of_file fname)
               | _, _ -> fail_http 400
             in
             let module X : SAVED_SERVICE = struct
Stephane Glondu's avatar
Stephane Glondu committed
503
504
               let uuid = W.election.e_params.e_uuid
               let s = W.S.election_cast
505
506
507
508
509
             end in
             let x = (module X : SAVED_SERVICE) in
             Eliom_reference.set S.saved_service x >>
             Eliom_reference.set ballot (Some the_ballot) >>
             match user with
Stephane Glondu's avatar
Stephane Glondu committed
510
             | None -> return (Eliom_service.preapply S.login None)
511
512
513
514
515
516
             | Some u -> S.cont ()
           )
        )

    end

517
  end in
518

Stephane Glondu's avatar
Stephane Glondu committed
519
  (module R : REGISTRATION)