Attention une mise à jour du service Gitlab va être effectuée le mardi 30 novembre entre 17h30 et 18h00. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes. Cette mise à jour intermédiaire en version 14.0.12 nous permettra de rapidement pouvoir mettre à votre disposition une version plus récente.

web_common.ml 5.82 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 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
type error =
 | Serialization of exn
 | ProofCheck
 | ElectionClosed
 | MissingCredential
 | InvalidCredential
 | RevoteNotAllowed
 | ReusedCredential

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"
96 97 98 99 100

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

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

  val inject_creds : SSet.t -> unit Lwt.t
108
  val extract_creds : unit -> SSet.t Lwt.t
109 110
end

111 112 113
module MakeBallotBox (P : Signatures.ELECTION_PARAMS) (E : LWT_ELECTION) = struct

  (* TODO: enforce E is derived from P *)
114 115 116 117 118 119 120 121

  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)
122
  let cred_table = Ocsipersist.open_table ("creds" ^ suffix)
123 124 125 126

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

127 128
  let extract_creds () =
    Ocsipersist.fold_step (fun k v x ->
129
      return (SSet.add k x)
130 131 132 133
    ) cred_table SSet.empty

  let inject_creds creds =
    lwt existing_creds = extract_creds () in
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
    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")
      )
    )

149
  let cast rawballot (user, date) =
150 151 152 153 154 155 156 157 158
    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 () >>
159 160 161 162
    lwt ballot =
      try Lwt.return (
        Serializable_j.ballot_of_string
          Serializable_builtin_j.read_number rawballot
163
      ) with e -> fail (Serialization e)
164
    in
165 166 167 168 169 170 171 172 173 174 175 176 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 202
    lwt credential =
      match ballot.signature with
        | Some s -> Lwt.return (Z.to_string s.s_commitment)
        | None -> fail MissingCredential
    in
    lwt cred =
      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
    match cred, old_record with
      | 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 >>
          Ocsipersist.add record_table user date
        ) else (
          fail ProofCheck
        )
      | Some h, Some _ ->
        (* revote *)
        if E.check_ballot ballot then (
          Ocsipersist.remove ballot_table h >>
          let hash = sha256_b64 rawballot in
          Ocsipersist.add cred_table credential (Some hash) >>
          Ocsipersist.add ballot_table hash rawballot >>
          Ocsipersist.add record_table user date
        ) else (
          fail ProofCheck
        )
      | None, Some _ -> fail RevoteNotAllowed
      | Some _, None -> fail ReusedCredential
203 204 205 206 207 208 209 210 211

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

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

  let turnout = Ocsipersist.length ballot_table
end
212 213 214

module type WEB_ELECTION = sig
  module G : Signatures.GROUP
215
  module P : Signatures.ELECTION_PARAMS
216 217 218 219
  module E : LWT_ELECTION
  module B : WEB_BBOX
  val data : election_data
end