web_main.ml 4.5 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 23
open Lwt
open Serializable_t
Stephane Glondu's avatar
Stephane Glondu committed
24
open Signatures
Stephane Glondu's avatar
Stephane Glondu committed
25
open Common
Stephane Glondu's avatar
Stephane Glondu committed
26
open Web_serializable_j
27
open Web_signatures
28
open Web_common
Stephane Glondu's avatar
Stephane Glondu committed
29

Stephane Glondu's avatar
Stephane Glondu committed
30 31
(** Global initialization *)

32
(* FIXME: the following should be in configuration file... but
33
   <maxrequestbodysize> doesn't work *)
34
let () = Ocsigen_config.set_maxrequestbodysizeinmemory 128000
35

Stephane Glondu's avatar
Stephane Glondu committed
36
let () = CalendarLib.Time_Zone.(change Local)
37

Stephane Glondu's avatar
Stephane Glondu committed
38
(** Parse configuration from <eliom> *)
39

40
let spool_dir = ref None
41
let import_dirs = ref []
Stephane Glondu's avatar
Stephane Glondu committed
42
let source_file = ref None
Stephane Glondu's avatar
Stephane Glondu committed
43
let main_election_uuid = ref None
44
let auth_instances = ref []
45

46
let () =
47 48 49 50 51 52 53 54 55
  Eliom_config.get_config () |>
  let open Simplexmlparser in
  List.iter @@ function
  | PCData x ->
    Ocsigen_extensions.Configuration.ignore_blank_pcdata ~in_tag:"belenios" x
  | Element ("log", ["file", file], []) ->
    Lwt_main.run (open_security_log file)
  | Element ("source", ["file", file], []) ->
    source_file := Some file
56 57
  | Element ("import", ["dir", dir], []) ->
    import_dirs := dir :: !import_dirs
58 59
  | Element ("spool", ["dir", dir], []) ->
    spool_dir := Some dir
60
  | Element ("rewrite-prefix", ["src", src; "dst", dst], []) ->
61
    set_rewrite_prefix ~src ~dst
62 63 64 65 66 67 68 69
  | Element ("auth", ["name", auth_instance],
             [Element (auth_system, auth_config, [])]) ->
    let i = {auth_system; auth_instance; auth_config} in
    auth_instances := i :: !auth_instances
  | Element (tag, _, _) ->
    Printf.ksprintf failwith
      "invalid configuration for tag %s in belenios"
      tag
70

Stephane Glondu's avatar
Stephane Glondu committed
71
(** Parse configuration from other sources *)
72

Stephane Glondu's avatar
Stephane Glondu committed
73 74 75 76 77 78 79 80 81
let ( / ) = Filename.concat

let file_exists x =
  try_lwt
    Lwt_unix.(access x [R_OK]) >>
    return true
  with _ ->
    return false

82 83 84 85 86 87
let read_election_dir dir =
  Lwt_io.chars_of_file (dir/"index.json") |>
  Lwt_stream.to_string >>=
  wrap1 datadir_index_of_string >>=
  Lwt_list.map_p (fun item ->
    let path = dir/item.datadir_dir in
88
    return {
89 90 91 92
      f_election = path/"election.json";
      f_metadata = path/"metadata.json";
      f_public_keys = path/"public_keys.jsons";
      f_public_creds = path/"public_creds.txt";
Stephane Glondu's avatar
Stephane Glondu committed
93
      f_voters = path/"voters.txt";
94
    }
95
  )
Stephane Glondu's avatar
Stephane Glondu committed
96

97 98 99 100 101 102 103 104
lwt source_file =
  match !source_file with
  | Some f ->
    lwt b = file_exists f in
    if b then (
      return f
    ) else (
      Printf.ksprintf failwith "file %s does not exist" f
Stephane Glondu's avatar
Stephane Glondu committed
105
    )
106
  | None -> failwith "missing <source> in configuration"
Stephane Glondu's avatar
Stephane Glondu committed
107

108 109 110 111 112
let spool_dir =
  match !spool_dir with
  | Some d -> d
  | None -> failwith "missing <spool> in configuration"

113
(** Build up the site *)
Stephane Glondu's avatar
Stephane Glondu committed
114

115
let () = Web_site.source_file := source_file
116
let () = Web_common.spool_dir := spool_dir
Stephane Glondu's avatar
Stephane Glondu committed
117
let () = Web_site_auth.configure (List.rev !auth_instances)
118

Stephane Glondu's avatar
Stephane Glondu committed
119
lwt () =
120 121
  Lwt_list.iter_s (fun dir ->
    read_election_dir dir >>=
122
    Lwt_list.iter_s (fun f ->
123
      match_lwt Web_site.import_election f with
124
      | None ->
Stephane Glondu's avatar
Stephane Glondu committed
125
        Ocsigen_messages.console (fun () ->
126 127
          Printf.sprintf "Ignored: %s" f.f_election
        ); return ()
128
      | Some w ->
129 130
        let module W = (val w : REGISTRABLE_ELECTION) in
        lwt w = W.register () in
131
        return ()
132 133
    )
  ) !import_dirs