web_election.ml 17.6 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 Lwt
23
open Platform
24
open Serializable_builtin_t
25
26
27
open Serializable_j
open Signatures
open Common
Stephane Glondu's avatar
Stephane Glondu committed
28
open Web_serializable_t
29
open Web_signatures
30
31
open Web_common

32
33
let ( / ) = Filename.concat

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

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

Stephane Glondu's avatar
Stephane Glondu committed
50
51
module type REGISTRATION = sig
  module W : WEB_ELECTION
52
  module Register (S : SITE) (T : TEMPLATES) : EMPTY
Stephane Glondu's avatar
Stephane Glondu committed
53
54
end

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
module type REGISTRABLE = sig
  module W : sig
    include ELECTION_DATA
    include WEB_PARAMS
    module E : ELECTION with type elt = G.t
  end
  module Register (X : EMPTY) : REGISTRATION
end

module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct

  module W = struct
    include D
    include P
    module M = MakeLwtRandom(struct let rng = make_rng () end)
    module E = Election.MakeElection(G)(M)
  end

  module Register (X : EMPTY) : REGISTRATION = struct
74

75
    let uuid = Uuidm.to_string D.election.e_params.e_uuid
76
77
78
79
80
    let base_path = ["elections"; uuid]

    module N = struct
      let name = uuid
      let path = base_path
81
      let kind = `Election P.dir
Stephane Glondu's avatar
Stephane Glondu committed
82
83

      let auth_config =
84
        match P.metadata.e_auth_config with
Stephane Glondu's avatar
Stephane Glondu committed
85
86
        | None -> []
        | Some xs -> xs
87
88
89
90
    end

    module Auth = Web_auth.Make (N)

91
92
93
    module W = struct
      include W

94
      module H = Auth.Handlers
Stephane Glondu's avatar
Stephane Glondu committed
95
96
97
98
99
100

      module B : WEB_BALLOT_BOX = struct

        let suffix = "_" ^ String.map (function
          | '-' -> '_'
          | c -> c
Stephane Glondu's avatar
Stephane Glondu committed
101
        ) uuid
Stephane Glondu's avatar
Stephane Glondu committed
102
103
104
105
106
107
108
109
110
111
112
113

        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
114
          type elt = datetime * string
Stephane Glondu's avatar
Stephane Glondu committed
115
116
117
118
119
120
121
122
          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)

123
124
        let inject_cred cred =
          try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
125
            lwt _ = Ocsipersist.find cred_table cred in
126
127
128
            failwith "trying to add duplicate credential"
          with Not_found ->
            Ocsipersist.add cred_table cred None
129

Stephane Glondu's avatar
Stephane Glondu committed
130
131
132
133
        let do_cast rawballot (user, date) =
          let voting_open =
            let compare a b =
              match a, b with
134
              | Some a, Some b -> datetime_compare a b
Stephane Glondu's avatar
Stephane Glondu committed
135
136
137
138
              | _, _ -> -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
139
          in
Stephane Glondu's avatar
Stephane Glondu committed
140
141
142
143
144
          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 =
145
            try Lwt.return (ballot_of_string G.read rawballot)
146
            with e -> fail (Serialization e)
Stephane Glondu's avatar
Stephane Glondu committed
147
148
149
          in
          lwt credential =
            match ballot.signature with
150
              | Some s -> Lwt.return (G.to_string s.s_public_key)
Stephane Glondu's avatar
Stephane Glondu committed
151
152
153
154
155
156
157
158
159
160
161
162
163
164
              | 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 *)
165
166
167
168
169
170
171
172
173
174
175
              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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
            | 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 _ ->
201
              security_log (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
                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

222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
        let do_write f =
          Lwt_io.(with_file ~mode:Output (dir / string_of_election_file f))

        let do_write_ballots () =
          do_write ESBallots (fun oc ->
            Ocsipersist.iter_step (fun _ x ->
              Lwt_io.write_line oc x
            ) Ballots.table
          )

        let do_write_creds () =
          do_write ESCreds (fun oc ->
            Ocsipersist.iter_step (fun x _ ->
              Lwt_io.write_line oc x
            ) cred_table
          )

        let do_write_records () =
          do_write ESRecords (fun oc ->
            Ocsipersist.iter_step (fun u (d, _) ->
              Printf.sprintf "%s %S\n" (string_of_datetime d) u |>
              Lwt_io.write oc
            ) Records.table
          )

Stephane Glondu's avatar
Stephane Glondu committed
247
248
249
        let mutex = Lwt_mutex.create ()

        let cast rawballot (user, date) =
250
251
252
253
254
255
          Lwt_mutex.with_lock mutex (fun () ->
            lwt r = do_cast rawballot (user, date) in
            do_write_ballots () >>
            do_write_records () >>
            return r
          )
Stephane Glondu's avatar
Stephane Glondu committed
256
257

        let update_cred ~old ~new_ =
258
259
260
261
262
263
264
265
266
267
268
          Lwt_mutex.with_lock mutex (fun () ->
            lwt r = do_update_cred ~old ~new_ in
            do_write_creds () >> return r
          )

        let update_files () =
          Lwt_mutex.with_lock mutex (fun () ->
            do_write_ballots () >>
            do_write_records () >>
            do_write_creds ()
          )
269

Stephane Glondu's avatar
Stephane Glondu committed
270
      end
271

Stephane Glondu's avatar
Stephane Glondu committed
272
273
274
275
      open Eliom_service
      open Eliom_parameter

      module S : ELECTION_SERVICES = struct
276
        include Auth.Services
Stephane Glondu's avatar
Stephane Glondu committed
277
278
279
280
281
282
283

        let make_path x = base_path @ x
        let root = make_path [""]

        let home = service
          ~path:root
          ~get_params:unit
284
285
          ()

286
287
288
289
290
        let admin = service
          ~path:(make_path ["admin"])
          ~get_params:unit
          ()

Stephane Glondu's avatar
Stephane Glondu committed
291
292
293
294
295
        let election_dir = service
          ~path:root
          ~priority:(-1)
          ~get_params:(suffix (election_file "file"))
          ()
296

Stephane Glondu's avatar
Stephane Glondu committed
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
        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
336
337
338

    end

339
    module Register (S : SITE) (T : TEMPLATES) : EMPTY = struct
340
341
      open Eliom_registration

342
      let () = let module X : EMPTY = Auth.Register (S) (T.Login (W.S)) in ()
343
344
345

      module T = T.Election (W)

Stephane Glondu's avatar
Stephane Glondu committed
346
      let if_eligible acl f () x =
347
        lwt user = W.S.get_user () in
348
        if acl W.metadata user then
Stephane Glondu's avatar
Stephane Glondu committed
349
350
351
352
          f user x
        else
          forbidden ()

Stephane Glondu's avatar
Stephane Glondu committed
353
354
355
356
      let scope = Eliom_common.default_session_scope

      let ballot = Eliom_reference.eref ~scope None
      let cast_confirmed = Eliom_reference.eref ~scope None
Stephane Glondu's avatar
Stephane Glondu committed
357

Stephane Glondu's avatar
Stephane Glondu committed
358
      let () = Html5.register ~service:W.S.home
Stephane Glondu's avatar
Stephane Glondu committed
359
        (if_eligible can_read
360
           (fun user () ->
361
             Eliom_reference.unset ballot >>
Stephane Glondu's avatar
Stephane Glondu committed
362
363
             let cont () () = Redirection.send W.S.home in
             Eliom_reference.set S.cont cont >>
Stephane Glondu's avatar
Stephane Glondu committed
364
365
366
367
             match_lwt Eliom_reference.get cast_confirmed with
             | Some result ->
               Eliom_reference.unset cast_confirmed >>
               T.cast_confirmed ~result ()
368
             | None -> T.home ()
369
           )
370
371
        )

372
373
374
      let () = Html5.register ~service:W.S.admin
        (fun () () ->
          match_lwt S.get_user () with
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
          | Some u when W.metadata.e_owner = Some u ->
            let post_params = Eliom_parameter.(
              bool "featured"
            ) in
            let set_featured = Eliom_service.post_coservice
              ~csrf_safe:true
              ~csrf_scope:scope
              ~fallback:W.S.admin
              ~post_params
              ()
            in
            let () = Any.register ~scope ~service:set_featured
              (fun () featured ->
                lwt () = if featured then (
                  S.add_featured_election uuid
                ) else (
                  S.remove_featured_election uuid
                ) in Redirection.send W.S.admin
              )
            in
            T.admin ~set_featured ()
396
397
398
          | _ -> forbidden ()
        )

399
400
401
      let content_type_of_file = function
        | ESRaw | ESKeys | ESBallots -> "application/json"
        | ESCreds | ESRecords -> "text/plain"
402
403

      let handle_pseudo_file u f =
404
405
406
407
408
409
        lwt () =
          if f = ESRecords then (
            match_lwt S.get_user () with
            | Some u when W.metadata.e_owner <> Some u -> forbidden ()
            | _ -> return ()
          ) else return ()
410
        in
411
412
        let content_type = content_type_of_file f in
        File.send ~content_type (W.dir / string_of_election_file f)
413
414

      let () = Any.register
Stephane Glondu's avatar
Stephane Glondu committed
415
        ~service:W.S.election_dir
416
        (fun f () ->
Stephane Glondu's avatar
Stephane Glondu committed
417
418
419
420
421
          let cont () () =
            Eliom_service.preapply W.S.election_dir f |>
            Redirection.send
          in
          Eliom_reference.set S.cont cont >>
422
423
424
425
          handle_pseudo_file () f
        )

      let () = Html5.register
Stephane Glondu's avatar
Stephane Glondu committed
426
        ~service:W.S.election_update_credential
Stephane Glondu's avatar
Stephane Glondu committed
427
        (fun () () ->
428
          lwt user = S.get_user () in
429
430
          match user with
          | Some u ->
431
            if W.metadata.e_owner = Some u then (
432
433
434
435
436
437
438
439
              T.update_credential ()
            ) else (
              forbidden ()
            )
          | _ -> forbidden ()
        )

      let () = String.register
Stephane Glondu's avatar
Stephane Glondu committed
440
        ~service:W.S.election_update_credential_post
Stephane Glondu's avatar
Stephane Glondu committed
441
        (fun () (old, new_) ->
442
          lwt user = S.get_user () in
443
444
          match user with
          | Some u ->
445
            if W.metadata.e_owner = Some u then (
446
              try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
447
                W.B.update_cred ~old ~new_ >>
448
449
450
451
452
453
454
455
456
457
                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
458
        ~service:W.S.election_vote
Stephane Glondu's avatar
Stephane Glondu committed
459
        (if_eligible can_read
460
461
           (fun user () ->
             Eliom_reference.unset ballot >>
Stephane Glondu's avatar
Stephane Glondu committed
462
463
             let cont () () = Redirection.send W.S.election_vote in
             Eliom_reference.set S.cont cont >>
Stephane Glondu's avatar
Stephane Glondu committed
464
             return W.S.booth
465
466
467
           )
        )

Stephane Glondu's avatar
Stephane Glondu committed
468
      let do_cast () () =
469
470
471
472
        match_lwt Eliom_reference.get ballot with
        | Some the_ballot ->
          begin
            Eliom_reference.unset ballot >>
473
            match_lwt W.S.get_user () with
474
            | Some u ->
475
              let b = check_acl W.metadata.e_voters u in
476
              if b then (
477
                let record = Web_auth.string_of_user u, now () in
478
479
                lwt result =
                  try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
480
                    lwt hash = W.B.cast the_ballot record in
481
482
483
484
                    return (`Valid hash)
                  with Error e -> return (`Error e)
                in
                Eliom_reference.unset ballot >>
Stephane Glondu's avatar
Stephane Glondu committed
485
486
                Eliom_reference.set cast_confirmed (Some result) >>
                let cont () () = Redirection.send W.S.home in
487
                W.H.do_logout cont ()
488
489
490
491
492
              ) else forbidden ()
            | None -> forbidden ()
          end
        | None -> fail_http 404

Stephane Glondu's avatar
Stephane Glondu committed
493
      let ballot_received user =
494
        let confirm () =
Stephane Glondu's avatar
Stephane Glondu committed
495
496
          let service = Eliom_service.post_coservice
            ~csrf_safe:true
Stephane Glondu's avatar
Stephane Glondu committed
497
            ~csrf_scope:scope
Stephane Glondu's avatar
Stephane Glondu committed
498
499
500
501
            ~fallback:W.S.election_cast
            ~post_params:Eliom_parameter.unit
            ()
          in
Stephane Glondu's avatar
Stephane Glondu committed
502
503
          let () = Any.register ~service ~scope do_cast in
          service
504
        in
505
        let can_vote = can_vote W.metadata user in
506
        T.cast_confirmation ~confirm ~can_vote ()
507
508

      let () = Html5.register
Stephane Glondu's avatar
Stephane Glondu committed
509
        ~service:W.S.election_cast
Stephane Glondu's avatar
Stephane Glondu committed
510
        (if_eligible can_read
511
           (fun user () ->
Stephane Glondu's avatar
Stephane Glondu committed
512
513
             let cont () () = Redirection.send W.S.election_cast in
             Eliom_reference.set S.cont cont >>
514
             match_lwt Eliom_reference.get ballot with
Stephane Glondu's avatar
Stephane Glondu committed
515
             | Some _ -> ballot_received user
516
517
518
519
             | None -> T.cast_raw ()
           )
        )

Stephane Glondu's avatar
Stephane Glondu committed
520
      let () = Any.register
Stephane Glondu's avatar
Stephane Glondu committed
521
        ~service:W.S.election_cast_post
Stephane Glondu's avatar
Stephane Glondu committed
522
        (if_eligible can_read
523
524
525
526
527
528
529
530
           (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
Stephane Glondu's avatar
Stephane Glondu committed
531
532
             let cont () () = Redirection.send W.S.election_cast in
             Eliom_reference.set S.cont cont >>
533
534
             Eliom_reference.set ballot (Some the_ballot) >>
             match user with
535
             | None -> W.H.do_login cont ()
Stephane Glondu's avatar
Stephane Glondu committed
536
             | Some u -> cont () ()
537
538
539
540
541
           )
        )

    end

542
543
  end

544
end