web_common.ml 8.39 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_election : string;
31
  fingerprint : string;
32
  election : ff_pubkey election;
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 183 184 185 186
    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 (
        Lwt.fail (Invalid_argument "Existing credentials do not match")
      )
    )

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

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

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

  let turnout = Ocsipersist.length ballot_table
Stephane Glondu's avatar
Stephane Glondu committed
274 275 276 277 278 279 280 281 282 283 284 285 286

  let 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
287
end
288 289 290

module type WEB_ELECTION = sig
  module G : Signatures.GROUP
291
  module P : Signatures.ELECTION_PARAMS
292 293 294 295
  module E : LWT_ELECTION
  module B : WEB_BBOX
  val data : election_data
end