Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. 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.

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

5
6
7
8
9
10
type user_type = Dummy | CAS

let string_of_user_type = function
  | Dummy -> "dummy"
  | CAS -> "cas"

11
12
type user = {
  user_name : string;
13
  user_type : user_type;
14
15
}

Stephane Glondu's avatar
Stephane Glondu committed
16
17
18
19
type acl =
  | Any
  | Restricted of (user -> bool Lwt.t)

20
21
22
type election_data = {
  raw : string;
  fingerprint : string;
23
  election : ff_pubkey election;
Stephane Glondu's avatar
Stephane Glondu committed
24
  public_keys : Z.t trustee_public_key array;
25
  public_keys_file : string;
Stephane Glondu's avatar
Stephane Glondu committed
26
  election_result : Z.t result option;
Stephane Glondu's avatar
Stephane Glondu committed
27
  author : user;
Stephane Glondu's avatar
Stephane Glondu committed
28
  featured_p : bool;
Stephane Glondu's avatar
Stephane Glondu committed
29
30
31
  can_read : acl;
  can_vote : acl;
  can_admin : acl;
32
33
34
35
36
37
38
39
40
}

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
41
42
43
44
45
46
47
48
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

49
50
51
52
53
54
55
56
57
58
59
60
61
62
let load_elections_and_votes dirname =
  Lwt_unix.files_of_directory dirname |>
  Lwt_stream.filter_map_s (fun x ->
    let n = String.length x in
    if n = 38 && x.[0] = '{' && x.[n-1] = '}' then (
      match Uuidm.of_string ~pos:1 x with
      | Some uuid ->
        let dirname = Filename.concat dirname x in
        let data x = Filename.concat dirname x in
        lwt raw =
          data "election.json" |>
          Lwt_io.lines_of_file |>
          enforce_single_element
        in
63
64
        let election = Serializable_j.election_of_string
          Serializable_j.read_ff_pubkey raw
65
66
        in
        (assert_lwt (Uuidm.equal uuid election.e_uuid)) >>
67
        let public_keys_file = data "public_keys.jsons" in
68
        lwt public_keys =
69
          public_keys_file |>
70
71
          Lwt_io.lines_of_file |>
          Lwt_stream.map (fun x ->
72
            Serializable_j.trustee_public_key_of_string Serializable_builtin_j.read_number x
73
74
75
          ) |>
          Lwt_stream.to_list >>= wrap1 Array.of_list
        in
76
77
78
79
80
        let election_result =
          try Some (
            data "result.json" |>
            load_from_file (Serializable_j.read_result Serializable_builtin_j.read_number)
          ) with Sys_error _ -> None
81
        in
Stephane Glondu's avatar
Stephane Glondu committed
82
        let fingerprint = sha256_b64 raw in
Stephane Glondu's avatar
Stephane Glondu committed
83
84
        let ballots =
          let file = data "ballots.json" in
85
86
87
          if Sys.file_exists file then (
            Lwt_io.lines_of_file file |>
            Lwt_stream.map (fun x ->
88
              let v = Serializable_j.ballot_of_string Serializable_builtin_j.read_number x in
89
              assert (Uuidm.equal uuid v.election_uuid);
Stephane Glondu's avatar
Stephane Glondu committed
90
              x, v
91
92
93
            )
          ) else Lwt_stream.from_direct (fun () -> None)
        in
Stephane Glondu's avatar
Stephane Glondu committed
94
95
96
97
98
        let election_data = {
          raw;
          fingerprint;
          election;
          public_keys;
99
          public_keys_file;
Stephane Glondu's avatar
Stephane Glondu committed
100
          election_result;
101
          author = { user_name = "admin"; user_type = Dummy };
Stephane Glondu's avatar
Stephane Glondu committed
102
          featured_p = true;
Stephane Glondu's avatar
Stephane Glondu committed
103
104
105
          can_read = Any;
          can_vote = Any;
          can_admin = Any;
Stephane Glondu's avatar
Stephane Glondu committed
106
        } in
107
        Lwt.return (Some (election_data, ballots))
108
109
110
      | None -> assert false
    ) else Lwt.return None
  )
111
112
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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

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

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