web_main.ml 6.7 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/>.                                       *)
(**************************************************************************)

Stephane Glondu's avatar
Stephane Glondu committed
22
open Signatures
Stephane Glondu's avatar
Stephane Glondu committed
23
open Common
24
open Serializable_t
Stephane Glondu's avatar
Stephane Glondu committed
25
open Web_serializable_j
26
open Lwt
27
open Web_common
28
open Web_signatures
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 import_dirs = ref []
Stephane Glondu's avatar
Stephane Glondu committed
41
let source_file = ref None
Stephane Glondu's avatar
Stephane Glondu committed
42
let main_election_uuid = ref None
43
let auth_instances = ref []
44

45
let () =
46
47
48
49
50
51
52
53
54
  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
55
56
  | Element ("import", ["dir", dir], []) ->
    import_dirs := dir :: !import_dirs
57
  | Element ("rewrite-prefix", ["src", src; "dst", dst], []) ->
58
    set_rewrite_prefix ~src ~dst
59
  | Element ("main-election", ["uuid", uuid], []) ->
Stephane Glondu's avatar
Stephane Glondu committed
60
    (match  Uuidm.of_string uuid with
61
    | Some u -> main_election_uuid := Some (Uuidm.to_string u)
Stephane Glondu's avatar
Stephane Glondu committed
62
63
    | None -> failwith "Incorrect UUID in configuration <main-election> tag"
    )
64
65
  | Element ("auth", ["name", auth_instance],
             [Element (auth_system, auth_config, [])]) ->
66
    let open Web_auth in
67
68
69
70
71
72
    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
73

Stephane Glondu's avatar
Stephane Glondu committed
74
(** Parse configuration from other sources *)
75

76
77
78
79
80
81
82
83
84
85
86
87
let get_single_line x =
  match_lwt Lwt_stream.get x with
  | None -> return None
  | Some _ as line ->
    lwt b = Lwt_stream.is_empty x in
    if b then (
      return line
    ) else (
      Lwt_stream.junk_while (fun _ -> true) x >>
      return None
    )

Stephane Glondu's avatar
Stephane Glondu committed
88
89
90
91
92
93
94
95
96
let ( / ) = Filename.concat

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

97
98
99
let election_table = Ocsipersist.open_table "elections"

let import_election_dir accu dir =
100
  Ocsigen_messages.debug (fun () ->
101
    "Importing data from " ^ dir ^ "..."
102
103
104
105
106
107
  );
  lwt index =
    Lwt_io.chars_of_file (dir/"index.json") |>
    Lwt_stream.to_string >>=
    wrap1 datadir_index_of_string
  in
108
  Lwt_list.fold_left_s (fun accu item ->
109
110
111
112
113
    let subdir = item.datadir_dir in
    let path = dir/subdir in
    let params_fname = path/"election.json" in
    let public_keys_fname = path/"public_keys.jsons" in
    Ocsigen_messages.debug (fun () ->
Stephane Glondu's avatar
Stephane Glondu committed
114
      "-- loading " ^ subdir
115
116
117
118
119
120
121
122
    );
    lwt raw_election =
      Lwt_io.lines_of_file params_fname |>
      get_single_line >>=
      (function
      | Some e -> return e
      | None -> failwith "election.json is invalid")
    in
123
124
125
126
127
128
129
130
131
    let uuid =
      (election_uuid_of_string raw_election).election_uuid |>
      Uuidm.to_string
    in
    lwt exists =
      try_lwt
        lwt _ = Ocsipersist.find election_table uuid in
        return true
      with Not_found -> return false
132
    in
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
    if exists then (
      let () = Ocsigen_messages.debug (fun () ->
        "-- election already present in database, skipping"
      ) in return accu
    ) else if SMap.mem uuid accu then (
      let () = Ocsigen_messages.debug (fun () ->
        "-- duplicate election, skipping"
      ) in return accu
    ) else (
      lwt metadata =
        let fname = path/"metadata.json" in
        lwt b = file_exists fname in
        if b then (
          Lwt_io.chars_of_file fname |>
          Lwt_stream.to_string >>=
          wrap1 metadata_of_string
        ) else return empty_metadata
      in
      let public_creds_fname = path/"public_creds.txt" in
      let config = Web_election.({
        raw_election;
        metadata;
        featured = item.datadir_featured;
        params_fname;
        public_keys_fname;
      }) in
      Ocsipersist.add election_table uuid config >>
      return @@ SMap.add uuid public_creds_fname accu
    )
  ) accu index

lwt imported =
  Lwt_list.fold_left_s import_election_dir SMap.empty !import_dirs
Stephane Glondu's avatar
Stephane Glondu committed
166

167
168
169
170
171
172
173
174
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
175
    )
176
  | None -> failwith "missing <source> in configuration"
Stephane Glondu's avatar
Stephane Glondu committed
177

178
(** Build up the site *)
Stephane Glondu's avatar
Stephane Glondu committed
179

180
181
182
183
module Site_config = struct
  let name = "site"
  let path = []
  let source_file = source_file
184
  let auth_config = !auth_instances
Stephane Glondu's avatar
Stephane Glondu committed
185
186
end

187
module Site = Web_site.Make (Site_config)
188

Stephane Glondu's avatar
Stephane Glondu committed
189
lwt () =
190
  Ocsipersist.iter_step (fun uuid config ->
Stephane Glondu's avatar
Stephane Glondu committed
191
    lwt election = Site.register_election config in
192
    let module W = (val election : WEB_ELECTION) in
193
    (match !main_election_uuid with
194
    | Some u when u = uuid -> Site.set_main_election election
195
196
    | _ -> ()
    );
197
198
199
200
201
202
203
204
    try_lwt
      let public_creds_fname = SMap.find uuid imported in
      (* if the election has just been imported, inject its credentials *)
      let () =
        Ocsigen_messages.debug (fun () ->
          Printf.sprintf "Injecting credentials for %s" uuid
        )
      in
Stephane Glondu's avatar
Stephane Glondu committed
205
      Lwt_io.lines_of_file public_creds_fname |>
206
207
208
      Lwt_stream.iter_s W.B.inject_cred
    with Not_found -> return ()
  ) election_table