web_common.ml 7.03 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2014 Inria                                           *)
Stephane Glondu's avatar
Stephane Glondu committed
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
Stephane Glondu's avatar
Stephane Glondu committed
24
open Common
25
open Serializable_builtin_j
26
open Serializable_t
Stephane Glondu's avatar
Stephane Glondu committed
27
open Web_serializable_t
28

29 30
let spool_dir = ref "."

31
let make_rng = Lwt_preemptive.detach (fun () ->
32
  pseudo_rng (random_string secure_rng 16)
33 34
)

35 36
module type LWT_RANDOM = Signatures.RANDOM with type 'a t = 'a Lwt.t

37
module type LWT_RNG = sig
38
  val rng : rng Lwt.t
39 40 41
end

module MakeLwtRandom (X : LWT_RNG) = struct
42 43 44 45 46 47 48

  type 'a t = 'a Lwt.t
  let return = Lwt.return
  let bind = Lwt.bind
  let fail = Lwt.fail

  let random q =
49
    let size = Z.bit_length q / 8 + 1 in
50
    lwt rng = X.rng in
51
    let r = random_string rng size in
52 53 54 55
    return Z.(of_bits r mod q)

end

56
type error =
57 58 59 60 61 62 63 64
  | Serialization of exn
  | ProofCheck
  | ElectionClosed
  | MissingCredential
  | InvalidCredential
  | RevoteNotAllowed
  | ReusedCredential
  | WrongCredential
Stephane Glondu's avatar
Stephane Glondu committed
65 66
  | UsedCredential
  | CredentialNotFound
67
  | UnauthorizedVoter
68 69 70 71 72 73 74 75 76 77 78 79 80 81

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"
82
  | WrongCredential -> "you are not allowed to vote with this credential"
Stephane Glondu's avatar
Stephane Glondu committed
83 84
  | UsedCredential -> "the credential has already been used"
  | CredentialNotFound -> "the credential has not been found"
85
  | UnauthorizedVoter -> "you are not allowed to vote"
86

87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
let security_logfile = ref None

let open_security_log f =
  lwt () =
    match !security_logfile with
      | Some ic -> Lwt_io.close ic
      | None -> return ()
  in
  lwt ic = Lwt_io.(
    open_file ~flags:Unix.(
      [O_WRONLY; O_APPEND; O_CREAT]
    ) ~perm:0o600 ~mode:output f
  ) in
  security_logfile := Some ic;
  return ()

let security_log s =
  match !security_logfile with
    | None -> return ()
    | Some ic -> Lwt_io.atomic (fun ic ->
      Lwt_io.write ic (
108
        string_of_datetime (now ())
109 110 111 112 113 114
      ) >>
      Lwt_io.write ic ": " >>
      Lwt_io.write_line ic (s ()) >>
      Lwt_io.flush ic
    ) ic

115 116 117 118 119
let fail_http status =
  raise_lwt (
    Ocsigen_extensions.Ocsigen_http_error
      (Ocsigen_cookies.empty_cookieset, status)
  )
120

121
let forbidden () = fail_http 403
122 123 124 125 126 127 128 129 130 131 132 133 134

let rewrite_fun = ref (fun x -> x)

let rewrite_prefix x = !rewrite_fun x

let set_rewrite_prefix ~src ~dst =
  let nsrc = String.length src in
  let f x =
    let n = String.length x in
    if n >= nsrc && String.sub x 0 nsrc = src then
      dst ^ String.sub x nsrc (n-nsrc)
    else x
  in rewrite_fun := f
Stephane Glondu's avatar
Stephane Glondu committed
135

136 137 138 139 140
type election_file =
  | ESRaw
  | ESKeys
  | ESCreds
  | ESBallots
Stephane Glondu's avatar
Stephane Glondu committed
141
  | ESVoters
142
  | ESRecords
143
  | ESETally
144
  | ESResult
145 146 147 148 149 150 151

let election_file_of_string = function
  | "election.json" -> ESRaw
  | "public_keys.jsons" -> ESKeys
  | "public_creds.txt" -> ESCreds
  | "ballots.jsons" -> ESBallots
  | "records" -> ESRecords
Stephane Glondu's avatar
Stephane Glondu committed
152
  | "voters.txt" -> ESVoters
153
  | "encrypted_tally.json" -> ESETally
154
  | "result.json" -> ESResult
155 156 157 158 159 160 161 162
  | x -> invalid_arg ("election_dir_item: " ^ x)

let string_of_election_file = function
  | ESRaw -> "election.json"
  | ESKeys -> "public_keys.jsons"
  | ESCreds -> "public_creds.txt"
  | ESBallots -> "ballots.jsons"
  | ESRecords -> "records"
Stephane Glondu's avatar
Stephane Glondu committed
163
  | ESVoters -> "voters.txt"
164
  | ESETally -> "encrypted_tally.json"
165
  | ESResult -> "result.json"
166 167 168 169

let election_file = Eliom_parameter.user_type
  ~of_string:election_file_of_string
  ~to_string:string_of_election_file
170 171 172 173 174 175 176 177 178 179 180

let uuid_of_string x =
  match Uuidm.of_string x with
  | Some x -> x
  | None -> Printf.ksprintf invalid_arg "invalid UUID [%s]" x

let uuid =
  let of_string x = uuid_of_string x
  and to_string x = Uuidm.to_string x
  in Eliom_parameter.user_type ~of_string ~to_string

181 182
type setup_voter = {
  sv_id : string;
183
  mutable sv_password : (string * string) option;
184 185
}

186
type setup_trustee = {
187
  st_id : string;
188 189 190 191
  st_token : string;
  mutable st_public_key : string;
}

192 193 194
type setup_election = {
  mutable se_owner : user;
  mutable se_group : string;
195
  mutable se_voters : setup_voter list;
196
  mutable se_questions : template;
197
  mutable se_public_keys : setup_trustee list;
198 199
  mutable se_metadata : metadata;
  mutable se_public_creds : string;
200
  mutable se_public_creds_received : bool;
201 202 203 204 205 206 207 208 209 210 211 212 213 214
}

let b58_digits = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
let token_length = 14
let prng = lazy (pseudo_rng (random_string secure_rng 16))

let random_char () =
  lwt rng =
    if Lazy.is_val prng then return (Lazy.force prng) else
    Lwt_preemptive.detach (fun () -> Lazy.force prng) ()
  in
  return (int_of_char (random_string rng 1).[0])

let generate_token () =
215
  let res = Bytes.create token_length in
216 217 218 219
  let rec loop i =
    if i < token_length then (
      lwt digit = random_char () in
      let digit = digit mod 58 in
220
      Bytes.set res i b58_digits.[digit];
221
      loop (i+1)
222
    ) else return (Bytes.to_string res)
223
  in loop 0
224 225 226

let string_of_user {user_domain; user_name} =
  user_domain ^ ":" ^ user_name
Stephane Glondu's avatar
Stephane Glondu committed
227 228 229

let underscorize x =
  String.map (function '-' -> '_' | c -> c) x
230 231 232 233 234

let send_email from to_ subject body =
  let contents =
    "From: " ^ from ^ "\nTo: " ^ to_ ^ "\nSubject: " ^ subject ^ "\n\n" ^ body
  in
Stephane Glondu's avatar
Stephane Glondu committed
235 236
  let sendmail = "/usr/sbin/sendmail" in
  Lwt_process.pwrite (sendmail, [|sendmail; "-f"; from; to_|]) contents
237 238 239 240 241 242 243 244

let split_identity x =
  let n = String.length x in
  try
    let i = String.index x ',' in
    String.sub x 0 i, String.sub x (i+1) (n-i-1)
  with Not_found ->
    x, x