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
open Web_common
31
open Web_services
32

33 34
let ( / ) = Filename.concat

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

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

Stephane Glondu's avatar
Stephane Glondu committed
51
module type REGISTRATION = sig
52
  module W : WEB_ELECTION_
53
  module Register (X : EMPTY) : ELECTION_HANDLERS
Stephane Glondu's avatar
Stephane Glondu committed
54 55
end

56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
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
75

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

    module N = struct
      let name = uuid
      let path = base_path
82
      let kind = `Election (D.election.e_params.e_uuid, P.dir)
Stephane Glondu's avatar
Stephane Glondu committed
83 84

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

    module Auth = Web_auth.Make (N)

92 93 94
    module W = struct
      include W

Stephane Glondu's avatar
Stephane Glondu committed
95 96 97 98 99
      module B : WEB_BALLOT_BOX = struct

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

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

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

Stephane Glondu's avatar
Stephane Glondu committed
129
        let do_cast rawballot (user, date) =
130
          lwt state = Web_persist.get_election_state uuid in
Stephane Glondu's avatar
Stephane Glondu committed
131 132 133
          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
              | _, _ -> -1
            in
137
            state = `Open &&
Stephane Glondu's avatar
Stephane Glondu committed
138 139
            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
140
          in
Stephane Glondu's avatar
Stephane Glondu committed
141 142 143 144 145
          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 =
146
            try Lwt.return (ballot_of_string G.read rawballot)
147
            with e -> fail (Serialization e)
Stephane Glondu's avatar
Stephane Glondu committed
148 149 150
          in
          lwt credential =
            match ballot.signature with
151
              | Some s -> Lwt.return (G.to_string s.s_public_key)
Stephane Glondu's avatar
Stephane Glondu committed
152 153 154 155 156 157 158 159 160 161 162 163 164 165
              | 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
                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

223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
        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
248 249 250
        let mutex = Lwt_mutex.create ()

        let cast rawballot (user, date) =
251 252 253 254 255 256
          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
257 258

        let update_cred ~old ~new_ =
259 260 261 262 263 264 265 266 267 268 269
          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 ()
          )
270

Stephane Glondu's avatar
Stephane Glondu committed
271
      end
272

Stephane Glondu's avatar
Stephane Glondu committed
273
      module S = Auth.Services
274 275 276

    end

277
    module Register (X : EMPTY) : ELECTION_HANDLERS = struct
278 279
      open Eliom_registration

280
      let () =
281
        Auth.configure N.auth_config
282 283

      let login service () =
284
        lwt cont = Eliom_reference.get Web_services.cont in
285
        Auth.Handlers.login service cont ()
286 287

      let logout () () =
288
        lwt cont = Eliom_reference.get Web_services.cont in
289
        Auth.Handlers.logout cont ()
290

291
      module T = Web_templates
292

Stephane Glondu's avatar
Stephane Glondu committed
293
      let if_eligible acl f () x =
294
        lwt user = W.S.get_user () in
295
        if acl W.metadata user then
Stephane Glondu's avatar
Stephane Glondu committed
296 297 298 299
          f user x
        else
          forbidden ()

Stephane Glondu's avatar
Stephane Glondu committed
300 301 302 303
      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
304

305
      let home =
Stephane Glondu's avatar
Stephane Glondu committed
306
        (if_eligible can_read
307
           (fun user () ->
308
             Eliom_reference.unset ballot >>
309 310 311
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
312
                    election_home (W.election.e_params.e_uuid, ()))
313
             in
314
             Eliom_reference.set Web_services.cont cont >>
Stephane Glondu's avatar
Stephane Glondu committed
315 316 317
             match_lwt Eliom_reference.get cast_confirmed with
             | Some result ->
               Eliom_reference.unset cast_confirmed >>
318
               T.cast_confirmed (module W) ~result () >>= Html5.send
319 320 321
             | None ->
               lwt state = Web_persist.get_election_state uuid in
               T.election_home (module W) state () >>= Html5.send
322
           )
323 324
        )

325
      let admin site_user is_featured =
326
        (fun () () ->
327
          match site_user with
328
          | Some u when W.metadata.e_owner = Some u ->
329
            lwt state = Web_persist.get_election_state uuid in
330
            T.election_admin (module W) ~is_featured state (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
331 332 333
          | _ -> forbidden ()
        )

334 335 336
      let content_type_of_file = function
        | ESRaw | ESKeys | ESBallots -> "application/json"
        | ESCreds | ESRecords -> "text/plain"
337

338
      let handle_pseudo_file u f site_user =
339 340
        lwt () =
          if f = ESRecords then (
341
            match site_user with
342 343
            | Some u when W.metadata.e_owner = Some u -> return ()
            | _ -> forbidden ()
344
          ) else return ()
345
        in
346 347
        let content_type = content_type_of_file f in
        File.send ~content_type (W.dir / string_of_election_file f)
348

349
      let election_dir site_user =
350
        (fun f () ->
Stephane Glondu's avatar
Stephane Glondu committed
351 352
          let cont () () =
            Redirection.send
353
              (Eliom_service.preapply
354
                 election_dir
355
                 (W.election.e_params.e_uuid, f))
Stephane Glondu's avatar
Stephane Glondu committed
356
          in
357
          Eliom_reference.set Web_services.cont cont >>
358
          handle_pseudo_file () f site_user
359 360
        )

361
      let election_update_credential site_user =
Stephane Glondu's avatar
Stephane Glondu committed
362
        (fun () () ->
363
          match site_user with
364
          | Some u ->
365
            if W.metadata.e_owner = Some u then (
366
              T.update_credential (module W) (module Web_site_auth : AUTH_SERVICES) () >>= Html5.send
367 368 369 370 371 372
            ) else (
              forbidden ()
            )
          | _ -> forbidden ()
        )

373
      let election_update_credential_post site_user =
Stephane Glondu's avatar
Stephane Glondu committed
374
        (fun () (old, new_) ->
375
          match site_user with
376
          | Some u ->
377
            if W.metadata.e_owner = Some u then (
378
              try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
379
                W.B.update_cred ~old ~new_ >>
380
                String.send ("OK", "text/plain")
381
              with Error e ->
382 383 384
                String.send ("Error: " ^ explain_error e, "text/plain")
            ) >>= (fun x -> return @@ cast_unknown_content_kind x)
            else (
385 386 387 388 389
              forbidden ()
            )
          | _ -> forbidden ()
        )

390
      let election_vote =
Stephane Glondu's avatar
Stephane Glondu committed
391
        (if_eligible can_read
392 393
           (fun user () ->
             Eliom_reference.unset ballot >>
394 395 396
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
397
                    election_vote (W.election.e_params.e_uuid, ()))
398
             in
399
             Eliom_reference.set Web_services.cont cont >>
400 401 402 403 404 405 406
             let uuid_s = Uuidm.to_string W.election.e_params.e_uuid in
             Redirection.send
               (Eliom_service.preapply
                  (Eliom_service.static_dir_with_params
                     ~get_params:(Eliom_parameter.string "election_url") ())
                  (["static"; "vote.html"],
                   "../elections/" ^ uuid_s ^ "/"))
407 408 409
           )
        )

410
      let election_cast_confirm () () =
411 412 413 414
        match_lwt Eliom_reference.get ballot with
        | Some the_ballot ->
          begin
            Eliom_reference.unset ballot >>
415
            match_lwt W.S.get_user () with
416
            | Some u ->
417
              let b = check_acl W.metadata.e_voters u in
418
              if b then (
419
                let record = string_of_user u, now () in
420 421
                lwt result =
                  try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
422
                    lwt hash = W.B.cast the_ballot record in
423 424 425 426
                    return (`Valid hash)
                  with Error e -> return (`Error e)
                in
                Eliom_reference.unset ballot >>
Stephane Glondu's avatar
Stephane Glondu committed
427
                Eliom_reference.set cast_confirmed (Some result) >>
428 429 430
                Redirection.send
                  (Eliom_service.preapply
                     election_home (W.election.e_params.e_uuid, ()))
431 432 433 434 435
              ) else forbidden ()
            | None -> forbidden ()
          end
        | None -> fail_http 404

436
      let ballot_received user hash =
437
        let can_vote = can_vote W.metadata user in
438
        T.cast_confirmation (module W) ~can_vote hash ()
439

440
      let election_cast =
Stephane Glondu's avatar
Stephane Glondu committed
441
        (if_eligible can_read
442
           (fun user () ->
443 444 445
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
446
                    election_cast (W.election.e_params.e_uuid, ()))
447
             in
448
             Eliom_reference.set Web_services.cont cont >>
449
             match_lwt Eliom_reference.get ballot with
450
             | Some b -> ballot_received user (sha256_b64 b) >>= Html5.send
451
             | None -> T.cast_raw (module W) () >>= Html5.send
452 453 454
           )
        )

455
      let election_cast_post =
Stephane Glondu's avatar
Stephane Glondu committed
456
        (if_eligible can_read
457 458 459 460 461 462 463 464
           (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
465 466 467
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
468
                    Web_services.election_cast (W.election.e_params.e_uuid, ()))
469
             in
470
             Eliom_reference.set Web_services.cont cont >>
471 472
             Eliom_reference.set ballot (Some the_ballot) >>
             match user with
473 474 475 476 477
             | None ->
                Redirection.send
                  (Eliom_service.preapply
                     Web_services.election_login
                     ((W.election.e_params.e_uuid, ()), None))
Stephane Glondu's avatar
Stephane Glondu committed
478
             | Some u -> cont () ()
479 480 481
           )
        )

482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
      let election_pretty_ballots start () =
        lwt user = W.S.get_user () in
        if can_read W.metadata user then (
          lwt res, _ =
            W.B.Ballots.fold
              (fun h _ (accu, i) ->
               if i >= start && i < start+50 then
                 return (h :: accu, i+1)
               else return (accu, i+1)
              ) ([], 1)
          in T.pretty_ballots (module W) res () >>= Html5.send
        ) else forbidden ()

      let election_pretty_ballot hash () =
        lwt user = W.S.get_user () in
        if can_read W.metadata user then (
          lwt ballot =
            W.B.Ballots.fold
              (fun h b accu ->
               if h = hash then return (Some b) else return accu
              ) None
          in
          match ballot with
          | None -> fail_http 404
          | Some b ->
             String.send (b, "application/json") >>=
             (fun x -> return @@ cast_unknown_content_kind x)
        ) else forbidden ()

511 512
    end

513 514
  end

515
end