web_common.ml 8.65 KB
Newer Older
1
open Lwt
Stephane Glondu's avatar
Stephane Glondu committed
2
open Util
3
open Serializable_builtin_t
4
open Serializable_t
5

Stephane Glondu's avatar
Stephane Glondu committed
6
type user_type = Dummy | CAS | Admin
7

8 9
type user = {
  user_name : string;
10
  user_type : user_type;
11 12
}

13 14 15 16
let string_of_user {user_name; user_type} =
  match user_type with
    | Dummy -> Printf.sprintf "dummy:%s" user_name
    | CAS -> user_name
Stephane Glondu's avatar
Stephane Glondu committed
17
    | Admin -> Printf.sprintf "admin:%s" user_name
18

19
let is_admin = function
Stephane Glondu's avatar
Stephane Glondu committed
20
  | Some { user_name = _; user_type = Admin } -> true
21 22
  | _ -> false

Stephane Glondu's avatar
Stephane Glondu committed
23 24 25 26
type acl =
  | Any
  | Restricted of (user -> bool Lwt.t)

27 28
module SSet = Set.Make(String)

29
type election_data = {
30
  fn_params : string;
31
  fingerprint : string;
32
  params : ff_pubkey params;
33
  fn_public_keys : string;
34
  public_creds : SSet.t;
Stephane Glondu's avatar
Stephane Glondu committed
35
  featured_p : bool;
Stephane Glondu's avatar
Stephane Glondu committed
36 37
  can_read : acl;
  can_vote : acl;
38 39 40 41 42 43 44 45 46
}

let enforce_single_element s =
  let open Lwt_stream in
  lwt t = next s in
  lwt b = is_empty s in
  (assert_lwt b) >>
  Lwt.return t

Stephane Glondu's avatar
Cleanup  
Stephane Glondu committed
47 48 49 50 51 52 53 54
let load_from_file read fname =
  let i = open_in fname in
  let buf = Lexing.from_channel i in
  let lex = Yojson.init_lexer ~fname () in
  let result = read lex buf in
  close_in i;
  result

55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
module MakeLwtRandom (G : Signatures.GROUP) = struct

  type 'a t = 'a Lwt.t
  let return = Lwt.return
  let bind = Lwt.bind
  let fail = Lwt.fail

  let prng = Lwt_preemptive.detach (fun () ->
    Cryptokit.Random.(pseudo_rng (string secure_rng 16))
  ) ()

  let random q =
    let size = Z.size q * Sys.word_size / 8 in
    lwt prng = prng in
    let r = Cryptokit.Random.string prng size in
    return Z.(of_bits r mod q)

end

74
type error =
75 76 77 78 79 80 81 82
  | Serialization of exn
  | ProofCheck
  | ElectionClosed
  | MissingCredential
  | InvalidCredential
  | RevoteNotAllowed
  | ReusedCredential
  | WrongCredential
Stephane Glondu's avatar
Stephane Glondu committed
83 84
  | UsedCredential
  | CredentialNotFound
85 86 87 88 89 90 91 92 93 94 95 96 97 98

exception Error of error

let fail e = Lwt.fail (Error e)

let explain_error = function
  | Serialization e ->
    Printf.sprintf "your ballot has a syntax error (%s)" (Printexc.to_string e)
  | ProofCheck -> "some proofs failed verification"
  | ElectionClosed -> "the election is closed"
  | MissingCredential -> "a credential is missing"
  | InvalidCredential -> "your credential is invalid"
  | RevoteNotAllowed -> "you are not allowed to revote"
  | ReusedCredential -> "your credential has already been used"
99
  | WrongCredential -> "you are not allowed to vote with this credential"
Stephane Glondu's avatar
Stephane Glondu committed
100 101
  | UsedCredential -> "the credential has already been used"
  | CredentialNotFound -> "the credential has not been found"
102 103 104 105 106

module type LWT_ELECTION = Signatures.ELECTION
  with type elt = Z.t
  and type 'a m = 'a Lwt.t

107 108 109 110
module type WEB_BBOX = sig
  include Signatures.BALLOT_BOX
  with type 'a m := 'a Lwt.t
  and type ballot = string
111
  and type record = string * datetime
112 113

  val inject_creds : SSet.t -> unit Lwt.t
114
  val extract_creds : unit -> SSet.t Lwt.t
Stephane Glondu's avatar
Stephane Glondu committed
115
  val update_cred : old:string -> new_:string -> unit Lwt.t
116 117
end

118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
let security_logfile = ref None

let open_security_log f =
  lwt () =
    match !security_logfile with
      | Some ic -> Lwt_io.close ic
      | None -> return ()
  in
  lwt ic = Lwt_io.(
    open_file ~flags:Unix.(
      [O_WRONLY; O_APPEND; O_CREAT]
    ) ~perm:0o600 ~mode:output f
  ) in
  security_logfile := Some ic;
  return ()

let security_log s =
  match !security_logfile with
    | None -> return ()
    | Some ic -> Lwt_io.atomic (fun ic ->
      Lwt_io.write ic (
        Serializable_builtin_j.string_of_datetime (
          CalendarLib.Fcalendar.Precise.now (),
          None
        )
      ) >>
      Lwt_io.write ic ": " >>
      Lwt_io.write_line ic (s ()) >>
      Lwt_io.flush ic
    ) ic

149 150 151
module MakeBallotBox (P : Signatures.ELECTION_PARAMS) (E : LWT_ELECTION) = struct

  (* TODO: enforce E is derived from P *)
152 153 154 155 156 157 158 159

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

  let ballot_table = Ocsipersist.open_table ("ballots" ^ suffix)
  let record_table = Ocsipersist.open_table ("records" ^ suffix)
160
  let cred_table = Ocsipersist.open_table ("creds" ^ suffix)
161 162 163 164

  type ballot = string
  type record = string * Serializable_builtin_t.datetime

165 166
  let extract_creds () =
    Ocsipersist.fold_step (fun k v x ->
167
      return (SSet.add k x)
168 169 170 171
    ) cred_table SSet.empty

  let inject_creds creds =
    lwt existing_creds = extract_creds () in
172 173 174 175 176 177 178 179 180 181 182
    if SSet.is_empty existing_creds then (
      Ocsigen_messages.debug (fun () ->
        "-- injecting credentials"
      );
      SSet.fold (fun x unit ->
        unit >> Ocsipersist.add cred_table x None
      ) creds (return ())
    ) else (
      if SSet.(is_empty (diff creds existing_creds)) then (
        Lwt.return ()
      ) else (
183 184
        Ocsigen_messages.warning "public_creds.txt does not match db!";
        Lwt.return ()
185 186 187
      )
    )

188
  let do_cast rawballot (user, date) =
189 190 191 192 193 194 195 196 197
    let voting_open = match P.metadata with
      | Some m ->
        let date = fst date in
        let open CalendarLib.Fcalendar.Precise in
        compare (fst m.e_voting_starts_at) date <= 0 &&
        compare date (fst m.e_voting_ends_at) < 0
      | None -> true
    in
    if not voting_open then fail ElectionClosed else return () >>
Stephane Glondu's avatar
Stephane Glondu committed
198 199 200
    if String.contains rawballot '\n' then (
      fail (Serialization (Invalid_argument "multiline ballot"))
    ) else return () >>
201 202 203 204
    lwt ballot =
      try Lwt.return (
        Serializable_j.ballot_of_string
          Serializable_builtin_j.read_number rawballot
205
      ) with e -> fail (Serialization e)
206
    in
207 208
    lwt credential =
      match ballot.signature with
Stephane Glondu's avatar
Stephane Glondu committed
209
        | Some s -> Lwt.return (Z.to_string s.s_public_key)
210 211
        | None -> fail MissingCredential
    in
212
    lwt old_cred =
213 214 215 216 217 218 219 220
      try_lwt Ocsipersist.find cred_table credential
      with Not_found -> fail InvalidCredential
    and old_record =
      try_lwt
        lwt x = Ocsipersist.find record_table user in
        Lwt.return (Some x)
      with Not_found -> Lwt.return None
    in
221
    match old_cred, old_record with
222 223 224 225 226 227
      | None, None ->
        (* first vote *)
        if E.check_ballot ballot then (
          let hash = sha256_b64 rawballot in
          Ocsipersist.add cred_table credential (Some hash) >>
          Ocsipersist.add ballot_table hash rawballot >>
228 229 230 231
          Ocsipersist.add record_table user (date, credential) >>
          security_log (fun () ->
            Printf.sprintf "%s successfully cast ballot %s" user hash
          )
232 233 234
        ) else (
          fail ProofCheck
        )
235
      | Some h, Some (_, old_credential) ->
236
        (* revote *)
237 238
        if credential = old_credential then (
          if E.check_ballot ballot then (
239
            lwt old_ballot = Ocsipersist.find ballot_table h in
240
            Ocsipersist.remove ballot_table h >>
241 242 243
            security_log (fun () ->
              Printf.sprintf "%s successfully removed ballot %S" user old_ballot
            ) >>
244 245 246
            let hash = sha256_b64 rawballot in
            Ocsipersist.add cred_table credential (Some hash) >>
            Ocsipersist.add ballot_table hash rawballot >>
247 248 249 250
            Ocsipersist.add record_table user (date, credential) >>
            security_log (fun () ->
              Printf.sprintf "%s successfully cast ballot %s" user hash
            )
251 252 253
          ) else (
            fail ProofCheck
          )
254 255 256 257 258 259 260 261 262 263 264 265 266
        ) else (
          security_log (fun () ->
            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
267 268 269 270 271

  let fold_ballots f x =
    Ocsipersist.fold_step (fun k v x -> f v x) ballot_table x

  let fold_records f x =
272
    Ocsipersist.fold_step (fun k v x -> f (k, fst v) x) record_table x
273 274

  let turnout = Ocsipersist.length ballot_table
Stephane Glondu's avatar
Stephane Glondu committed
275

276
  let do_update_cred ~old ~new_ =
Stephane Glondu's avatar
Stephane Glondu committed
277 278 279 280 281 282 283 284 285 286 287
    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
288 289 290 291 292 293 294 295 296

  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_)

297
end
298 299 300

module type WEB_ELECTION = sig
  module G : Signatures.GROUP
301
  module P : Signatures.ELECTION_PARAMS
302 303 304 305
  module E : LWT_ELECTION
  module B : WEB_BBOX
  val data : election_data
end