web_election.ml 17.9 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
      module L = struct
281 282
        let login x = Eliom_service.preapply election_login ((W.election.e_params.e_uuid, ()), x)
        let logout = Eliom_service.preapply election_logout (W.election.e_params.e_uuid, ())
283 284
      end

285
      let () =
286
        Auth.register (module W.S : AUTH_SERVICES) (module L : AUTH_LINKS) N.auth_config
287 288

      let login service () =
289
        lwt cont = Eliom_reference.get Web_services.cont in
290 291 292
        Auth.Handlers.do_login service cont ()

      let logout () () =
293
        lwt cont = Eliom_reference.get Web_services.cont in
294
        Auth.Handlers.do_logout cont ()
295

296
      module T = Web_templates
297

Stephane Glondu's avatar
Stephane Glondu committed
298
      let if_eligible acl f () x =
299
        lwt user = W.S.get_user () in
300
        if acl W.metadata user then
Stephane Glondu's avatar
Stephane Glondu committed
301 302 303 304
          f user x
        else
          forbidden ()

Stephane Glondu's avatar
Stephane Glondu committed
305 306 307 308
      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
309

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

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

339 340 341
      let content_type_of_file = function
        | ESRaw | ESKeys | ESBallots -> "application/json"
        | ESCreds | ESRecords -> "text/plain"
342

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

354
      let election_dir site_user =
355
        (fun f () ->
Stephane Glondu's avatar
Stephane Glondu committed
356 357
          let cont () () =
            Redirection.send
358
              (Eliom_service.preapply
359
                 election_dir
360
                 (W.election.e_params.e_uuid, f))
Stephane Glondu's avatar
Stephane Glondu committed
361
          in
362
          Eliom_reference.set Web_services.cont cont >>
363
          handle_pseudo_file () f site_user
364 365
        )

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

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

395
      let election_vote =
Stephane Glondu's avatar
Stephane Glondu committed
396
        (if_eligible can_read
397 398
           (fun user () ->
             Eliom_reference.unset ballot >>
399 400 401
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
402
                    election_vote (W.election.e_params.e_uuid, ()))
403
             in
404
             Eliom_reference.set Web_services.cont cont >>
405 406 407 408 409 410 411
             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 ^ "/"))
412 413 414
           )
        )

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

441
      let ballot_received user hash =
442
        let can_vote = can_vote W.metadata user in
443
        T.cast_confirmation (module W) ~can_vote hash ()
444

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

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

516 517
    end

518 519
  end

520
end