web_main.ml 5.07 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
  | Element ("main-election", ["uuid", uuid], []) ->
Stephane Glondu's avatar
Stephane Glondu committed
63
    (match  Uuidm.of_string uuid with
64
    | Some u -> main_election_uuid := Some (Uuidm.to_string u)
Stephane Glondu's avatar
Stephane Glondu committed
65
66
    | None -> failwith "Incorrect UUID in configuration <main-election> tag"
    )
67
68
69
70
71
72
73
74
  | 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
75

Stephane Glondu's avatar
Stephane Glondu committed
76
(** Parse configuration from other sources *)
77

Stephane Glondu's avatar
Stephane Glondu committed
78
79
80
81
82
83
84
85
86
let ( / ) = Filename.concat

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

87
88
89
90
91
92
93
94
95
96
97
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
    return ({
      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
98
      f_voters = path/"voters.txt";
99
100
    }, item.datadir_featured)
  )
Stephane Glondu's avatar
Stephane Glondu committed
101

102
103
104
105
106
107
108
109
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
110
    )
111
  | None -> failwith "missing <source> in configuration"
Stephane Glondu's avatar
Stephane Glondu committed
112

113
114
115
116
117
let spool_dir =
  match !spool_dir with
  | Some d -> d
  | None -> failwith "missing <spool> in configuration"

118
(** Build up the site *)
Stephane Glondu's avatar
Stephane Glondu committed
119

120
121
let () = Web_site.source_file := source_file
let () = Web_site.spool_dir := spool_dir
Stephane Glondu's avatar
Stephane Glondu committed
122
let () = Web_site_auth.configure (List.rev !auth_instances)
123

Stephane Glondu's avatar
Stephane Glondu committed
124
lwt () =
125
126
127
  Lwt_list.iter_s (fun dir ->
    read_election_dir dir >>=
    Lwt_list.iter_s (fun (f, featured) ->
128
      match_lwt Web_site.import_election f with
129
      | None ->
130
        Ocsigen_messages.debug (fun () ->
131
132
          Printf.sprintf "Ignored: %s" f.f_election
        ); return ()
133
      | Some w ->
134
135
136
        let module W = (val w : REGISTRABLE_ELECTION) in
        lwt w = W.register () in
        let module W = (val w : WEB_ELECTION) in
137
138
        if featured then (
          let uuid = Uuidm.to_string W.election.e_params.e_uuid in
139
          Web_persist.add_featured_election uuid
140
        ) else return ()
141
142
143
144
145
    )
  ) !import_dirs

lwt () =
  match !main_election_uuid with
146
  | Some uuid -> Web_persist.set_main_election uuid
147
  | _ -> return ()