web_persist.ml 15.1 KB
Newer Older
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2018 Inria                                           *)
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

22
open Lwt
23
open Platform
24
open Signatures
25
open Serializable_builtin_t
26
open Serializable_j
27
open Common
28
open Web_serializable_j
29
open Web_common
30

31 32
let ( / ) = Filename.concat

33 34 35 36 37 38 39 40
let get_draft_election uuid =
  match%lwt read_file ~uuid "draft.json" with
  | Some [x] -> return @@ Some (draft_election_of_string x)
  | _ -> return_none

let set_draft_election uuid se =
  write_file ~uuid "draft.json" [string_of_draft_election se]

41
let get_election_result uuid =
42 43 44
  match%lwt read_file ~uuid "result.json" with
  | Some [x] -> return (Some (result_of_string Yojson.Safe.read_json x))
  | _ -> return_none
45

46 47 48 49
let get_election_state uuid =
  match%lwt read_file ~uuid "state.json" with
  | Some [x] -> return @@ election_state_of_string x
  | _ -> return `Archived
50

51 52 53 54 55 56 57 58
let set_election_state uuid s =
  match s with
  | `Archived ->
     (
       try%lwt Lwt_unix.unlink (!spool_dir / raw_string_of_uuid uuid / "state.json")
       with _ -> return_unit
     )
  | _ -> write_file ~uuid "state.json" [string_of_election_state s]
59

60 61
type election_date =
  [ `Creation
62
  | `Validation
63 64
  | `Tally
  | `Archive
65
  | `LastMail
66 67 68 69 70 71 72 73 74 75
  ]

let get_election_dates uuid =
  match%lwt read_file ~uuid "dates.json" with
  | Some [x] -> return (election_dates_of_string x)
  | _ -> return {
             e_creation = None;
             e_finalization = None;
             e_tally = None;
             e_archive = None;
76
             e_last_mail = None;
77
           }
78

79 80 81 82
let set_election_date kind uuid d =
  let%lwt dates = get_election_dates uuid in
  let dates = match kind with
    | `Creation -> { dates with e_creation = Some d }
83
    | `Validation -> { dates with e_finalization = Some d }
84 85
    | `Tally -> { dates with e_tally = Some d }
    | `Archive -> { dates with e_archive = Some d }
86
    | `LastMail -> { dates with e_last_mail = Some d }
87 88
  in
  let dates = string_of_election_dates dates in
89
  write_file ~uuid "dates.json" [dates]
90

91 92 93 94
let get_election_date kind uuid =
  let%lwt dates = get_election_dates uuid in
  match kind with
  | `Creation -> return dates.e_creation
95
  | `Validation -> return dates.e_finalization
96 97
  | `Tally -> return dates.e_tally
  | `Archive -> return dates.e_archive
98
  | `LastMail -> return dates.e_last_mail
99

100 101 102 103
let get_partial_decryptions uuid =
  match%lwt read_file ~uuid "partial_decryptions.json" with
  | Some [x] -> return @@ partial_decryptions_of_string x
  | _ -> return []
104

105 106 107
let set_partial_decryptions uuid pds =
  write_file ~uuid "partial_decryptions.json"
    [string_of_partial_decryptions pds]
108

109 110 111 112 113 114 115 116 117
let get_decryption_tokens uuid =
  match%lwt read_file ~uuid "decryption_tokens.json" with
  | Some [x] -> return @@ Some (decryption_tokens_of_string x)
  | _ -> return_none

let set_decryption_tokens uuid pds =
  write_file ~uuid "decryption_tokens.json"
    [string_of_decryption_tokens pds]

118
let get_raw_election uuid =
119 120 121
  match%lwt read_file ~uuid "election.json" with
  | Some [x] -> return (Some x)
  | _ -> return_none
122

123 124 125 126 127
let empty_metadata = {
  e_owner = None;
  e_auth_config = None;
  e_cred_authority = None;
  e_trustees = None;
128
  e_languages = None;
129
  e_contact = None;
130
  e_server_is_trustee = None;
131 132 133 134
}

let return_empty_metadata = return empty_metadata

135
let get_election_metadata uuid =
136 137 138
  match%lwt read_file ~uuid "metadata.json" with
  | Some [x] -> return (metadata_of_string x)
  | _ -> return_empty_metadata
139

140 141 142 143
let get_auth_config uuid =
  let%lwt metadata = get_election_metadata uuid in
  match metadata.e_auth_config with
  | None -> return []
144
  | Some x -> return x
145

146 147 148 149 150 151 152
type election_kind =
  [ `Draft
  | `Validated
  | `Tallied
  | `Archived
  ]

153 154
let get_elections_by_owner user =
  Lwt_unix.files_of_directory !spool_dir |>
155 156
    Lwt_stream.to_list >>=
    Lwt_list.filter_map_p
157 158 159 160 161
      (fun x ->
        if x = "." || x = ".." then
          return None
        else (
          try
162
            let uuid = uuid_of_raw_string x in
163 164 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
            match%lwt get_draft_election uuid with
            | None ->
               (
                 let%lwt metadata = get_election_metadata uuid in
                 match metadata.e_owner with
                 | Some o when o = user ->
                    (
                      match%lwt get_raw_election uuid with
                      | None -> return_none
                      | Some election ->
                         let election = Election.of_string election in
                         let%lwt kind, date =
                           match%lwt get_election_state uuid with
                           | `Open | `Closed | `EncryptedTally _ ->
                              let%lwt date = get_election_date `Validation uuid in
                              let date = Option.get date default_validation_date in
                              return (`Validated, date)
                           | `Tallied ->
                              let%lwt date = get_election_date `Tally uuid in
                              let date = Option.get date default_tally_date in
                              return (`Tallied, date)
                           | `Archived ->
                              let%lwt date = get_election_date `Archive uuid in
                              let date = Option.get date default_archive_date in
                              return (`Archived, date)
                         in
                         return @@ Some (kind, uuid, date, election.e_params.e_name)
                    )
                 | _ -> return_none
               )
            | Some se ->
               if se.se_owner = user then
                 let date = Option.get se.se_creation_date default_creation_date in
                 return @@ Some (`Draft, uuid, date, se.se_questions.t_name)
               else return_none
198 199
          with _ -> return None
        )
200
      )
201 202

let get_voters uuid =
203
  read_file ~uuid "voters.txt"
204 205 206

let get_passwords uuid =
  let csv =
207
    try Some (Csv.load (!spool_dir / raw_string_of_uuid uuid / "passwords.csv"))
208 209 210 211 212 213 214 215 216 217 218 219
    with _ -> None
  in
  match csv with
  | None -> return_none
  | Some csv ->
     let res = List.fold_left (fun accu line ->
       match line with
       | [login; salt; hash] ->
          SMap.add login (salt, hash) accu
       | _ -> accu
     ) SMap.empty csv in
     return @@ Some res
220

221
let get_public_keys uuid =
222
  read_file ~uuid "public_keys.jsons"
223

224 225 226 227 228
let get_private_key uuid =
  match%lwt read_file ~uuid "private_key.json" with
  | Some [x] -> return (Some (number_of_string x))
  | _ -> return_none

229
let get_private_keys uuid =
230
  read_file ~uuid "private_keys.jsons"
231

232
let get_threshold uuid =
233 234 235
  match%lwt read_file ~uuid "threshold.json" with
  | Some [x] -> return (Some x)
  | _ -> return_none
236

237
module StringMap = Map.Make (String)
238 239

module BallotsCacheTypes = struct
240
  type key = uuid
241
  type value = string StringMap.t
242 243 244 245 246
end

module BallotsCache = Ocsigen_cache.Make (BallotsCacheTypes)

let raw_get_ballots_archived uuid =
247 248 249 250 251
  match%lwt read_file ~uuid "ballots.jsons" with
  | Some bs ->
     return (
         List.fold_left (fun accu b ->
             let hash = sha256_b64 b in
252 253
             StringMap.add hash b accu
           ) StringMap.empty bs
254
       )
255
  | None -> return StringMap.empty
256 257

let archived_ballots_cache =
Stephane Glondu's avatar
Stephane Glondu committed
258
  new BallotsCache.cache raw_get_ballots_archived ~timer:3600. 10
259

260
let get_ballot_hashes uuid =
261
  match%lwt get_election_state uuid with
262
  | `Archived ->
263
     let%lwt ballots = archived_ballots_cache#find uuid in
264
     StringMap.bindings ballots |> List.map fst |> return
265
  | _ ->
266 267 268 269 270
     let uuid_s = raw_string_of_uuid uuid in
     let ballots = Lwt_unix.files_of_directory (!spool_dir / uuid_s / "ballots") in
     let%lwt ballots = Lwt_stream.to_list ballots in
     let ballots = List.filter (fun x -> x <> "." && x <> "..") ballots in
     return (List.rev_map unurlize ballots)
271

272
let get_ballot_by_hash uuid hash =
273
  match%lwt get_election_state uuid with
274
  | `Archived ->
275
     let%lwt ballots = archived_ballots_cache#find uuid in
276
     return (StringMap.find_opt hash ballots)
277
  | _ ->
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296
     let%lwt ballot = read_file ~uuid ("ballots" / urlize hash) in
     match ballot with
     | Some [x] -> return (Some x)
     | _ -> return_none

let load_ballots uuid =
  let ballots_dir = !spool_dir / raw_string_of_uuid uuid / "ballots" in
  let ballots = Lwt_unix.files_of_directory ballots_dir in
  let%lwt ballots = Lwt_stream.to_list ballots in
  Lwt_list.filter_map_p (fun x ->
      match%lwt read_file (ballots_dir / x) with
      | Some [x] -> return (Some x)
      | _ -> return_none
    ) ballots

let dump_ballots uuid =
  let%lwt ballots = load_ballots uuid in
  write_file ~uuid "ballots.jsons" ballots

297 298
let add_ballot uuid ballot =
  let hash = sha256_b64 ballot in
299 300
  let ballots_dir = !spool_dir / raw_string_of_uuid uuid / "ballots" in
  let%lwt () = try%lwt Lwt_unix.mkdir ballots_dir 0o755 with _ -> return_unit in
301 302
  let%lwt () = write_file (ballots_dir / urlize hash) [ballot] in
  let%lwt () = dump_ballots uuid in
303
  return hash
304 305 306 307 308

let remove_ballot uuid hash =
  let ballots_dir = !spool_dir / raw_string_of_uuid uuid / "ballots" in
  try%lwt Lwt_unix.unlink (ballots_dir / urlize hash) with _ -> return_unit

309
let replace_ballot uuid hash ballot =
310
  let%lwt () = remove_ballot uuid hash in
311 312
  add_ballot uuid ballot

313 314 315
let compute_encrypted_tally uuid =
  let%lwt election = get_raw_election uuid in
  match election with
316
  | None -> return None
317 318 319 320 321 322 323 324 325 326 327 328 329 330
  | Some election ->
     let election = Election.of_string election in
     let module W = (val Election.get_group election) in
     let module E = Election.Make (W) (LwtRandom) in
     let%lwt ballots = load_ballots uuid in
     let num_tallied, tally =
       List.fold_left (fun (n, accu) rawballot ->
           let ballot = ballot_of_string E.G.read rawballot in
           let ciphertext = E.extract_ciphertext ballot in
           n + 1, E.combine_ciphertexts accu ciphertext
         ) (0, E.neutral_ciphertext ()) ballots
     in
     let tally = string_of_encrypted_tally E.G.write tally in
     let%lwt () = write_file ~uuid (string_of_election_file ESETally) [tally] in
331
     return (Some (num_tallied, sha256_b64 tally, tally))
332

333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359
module ExtendedRecordsCacheTypes = struct
  type key = uuid
  type value = (datetime * string) StringMap.t
end

module ExtendedRecordsCache = Ocsigen_cache.Make (ExtendedRecordsCacheTypes)

let raw_get_extended_records uuid =
  match%lwt read_file ~uuid "extended_records.jsons" with
  | Some xs ->
     let xs = List.map extended_record_of_string xs in
     return (
         List.fold_left (fun accu r ->
             StringMap.add r.r_username (r.r_date, r.r_credential) accu
           ) StringMap.empty xs
       )
  | None -> return StringMap.empty

let dump_extended_records uuid rs =
  let rs = StringMap.bindings rs in
  let extended_records =
    List.map (fun (r_username, (r_date, r_credential)) ->
        string_of_extended_record {r_username; r_date; r_credential}
      ) rs
  in
  let records =
    List.map (fun (u, (d, _)) ->
360
        Printf.sprintf "%s %S" (string_of_datetime d) u
361 362
      ) rs
  in
363
  let%lwt () = write_file ~uuid "extended_records.jsons" extended_records in
364 365 366 367 368 369 370
  write_file ~uuid (string_of_election_file ESRecords) records

let extended_records_cache =
  new ExtendedRecordsCache.cache raw_get_extended_records ~timer:3600. 10

let find_extended_record uuid username =
  let%lwt rs = extended_records_cache#find uuid in
371
  return (StringMap.find_opt username rs)
372 373 374 375 376 377 378

let add_extended_record uuid username r =
  let%lwt rs = extended_records_cache#find uuid in
  let rs = StringMap.add username r rs in
  extended_records_cache#add uuid rs;
  dump_extended_records uuid rs

379
let has_voted uuid user =
380 381
  let%lwt rs = extended_records_cache#find uuid in
  return @@ StringMap.mem (string_of_user user) rs
382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408

module CredMappingsCacheTypes = struct
  type key = uuid
  type value = string option StringMap.t
end

module CredMappingsCache = Ocsigen_cache.Make (CredMappingsCacheTypes)

let raw_get_credential_mappings uuid =
  match%lwt read_file ~uuid "credential_mappings.jsons" with
  | Some xs ->
     let xs = List.map credential_mapping_of_string xs in
     return (
         List.fold_left (fun accu x ->
             StringMap.add x.c_credential x.c_ballot accu
           ) StringMap.empty xs
       )
  | None -> return StringMap.empty

let dump_credential_mappings uuid xs =
  let xs = StringMap.bindings xs in
  let mappings =
    List.map (fun (c_credential, c_ballot) ->
        string_of_credential_mapping {c_credential; c_ballot}
      ) xs
  in
  let creds = List.map fst xs in
409
  let%lwt () = write_file ~uuid "credential_mappings.jsons" mappings in
410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454
  write_file ~uuid "public_creds.txt" creds

let credential_mappings_cache =
  new CredMappingsCache.cache raw_get_credential_mappings ~timer:3600. 10

let init_credential_mapping uuid xs =
  let xs =
    List.fold_left (fun accu x ->
        if StringMap.mem x accu then
          failwith "trying to add duplicate credential"
        else
          StringMap.add x None accu
      ) StringMap.empty xs
  in
  credential_mappings_cache#add uuid xs;
  dump_credential_mappings uuid xs

let find_credential_mapping uuid cred =
  let%lwt xs = credential_mappings_cache#find uuid in
  return @@ StringMap.find cred xs

let add_credential_mapping uuid cred mapping =
  let%lwt xs = credential_mappings_cache#find uuid in
  let xs = StringMap.add cred mapping xs in
  credential_mappings_cache#add uuid xs;
  dump_credential_mappings uuid xs

let replace_credential uuid old_ new_ =
  let%lwt xs = credential_mappings_cache#find uuid in
  let old_cred =
    StringMap.fold (fun k v accu ->
        if sha256_hex k = old_ then (
          match v with
          | Some _ -> raise (Error UsedCredential)
          | None -> Some k
        ) else accu
      ) xs None
  in
  match old_cred with
  | None -> fail CredentialNotFound
  | Some old_cred ->
     let xs = StringMap.remove old_cred xs in
     let xs = StringMap.add new_ None xs in
     credential_mappings_cache#add uuid xs;
     dump_credential_mappings uuid xs