web_election.ml 8.86 KB
Newer Older
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2016 Inria                                           *)
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
(*                                                                        *)
(*  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
Stephane Glondu's avatar
Stephane Glondu committed
24
open Serializable_builtin_t
25 26 27
open Serializable_j
open Signatures
open Common
28
open Web_serializable_j
29
open Web_signatures
30 31
open Web_common

32 33
let ( / ) = Filename.concat

34
module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
35

36
    let uuid = E.election.e_params.e_uuid
37

38
    module G = E.G
39

40 41 42 43
      let uuid_u = underscorize uuid
      let ballots_table = Ocsipersist.open_table ("ballots_" ^ uuid_u)
      let records_table = Ocsipersist.open_table ("records_" ^ uuid_u)
      let cred_table = Ocsipersist.open_table ("creds_" ^ uuid_u)
44 45

      let inject_cred cred =
46 47
        try%lwt
          let%lwt _ = Ocsipersist.find cred_table cred in
48 49 50 51
          failwith "trying to add duplicate credential"
        with Not_found ->
          Ocsipersist.add cred_table cred None

52
      let send_confirmation_email user email hash =
53
        let title = E.election.e_params.e_name in
54 55 56
        let uuid = E.election.e_params.e_uuid in
        let%lwt metadata = Web_persist.get_election_metadata uuid in
        let x = (uuid, ()) in
57 58 59 60 61 62
        let url1 = Eliom_uri.make_string_uri ~absolute:true
          ~service:Web_services.election_pretty_ballots x |> rewrite_prefix
        in
        let url2 = Eliom_uri.make_string_uri ~absolute:true
          ~service:Web_services.election_home x |> rewrite_prefix
        in
63
        let%lwt language = Eliom_reference.get Web_state.language in
Stephane Glondu's avatar
Stephane Glondu committed
64
        let module L = (val Web_i18n.get_lang language) in
Stephane Glondu's avatar
Stephane Glondu committed
65
        let subject = Printf.sprintf L.mail_confirmation_subject title in
66 67
        let contact = Web_templates.contact_footer metadata L.please_contact in
        let body = Printf.sprintf L.mail_confirmation user title hash url1 url2 contact in
68
        send_email email subject body
69

70
      let do_cast rawballot (user, date) =
71
        let%lwt voters = read_file ~uuid "voters.txt" in
72
        let%lwt email, login =
73 74 75 76 77
          let rec loop = function
            | x :: xs ->
               let email, login = split_identity x in
               if login = user.user_name then return (email, login) else loop xs
            | [] -> fail UnauthorizedVoter
78
          in loop (match voters with Some xs -> xs | None -> [])
79
        in
80
        let user = string_of_user user in
81
        let%lwt state = Web_persist.get_election_state uuid in
82
        let voting_open = state = `Open in
83 84 85 86
        if not voting_open then fail ElectionClosed else return () >>
        if String.contains rawballot '\n' then (
          fail (Serialization (Invalid_argument "multiline ballot"))
        ) else return () >>
87
        let%lwt ballot =
88 89 90
          try Lwt.return (ballot_of_string G.read rawballot)
          with e -> fail (Serialization e)
        in
91
        let%lwt credential =
92 93 94 95
          match ballot.signature with
            | Some s -> Lwt.return (G.to_string s.s_public_key)
            | None -> fail MissingCredential
        in
96 97
        let%lwt old_cred =
          try%lwt Ocsipersist.find cred_table credential
98 99
          with Not_found -> fail InvalidCredential
        and old_record =
100 101
          try%lwt
            let%lwt x = Ocsipersist.find records_table user in
102 103 104 105 106 107
            Lwt.return (Some x)
          with Not_found -> Lwt.return None
        in
        match old_cred, old_record with
          | None, None ->
            (* first vote *)
108
            if E.check_ballot ballot then (
109 110
              let hash = sha256_b64 rawballot in
              Ocsipersist.add cred_table credential (Some hash) >>
111 112
              Ocsipersist.add ballots_table hash rawballot >>
              Ocsipersist.add records_table user (date, credential) >>
113
              send_confirmation_email login email hash >>
Stephane Glondu's avatar
Stephane Glondu committed
114
              return hash
115 116 117 118 119 120
            ) else (
              fail ProofCheck
            )
          | Some h, Some (_, old_credential) ->
            (* revote *)
            if credential = old_credential then (
121
              if E.check_ballot ballot then (
122
                Ocsipersist.remove ballots_table h >>
123 124
                let hash = sha256_b64 rawballot in
                Ocsipersist.add cred_table credential (Some hash) >>
125 126
                Ocsipersist.add ballots_table hash rawballot >>
                Ocsipersist.add records_table user (date, credential) >>
127
                send_confirmation_email login email hash >>
Stephane Glondu's avatar
Stephane Glondu committed
128
                return hash
129 130 131
              ) else (
                fail ProofCheck
              )
132
            ) else (
Stephane Glondu's avatar
Stephane Glondu committed
133
              security_log (fun () ->
134 135 136 137 138 139 140 141 142 143 144 145 146
                Printf.sprintf "%s attempted to revote with already used credential %s" user credential
              ) >> fail WrongCredential
            )
          | None, Some _ ->
            security_log (fun () ->
              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_ =
147
        match%lwt Ocsipersist.fold_step (fun k v x ->
148 149 150 151 152 153 154 155 156 157 158 159
          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 do_write f =
Stephane Glondu's avatar
Stephane Glondu committed
160
        Lwt_io.(with_file ~mode:Output (!spool_dir / raw_string_of_uuid uuid / string_of_election_file f))
161 162 163 164 165

      let do_write_ballots () =
        do_write ESBallots (fun oc ->
          Ocsipersist.iter_step (fun _ x ->
            Lwt_io.write_line oc x
166
          ) ballots_table
167 168 169 170 171 172 173 174 175 176 177 178 179 180
        )

      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
181
          ) records_table
182 183 184 185 186 187
        )

      let mutex = Lwt_mutex.create ()

      let cast rawballot (user, date) =
        Lwt_mutex.with_lock mutex (fun () ->
188
          let%lwt r = do_cast rawballot (user, date) in
189 190 191 192 193 194 195
          do_write_ballots () >>
          do_write_records () >>
          return r
        )

      let update_cred ~old ~new_ =
        Lwt_mutex.with_lock mutex (fun () ->
196
          let%lwt r = do_update_cred ~old ~new_ in
197 198 199 200 201 202 203 204 205
          do_write_creds () >> return r
        )

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

207
      let compute_encrypted_tally () =
208
        let%lwt num_tallied, tally =
209 210 211 212 213
          Ocsipersist.fold_step
            (fun _ rawballot (n, accu) ->
              let ballot = ballot_of_string G.read rawballot in
              let ciphertext = E.extract_ciphertext ballot in
              return (n + 1, E.combine_ciphertexts accu ciphertext))
214
            ballots_table (0, E.neutral_ciphertext ())
215 216 217 218 219 220 221
        in
        let tally = string_of_encrypted_tally G.write tally in
        Lwt_mutex.with_lock mutex (fun () ->
          do_write ESETally (fun oc ->
            Lwt_io.write oc tally
          )
        ) >>
222
        return (num_tallied, sha256_b64 tally, tally)
223

224
end