web_common.ml 7.82 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2016 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
24
open Common
25
open Serializable_builtin_t
26 27
open Web_serializable_builtin_t
open Web_serializable_j
28

29
let spool_dir = ref "."
30
let server_mail = ref "noreply@example.org"
31
let return_path = ref None
32
let contact_uri = ref None
33

Stephane Glondu's avatar
Stephane Glondu committed
34
module LwtRandom = struct
35 36 37 38 39 40

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

Stephane Glondu's avatar
Stephane Glondu committed
41 42
  let prng = lazy (pseudo_rng (random_string secure_rng 16))

43
  let random q =
44
    let size = bytes_to_sample q in
Stephane Glondu's avatar
Stephane Glondu committed
45
    let%lwt rng = Lwt_preemptive.detach Lazy.force prng in
46
    let r = random_string rng size in
47 48 49 50
    return Z.(of_bits r mod q)

end

51
type error =
52 53 54 55 56 57 58 59
  | Serialization of exn
  | ProofCheck
  | ElectionClosed
  | MissingCredential
  | InvalidCredential
  | RevoteNotAllowed
  | ReusedCredential
  | WrongCredential
60 61
  | UsedCredential
  | CredentialNotFound
62
  | UnauthorizedVoter
63 64 65 66 67 68 69 70 71 72 73 74 75 76

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"
77
  | WrongCredential -> "you are not allowed to vote with this credential"
78 79
  | UsedCredential -> "the credential has already been used"
  | CredentialNotFound -> "the credential has not been found"
80
  | UnauthorizedVoter -> "you are not allowed to vote"
81

82 83 84
let security_logfile = ref None

let open_security_log f =
85
  let%lwt () =
86 87 88 89
    match !security_logfile with
      | Some ic -> Lwt_io.close ic
      | None -> return ()
  in
90
  let%lwt ic = Lwt_io.(
91 92 93 94 95 96 97 98 99 100 101 102
    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 (
103
        string_of_datetime (now ())
104 105 106 107 108 109
      ) >>
      Lwt_io.write ic ": " >>
      Lwt_io.write_line ic (s ()) >>
      Lwt_io.flush ic
    ) ic

110
let fail_http status =
111
  [%lwt raise (
112 113
    Ocsigen_extensions.Ocsigen_http_error
      (Ocsigen_cookies.empty_cookieset, status)
114
  )]
115

116
let forbidden () = fail_http 403
117 118 119 120 121 122 123 124 125 126 127 128 129

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
130

131 132 133
type election_file =
  | ESRaw
  | ESKeys
134
  | ESTParams
135 136
  | ESCreds
  | ESBallots
137
  | ESVoters
138
  | ESRecords
139
  | ESETally
140
  | ESResult
141 142 143 144

let election_file_of_string = function
  | "election.json" -> ESRaw
  | "public_keys.jsons" -> ESKeys
145
  | "threshold.json" -> ESTParams
146 147 148
  | "public_creds.txt" -> ESCreds
  | "ballots.jsons" -> ESBallots
  | "records" -> ESRecords
149
  | "voters.txt" -> ESVoters
150
  | "encrypted_tally.json" -> ESETally
151
  | "result.json" -> ESResult
152 153 154 155 156
  | x -> invalid_arg ("election_dir_item: " ^ x)

let string_of_election_file = function
  | ESRaw -> "election.json"
  | ESKeys -> "public_keys.jsons"
157
  | ESTParams -> "threshold.json"
158 159 160
  | ESCreds -> "public_creds.txt"
  | ESBallots -> "ballots.jsons"
  | ESRecords -> "records"
161
  | ESVoters -> "voters.txt"
162
  | ESETally -> "encrypted_tally.json"
163
  | ESResult -> "result.json"
164 165 166 167

let election_file = Eliom_parameter.user_type
  ~of_string:election_file_of_string
  ~to_string:string_of_election_file
168 169

let uuid =
170
  Eliom_parameter.user_type ~of_string:uuid_of_raw_string ~to_string:raw_string_of_uuid
171 172 173 174 175

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

let random_char () =
176
  let%lwt rng =
177 178 179 180 181
    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])

182 183
let generate_token ?(length=14) () =
  let res = Bytes.create length in
184
  let rec loop i =
185
    if i < length then (
186
      let%lwt digit = random_char () in
187
      let digit = digit mod 58 in
188
      Bytes.set res i b58_digits.[digit];
189
      loop (i+1)
190
    ) else return (Bytes.to_string res)
191
  in loop 0
192 193 194

let string_of_user {user_domain; user_name} =
  user_domain ^ ":" ^ user_name
195 196

let underscorize x =
197
  String.map (function '-' -> '_' | c -> c) (raw_string_of_uuid x)
198

199 200 201 202 203 204 205
let sendmail ?return_path message =
  let mailer =
    match return_path with
    | None -> None
    | Some x -> Some (Printf.sprintf "/usr/lib/sendmail -f %s" x) in
  Netsendmail.sendmail ?mailer message

206
let send_email recipient subject body =
207
  let contents =
208
    Netsendmail.compose
209
      ~from_addr:("Belenios public server", !server_mail)
210
      ~to_addrs:[recipient, recipient]
211 212
      ~in_charset:`Enc_utf8 ~out_charset:`Enc_utf8
      ~subject body
213
  in
214 215
  let return_path = !return_path in
  let sendmail = sendmail ?return_path in
216
  let rec loop () =
217
    try%lwt
218
      Lwt_preemptive.detach sendmail contents
219 220 221
    with Unix.Unix_error (Unix.EAGAIN, _, _) ->
      Lwt_unix.sleep 1. >> loop ()
  in loop ()
222 223 224 225 226 227 228 229

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
Stephane Glondu's avatar
Stephane Glondu committed
230

231
let available_languages = ["en"; "fr"; "de"; "ro"; "it"]
232 233 234

let get_languages xs =
  match xs with
235
  | None -> ["en"]
236 237 238 239 240 241
  | Some xs -> xs

let string_of_languages xs =
  String.concat " " (get_languages xs)

let languages_of_string x =
242
  Pcre.split x
243 244 245 246 247 248 249 250

let email_rex = Pcre.regexp
  ~flags:[`CASELESS]
  "^[A-Z0-9._%+-]+@[A-Z0-9.-]+\\.[A-Z]{2,7}$"

let is_email x =
  try ignore (Pcre.pcre_exec ~rex:email_rex x); true
  with Not_found -> false
251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270

let get_fname uuid x =
  match uuid with
  | None -> x
  | Some uuid ->
     let ( / ) = Filename.concat in
     !spool_dir / raw_string_of_uuid uuid / x

let read_file ?uuid x =
  try%lwt
    let%lwt lines = Lwt_io.lines_of_file (get_fname uuid x) |> Lwt_stream.to_list in
    return (Some lines)
  with _ -> return_none

let write_file ?uuid x lines =
  Lwt_io.(
    with_file Output (get_fname uuid x) (fun oc ->
        Lwt_list.iter_s (write_line oc) lines
      )
  )
271 272

let default_contact = "Name <user@example.org>"