web_common.ml 7.63 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

6 7
type user_type = Dummy | CAS

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

13 14 15 16 17
let string_of_user {user_name; user_type} =
  match user_type with
    | Dummy -> Printf.sprintf "dummy:%s" user_name
    | CAS -> user_name

18 19 20 21 22
(* FIXME: use a dedicated user_type *)
let is_admin = function
  | Some { user_name = "admin"; user_type = Dummy } -> true
  | _ -> 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
83 84 85 86 87 88 89 90 91 92 93 94 95 96

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"
97
  | WrongCredential -> "you are not allowed to vote with this credential"
98 99 100 101 102

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

103 104 105 106
module type WEB_BBOX = sig
  include Signatures.BALLOT_BOX
  with type 'a m := 'a Lwt.t
  and type ballot = string
107
  and type record = string * datetime
108 109

  val inject_creds : SSet.t -> unit Lwt.t
110
  val extract_creds : unit -> SSet.t Lwt.t
111 112
end

113 114 115 116 117 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
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

144 145 146
module MakeBallotBox (P : Signatures.ELECTION_PARAMS) (E : LWT_ELECTION) = struct

  (* TODO: enforce E is derived from P *)
147 148 149 150 151 152 153 154

  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)
155
  let cred_table = Ocsipersist.open_table ("creds" ^ suffix)
156 157 158 159

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

160 161
  let extract_creds () =
    Ocsipersist.fold_step (fun k v x ->
162
      return (SSet.add k x)
163 164 165 166
    ) cred_table SSet.empty

  let inject_creds creds =
    lwt existing_creds = extract_creds () in
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
    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")
      )
    )

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

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

  let fold_records f x =
263
    Ocsipersist.fold_step (fun k v x -> f (k, fst v) x) record_table x
264 265 266

  let turnout = Ocsipersist.length ballot_table
end
267 268 269

module type WEB_ELECTION = sig
  module G : Signatures.GROUP
270
  module P : Signatures.ELECTION_PARAMS
271 272 273 274
  module E : LWT_ELECTION
  module B : WEB_BBOX
  val data : election_data
end