web_persist.ml 5.89 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
(*  Copyright © 2012-2015 Inria                                           *)
(*                                                                        *)
(*  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 Serializable_j
25
open Common
26
open Web_serializable_j
27
open Web_common
28

29 30 31 32 33 34 35 36 37
let ( / ) = Filename.concat

let get_election_result uuid =
  try_lwt
    Lwt_io.chars_of_file (!spool_dir / uuid / "result.json") |>
    Lwt_stream.to_string >>= fun x ->
    return @@ Some (result_of_string (Yojson.Safe.from_lexbuf ~stream:true) x)
  with _ -> return_none

38 39 40
type election_state =
  [ `Open
  | `Closed
41
  | `EncryptedTally of int * int * string
42
  | `Tallied of plaintext
Stephane Glondu's avatar
Stephane Glondu committed
43
  | `Archived
44 45
  ]

46 47 48 49
let election_states = Ocsipersist.open_table "election_states"

let get_election_state x =
  try_lwt Ocsipersist.find election_states x
Stephane Glondu's avatar
Stephane Glondu committed
50
  with Not_found -> return `Archived
51 52 53

let set_election_state x s =
  Ocsipersist.add election_states x s
54

55 56
let past = datetime_of_string "\"2015-10-01 00:00:00.000000\""

Stephane Glondu's avatar
Stephane Glondu committed
57 58 59 60 61
let set_election_date uuid d =
  let dates = { e_finalization = d } in
  Lwt_io.(with_file Output (!spool_dir / uuid / "dates.json") (fun oc ->
    write_line oc (string_of_election_dates dates)
  ))
62

Stephane Glondu's avatar
Stephane Glondu committed
63 64 65 66 67 68 69 70
let get_election_date uuid =
    try_lwt
      Lwt_io.chars_of_file (!spool_dir / uuid / "dates.json") |>
      Lwt_stream.to_string >>= fun x ->
      let dates = election_dates_of_string x in
      return dates.e_finalization
    with _ ->
      return past
71

72 73 74 75 76 77 78 79
let election_pds = Ocsipersist.open_table "election_pds"

let get_partial_decryptions x =
  try_lwt Ocsipersist.find election_pds x
  with Not_found -> return []

let set_partial_decryptions x pds =
  Ocsipersist.add election_pds x pds
Stephane Glondu's avatar
Stephane Glondu committed
80 81 82 83 84 85 86 87 88

let auth_configs = Ocsipersist.open_table "auth_configs"

let get_auth_config x =
  try_lwt Ocsipersist.find auth_configs x
  with Not_found -> return []

let set_auth_config x c =
  Ocsipersist.add auth_configs x c
89

90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
let get_raw_election uuid =
  try_lwt
    let lines = Lwt_io.lines_of_file (!spool_dir / uuid / "election.json") in
    begin match_lwt Lwt_stream.to_list lines with
    | x :: _ -> return @@ Some x
    | [] -> return_none
    end
  with _ -> return_none

let get_election_metadata uuid =
  try_lwt
    Lwt_io.chars_of_file (!spool_dir / uuid / "metadata.json") |>
    Lwt_stream.to_string >>= fun x ->
    return @@ Some (metadata_of_string x)
  with _ -> return_none

Stephane Glondu's avatar
Stephane Glondu committed
106 107 108 109 110 111 112 113
let get_elections_by_owner user =
  Lwt_unix.files_of_directory !spool_dir |>
  Lwt_stream.filter_s (fun x ->
    if x = "." || x = ".." then return false else
    match_lwt get_election_metadata x with
    | Some m -> return (m.e_owner = Some user)
    | None -> return false
  ) |> Lwt_stream.to_list
114 115 116 117 118 119 120

let get_voters uuid =
  try_lwt
    let lines = Lwt_io.lines_of_file (!spool_dir / uuid / "voters.txt") in
    lwt lines = Lwt_stream.to_list lines in
    return @@ Some lines
  with _ -> return_none
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136

let get_passwords uuid =
  let csv =
    try Some (Csv.load (!spool_dir / uuid / "passwords.csv"))
    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
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 174 175 176 177 178 179


module Ballots = Map.Make (String)

module BallotsCacheTypes = struct
  type key = string
  type value = string Ballots.t
end

module BallotsCache = Ocsigen_cache.Make (BallotsCacheTypes)

let raw_get_ballots_archived uuid =
  try_lwt
    let ballots = Lwt_io.lines_of_file (!spool_dir / uuid / "ballots.jsons") in
    Lwt_stream.fold (fun b accu ->
      let hash = sha256_b64 b in
      Ballots.add hash b accu
    ) ballots Ballots.empty
  with _ -> return Ballots.empty

let archived_ballots_cache =
  new BallotsCache.cache raw_get_ballots_archived 10

let get_ballot_hashes ~uuid =
  match_lwt get_election_state uuid with
  | `Archived ->
     lwt ballots = archived_ballots_cache#find uuid in
     Ballots.bindings ballots |> List.map fst |> return
  | _ ->
     let table = Ocsipersist.open_table ("ballots_" ^ underscorize uuid) in
     Ocsipersist.fold_step (fun hash _ accu ->
       return (hash :: accu)
     ) table [] >>= (fun x -> return @@ List.rev x)

let get_ballot_by_hash ~uuid ~hash =
  match_lwt get_election_state uuid with
  | `Archived ->
     lwt ballots = archived_ballots_cache#find uuid in
     (try Some (Ballots.find hash ballots) with Not_found -> None) |> return
  | _ ->
     let table = Ocsipersist.open_table ("ballots_" ^ underscorize uuid) in
     try_lwt Ocsipersist.find table hash >>= (fun x -> return @@ Some x)
     with Not_found -> return_none