Attention une mise à jour du service Gitlab va être effectuée le mardi 30 novembre entre 17h30 et 18h00. 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. Cette mise à jour intermédiaire en version 14.0.12 nous permettra de rapidement pouvoir mettre à votre disposition une version plus récente.

web_election.ml 17.5 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
(*  Copyright © 2012-2014 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/>.                                       *)
(**************************************************************************)

open Lwt
23
open Platform
24
open Serializable_builtin_t
25 26 27
open Serializable_j
open Signatures
open Common
Stephane Glondu's avatar
Stephane Glondu committed
28
open Web_serializable_t
29
open Web_signatures
30
open Web_common
31
open Web_services
32

33 34
let ( / ) = Filename.concat

35 36 37
let can_read m user =
  match m.e_readers with
  | None -> false
38
  | Some acl ->
39
    match user with
40 41
    | None -> acl = `Any (* readers can be anonymous *)
    | Some u -> check_acl (Some acl) u
42 43 44 45

let can_vote m user =
  match m.e_voters with
  | None -> false
46
  | Some acl ->
47 48
    match user with
    | None -> false (* voters must log in *)
49
    | Some u -> check_acl (Some acl) u
50

Stephane Glondu's avatar
Stephane Glondu committed
51
module type REGISTRATION = sig
52
  module W : WEB_ELECTION_
53
  module Register (X : EMPTY) : ELECTION_HANDLERS
Stephane Glondu's avatar
Stephane Glondu committed
54 55
end

56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
module type REGISTRABLE = sig
  module W : sig
    include ELECTION_DATA
    include WEB_PARAMS
    module E : ELECTION with type elt = G.t
  end
  module Register (X : EMPTY) : REGISTRATION
end

module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct

  module W = struct
    include D
    include P
    module M = MakeLwtRandom(struct let rng = make_rng () end)
    module E = Election.MakeElection(G)(M)
  end

  module Register (X : EMPTY) : REGISTRATION = struct
75

76
    let uuid = Uuidm.to_string D.election.e_params.e_uuid
77 78 79 80 81
    let base_path = ["elections"; uuid]

    module N = struct
      let name = uuid
      let path = base_path
82
      let kind = `Election P.dir
Stephane Glondu's avatar
Stephane Glondu committed
83 84

      let auth_config =
85
        match P.metadata.e_auth_config with
Stephane Glondu's avatar
Stephane Glondu committed
86 87
        | None -> []
        | Some xs -> xs
88 89 90 91
    end

    module Auth = Web_auth.Make (N)

92 93 94
    module W = struct
      include W

Stephane Glondu's avatar
Stephane Glondu committed
95 96 97 98 99
      module B : WEB_BALLOT_BOX = struct

        let suffix = "_" ^ String.map (function
          | '-' -> '_'
          | c -> c
Stephane Glondu's avatar
Stephane Glondu committed
100
        ) uuid
Stephane Glondu's avatar
Stephane Glondu committed
101 102 103 104 105 106 107 108 109 110 111 112

        module Ballots = struct
          type 'a m = 'a Lwt.t
          type elt = string
          type key = string
          let table = Ocsipersist.open_table ("ballots" ^ suffix)
          let cardinal = Ocsipersist.length table
          let fold f x = Ocsipersist.fold_step f table x
        end

        module Records = struct
          type 'a m = 'a Lwt.t
113
          type elt = datetime * string
Stephane Glondu's avatar
Stephane Glondu committed
114 115 116 117 118 119 120 121
          type key = string
          let table = Ocsipersist.open_table ("records" ^ suffix)
          let cardinal = Ocsipersist.length table
          let fold f x = Ocsipersist.fold_step f table x
        end

        let cred_table = Ocsipersist.open_table ("creds" ^ suffix)

122 123
        let inject_cred cred =
          try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
124
            lwt _ = Ocsipersist.find cred_table cred in
125 126 127
            failwith "trying to add duplicate credential"
          with Not_found ->
            Ocsipersist.add cred_table cred None
128

Stephane Glondu's avatar
Stephane Glondu committed
129 130 131 132
        let do_cast rawballot (user, date) =
          let voting_open =
            let compare a b =
              match a, b with
133
              | Some a, Some b -> datetime_compare a b
Stephane Glondu's avatar
Stephane Glondu committed
134 135 136 137
              | _, _ -> -1
            in
            compare metadata.e_voting_starts_at (Some date) <= 0 &&
            compare (Some date) metadata.e_voting_ends_at < 0
Stephane Glondu's avatar
Stephane Glondu committed
138
          in
Stephane Glondu's avatar
Stephane Glondu committed
139 140 141 142 143
          if not voting_open then fail ElectionClosed else return () >>
          if String.contains rawballot '\n' then (
            fail (Serialization (Invalid_argument "multiline ballot"))
          ) else return () >>
          lwt ballot =
144
            try Lwt.return (ballot_of_string G.read rawballot)
145
            with e -> fail (Serialization e)
Stephane Glondu's avatar
Stephane Glondu committed
146 147 148
          in
          lwt credential =
            match ballot.signature with
149
              | Some s -> Lwt.return (G.to_string s.s_public_key)
Stephane Glondu's avatar
Stephane Glondu committed
150 151 152 153 154 155 156 157 158 159 160 161 162 163
              | None -> fail MissingCredential
          in
          lwt old_cred =
            try_lwt Ocsipersist.find cred_table credential
            with Not_found -> fail InvalidCredential
          and old_record =
            try_lwt
              lwt x = Ocsipersist.find Records.table user in
              Lwt.return (Some x)
            with Not_found -> Lwt.return None
          in
          match old_cred, old_record with
            | None, None ->
              (* first vote *)
164 165 166 167 168 169 170 171 172 173 174
              if E.check_ballot election ballot then (
                let hash = sha256_b64 rawballot in
                Ocsipersist.add cred_table credential (Some hash) >>
                Ocsipersist.add Ballots.table hash rawballot >>
                Ocsipersist.add Records.table user (date, credential) >>
                security_log (fun () ->
                  Printf.sprintf "%s successfully cast ballot %s" user hash
                ) >> return hash
              ) else (
                fail ProofCheck
              )
Stephane Glondu's avatar
Stephane Glondu committed
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
            | Some h, Some (_, old_credential) ->
              (* revote *)
              if credential = old_credential then (
                if E.check_ballot election ballot then (
                  lwt old_ballot = Ocsipersist.find Ballots.table h in
                  Ocsipersist.remove Ballots.table h >>
                  security_log (fun () ->
                    Printf.sprintf "%s successfully removed ballot %S" user old_ballot
                  ) >>
                  let hash = sha256_b64 rawballot in
                  Ocsipersist.add cred_table credential (Some hash) >>
                  Ocsipersist.add Ballots.table hash rawballot >>
                  Ocsipersist.add Records.table user (date, credential) >>
                  security_log (fun () ->
                    Printf.sprintf "%s successfully cast ballot %s" user hash
                  ) >> return hash
                ) else (
                  fail ProofCheck
                )
              ) else (
                security_log (fun () ->
                  Printf.sprintf "%s attempted to revote with already used credential %s" user credential
                ) >> fail WrongCredential
              )
            | None, Some _ ->
200
              security_log (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
                Printf.sprintf "%s attempted to revote using a new credential %s" user credential
              ) >> fail RevoteNotAllowed
            | Some _, None ->
              security_log (fun () ->
                Printf.sprintf "%s attempted to vote with already used credential %s" user credential
              ) >> fail ReusedCredential

        let do_update_cred ~old ~new_ =
          match_lwt Ocsipersist.fold_step (fun k v x ->
            if sha256_hex k = old then (
              match v with
                | Some _ -> fail UsedCredential
                | None -> return (Some k)
            ) else return x
          ) cred_table None with
          | None -> fail CredentialNotFound
          | Some x ->
            Ocsipersist.remove cred_table x >>
            Ocsipersist.add cred_table new_ None

221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
        let do_write f =
          Lwt_io.(with_file ~mode:Output (dir / string_of_election_file f))

        let do_write_ballots () =
          do_write ESBallots (fun oc ->
            Ocsipersist.iter_step (fun _ x ->
              Lwt_io.write_line oc x
            ) Ballots.table
          )

        let do_write_creds () =
          do_write ESCreds (fun oc ->
            Ocsipersist.iter_step (fun x _ ->
              Lwt_io.write_line oc x
            ) cred_table
          )

        let do_write_records () =
          do_write ESRecords (fun oc ->
            Ocsipersist.iter_step (fun u (d, _) ->
              Printf.sprintf "%s %S\n" (string_of_datetime d) u |>
              Lwt_io.write oc
            ) Records.table
          )

Stephane Glondu's avatar
Stephane Glondu committed
246 247 248
        let mutex = Lwt_mutex.create ()

        let cast rawballot (user, date) =
249 250 251 252 253 254
          Lwt_mutex.with_lock mutex (fun () ->
            lwt r = do_cast rawballot (user, date) in
            do_write_ballots () >>
            do_write_records () >>
            return r
          )
Stephane Glondu's avatar
Stephane Glondu committed
255 256

        let update_cred ~old ~new_ =
257 258 259 260 261 262 263 264 265 266 267
          Lwt_mutex.with_lock mutex (fun () ->
            lwt r = do_update_cred ~old ~new_ in
            do_write_creds () >> return r
          )

        let update_files () =
          Lwt_mutex.with_lock mutex (fun () ->
            do_write_ballots () >>
            do_write_records () >>
            do_write_creds ()
          )
268

Stephane Glondu's avatar
Stephane Glondu committed
269
      end
270

Stephane Glondu's avatar
Stephane Glondu committed
271
      module S = Auth.Services
272 273 274

    end

275
    module Register (X : EMPTY) : ELECTION_HANDLERS = struct
276 277
      open Eliom_registration

278
      module L = struct
279 280
        let login x = Eliom_service.preapply election_login ((W.election.e_params.e_uuid, ()), x)
        let logout = Eliom_service.preapply election_logout (W.election.e_params.e_uuid, ())
281 282
      end

283
      let () =
284
        let module T = Web_templates.Login (W.S) (L) in
285 286 287 288
        let templates = (module T : LOGIN_TEMPLATES) in
        Auth.register templates N.auth_config

      let login service () =
289
        lwt cont = Eliom_reference.get Web_services.cont in
290 291 292
        Auth.Handlers.do_login service cont ()

      let logout () () =
293
        lwt cont = Eliom_reference.get Web_services.cont in
294
        Auth.Handlers.do_logout cont ()
295

296
      module T = Web_templates
297

Stephane Glondu's avatar
Stephane Glondu committed
298
      let if_eligible acl f () x =
299
        lwt user = W.S.get_user () in
300
        if acl W.metadata user then
Stephane Glondu's avatar
Stephane Glondu committed
301 302 303 304
          f user x
        else
          forbidden ()

Stephane Glondu's avatar
Stephane Glondu committed
305 306 307 308
      let scope = Eliom_common.default_session_scope

      let ballot = Eliom_reference.eref ~scope None
      let cast_confirmed = Eliom_reference.eref ~scope None
Stephane Glondu's avatar
Stephane Glondu committed
309

310
      let home =
Stephane Glondu's avatar
Stephane Glondu committed
311
        (if_eligible can_read
312
           (fun user () ->
313
             Eliom_reference.unset ballot >>
314 315 316
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
317
                    election_home (W.election.e_params.e_uuid, ()))
318
             in
319
             Eliom_reference.set Web_services.cont cont >>
Stephane Glondu's avatar
Stephane Glondu committed
320 321 322
             match_lwt Eliom_reference.get cast_confirmed with
             | Some result ->
               Eliom_reference.unset cast_confirmed >>
323 324
               T.cast_confirmed (module W) ~result () >>= Html5.send
             | None -> T.election_home (module W) () >>= Html5.send
325
           )
326 327
        )

328
      let admin site_user is_featured =
329
        (fun () () ->
330
          match site_user with
331
          | Some u when W.metadata.e_owner = Some u ->
332
            T.election_admin (module W) ~is_featured () >>= Html5.send
333 334 335
          | _ -> forbidden ()
        )

336 337 338
      let content_type_of_file = function
        | ESRaw | ESKeys | ESBallots -> "application/json"
        | ESCreds | ESRecords -> "text/plain"
339

340
      let handle_pseudo_file u f site_user =
341 342
        lwt () =
          if f = ESRecords then (
343
            match site_user with
344 345
            | Some u when W.metadata.e_owner = Some u -> return ()
            | _ -> forbidden ()
346
          ) else return ()
347
        in
348 349
        let content_type = content_type_of_file f in
        File.send ~content_type (W.dir / string_of_election_file f)
350

351
      let election_dir site_user =
352
        (fun f () ->
Stephane Glondu's avatar
Stephane Glondu committed
353 354
          let cont () () =
            Redirection.send
355
              (Eliom_service.preapply
356
                 election_dir
357
                 (W.election.e_params.e_uuid, f))
Stephane Glondu's avatar
Stephane Glondu committed
358
          in
359
          Eliom_reference.set Web_services.cont cont >>
360
          handle_pseudo_file () f site_user
361 362
        )

363
      let election_update_credential site_user =
Stephane Glondu's avatar
Stephane Glondu committed
364
        (fun () () ->
365
          match site_user with
366
          | Some u ->
367
            if W.metadata.e_owner = Some u then (
368
              T.update_credential (module W) () >>= Html5.send
369 370 371 372 373 374
            ) else (
              forbidden ()
            )
          | _ -> forbidden ()
        )

375
      let election_update_credential_post site_user =
Stephane Glondu's avatar
Stephane Glondu committed
376
        (fun () (old, new_) ->
377
          match site_user with
378
          | Some u ->
379
            if W.metadata.e_owner = Some u then (
380
              try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
381
                W.B.update_cred ~old ~new_ >>
382
                String.send ("OK", "text/plain")
383
              with Error e ->
384 385 386
                String.send ("Error: " ^ explain_error e, "text/plain")
            ) >>= (fun x -> return @@ cast_unknown_content_kind x)
            else (
387 388 389 390 391
              forbidden ()
            )
          | _ -> forbidden ()
        )

392
      let election_vote =
Stephane Glondu's avatar
Stephane Glondu committed
393
        (if_eligible can_read
394 395
           (fun user () ->
             Eliom_reference.unset ballot >>
396 397 398
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
399
                    election_vote (W.election.e_params.e_uuid, ()))
400
             in
401
             Eliom_reference.set Web_services.cont cont >>
402 403 404 405 406 407 408
             let uuid_s = Uuidm.to_string W.election.e_params.e_uuid in
             Redirection.send
               (Eliom_service.preapply
                  (Eliom_service.static_dir_with_params
                     ~get_params:(Eliom_parameter.string "election_url") ())
                  (["static"; "vote.html"],
                   "../elections/" ^ uuid_s ^ "/"))
409 410 411
           )
        )

412
      let election_cast_confirm () () =
413 414 415 416
        match_lwt Eliom_reference.get ballot with
        | Some the_ballot ->
          begin
            Eliom_reference.unset ballot >>
417
            match_lwt W.S.get_user () with
418
            | Some u ->
419
              let b = check_acl W.metadata.e_voters u in
420
              if b then (
421
                let record = Web_auth.string_of_user u, now () in
422 423
                lwt result =
                  try_lwt
Stephane Glondu's avatar
Stephane Glondu committed
424
                    lwt hash = W.B.cast the_ballot record in
425 426 427 428
                    return (`Valid hash)
                  with Error e -> return (`Error e)
                in
                Eliom_reference.unset ballot >>
Stephane Glondu's avatar
Stephane Glondu committed
429
                Eliom_reference.set cast_confirmed (Some result) >>
430 431 432
                Redirection.send
                  (Eliom_service.preapply
                     election_home (W.election.e_params.e_uuid, ()))
433 434 435 436 437
              ) else forbidden ()
            | None -> forbidden ()
          end
        | None -> fail_http 404

Stephane Glondu's avatar
Stephane Glondu committed
438
      let ballot_received user =
439
        let can_vote = can_vote W.metadata user in
440
        T.cast_confirmation (module W) ~can_vote ()
441

442
      let election_cast =
Stephane Glondu's avatar
Stephane Glondu committed
443
        (if_eligible can_read
444
           (fun user () ->
445 446 447
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
448
                    election_cast (W.election.e_params.e_uuid, ()))
449
             in
450
             Eliom_reference.set Web_services.cont cont >>
451
             match_lwt Eliom_reference.get ballot with
452
             | Some _ -> ballot_received user >>= Html5.send
453
             | None -> T.cast_raw (module W) () >>= Html5.send
454 455 456
           )
        )

457
      let election_cast_post =
Stephane Glondu's avatar
Stephane Glondu committed
458
        (if_eligible can_read
459 460 461 462 463 464 465 466
           (fun user (ballot_raw, ballot_file) ->
             lwt the_ballot = match ballot_raw, ballot_file with
               | Some ballot, None -> return ballot
               | None, Some fi ->
                 let fname = fi.Ocsigen_extensions.tmp_filename in
                 Lwt_stream.to_string (Lwt_io.chars_of_file fname)
               | _, _ -> fail_http 400
             in
467 468 469
             let cont () () =
               Redirection.send
                 (Eliom_service.preapply
470
                    Web_services.election_cast (W.election.e_params.e_uuid, ()))
471
             in
472
             Eliom_reference.set Web_services.cont cont >>
473 474
             Eliom_reference.set ballot (Some the_ballot) >>
             match user with
Stephane Glondu's avatar
Stephane Glondu committed
475
             | None -> Auth.Handlers.do_login None cont ()
Stephane Glondu's avatar
Stephane Glondu committed
476
             | Some u -> cont () ()
477 478 479
           )
        )

480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508
      let election_pretty_ballots start () =
        lwt user = W.S.get_user () in
        if can_read W.metadata user then (
          lwt res, _ =
            W.B.Ballots.fold
              (fun h _ (accu, i) ->
               if i >= start && i < start+50 then
                 return (h :: accu, i+1)
               else return (accu, i+1)
              ) ([], 1)
          in T.pretty_ballots (module W) res () >>= Html5.send
        ) else forbidden ()

      let election_pretty_ballot hash () =
        lwt user = W.S.get_user () in
        if can_read W.metadata user then (
          lwt ballot =
            W.B.Ballots.fold
              (fun h b accu ->
               if h = hash then return (Some b) else return accu
              ) None
          in
          match ballot with
          | None -> fail_http 404
          | Some b ->
             String.send (b, "application/json") >>=
             (fun x -> return @@ cast_unknown_content_kind x)
        ) else forbidden ()

509 510
    end

511 512
  end

513
end