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 2.73 KB
Newer Older
1
open Lwt
Stephane Glondu's avatar
Stephane Glondu committed
2
open Util
3
open Serializable_t
4

5 6
type user_type = Dummy | CAS

7 8
type user = {
  user_name : string;
9
  user_type : user_type;
10 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 18 19 20
type acl =
  | Any
  | Restricted of (user -> bool Lwt.t)

21
type election_data = {
22
  fn_election : string;
23
  fingerprint : string;
24
  election : ff_pubkey election;
25
  fn_public_keys : string;
Stephane Glondu's avatar
Stephane Glondu committed
26
  featured_p : bool;
Stephane Glondu's avatar
Stephane Glondu committed
27 28
  can_read : acl;
  can_vote : acl;
29 30 31 32 33 34 35 36 37
}

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
38 39 40 41 42 43 44 45
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

46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
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

exception Serialization of exn
exception ProofCheck

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

72 73 74 75 76 77 78
module type WEB_BBOX = sig
  include Signatures.BALLOT_BOX
  with type 'a m := 'a Lwt.t
  and type ballot = string
  and type record = string * Serializable_builtin_t.datetime
end

79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
module MakeBallotBox (E : LWT_ELECTION) = struct

  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)

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

  let cast rawballot (user, date) =
    lwt ballot =
      try Lwt.return (
        Serializable_j.ballot_of_string
          Serializable_builtin_j.read_number rawballot
      ) with e -> Lwt.fail (Serialization e)
    in
    if E.check_ballot ballot then (
      Ocsipersist.add ballot_table (sha256_b64 rawballot) rawballot >>
      Ocsipersist.add record_table user date
    ) else (
      Lwt.fail ProofCheck
    )


  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
115 116 117 118 119 120 121

module type WEB_ELECTION = sig
  module G : Signatures.GROUP
  module E : LWT_ELECTION
  module B : WEB_BBOX
  val data : election_data
end