-
Notifications
You must be signed in to change notification settings - Fork 20
/
site_common.ml
112 lines (97 loc) · 4.28 KB
/
site_common.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2022 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
open Lwt.Syntax
open Belenios
open Belenios_server_core
open Web_common
module Make (X : Pages_sig.S) = struct
open X
open Web_services
open Eliom_service
open Eliom_registration
let get_preferred_gettext () = Web_i18n.get_preferred_gettext "voter"
let election_not_found () =
let* l = get_preferred_gettext () in
let open (val l) in
Pages_common.generic_page ~title:(s_ "Not found")
(s_
"This election does not exist. This may happen for elections that \
have not yet been open or have been deleted.")
()
>>= Html.send ~code:404
let with_election s uuid f =
Public_archive.with_election s uuid ~fallback:election_not_found f
let () =
File.register ~service:source_code ~content_type:"application/x-gzip"
(fun () () -> return !Web_config.source_file)
let () =
Any.register ~service:logo (fun () () ->
match !Web_config.logo with
| None -> fail_http `Not_found
| Some (file, content_type) -> File.send ~content_type file)
let () =
Any.register ~service:favicon (fun () () ->
match !Web_config.favicon with
| None -> fail_http `Not_found
| Some (file, content_type) -> File.send ~content_type file)
let redir_preapply s u () =
Redirection.send (Redirection (preapply ~service:s u))
let wrap_handler f =
Lwt.catch f (fun e ->
Pages_common.generic_page ~title:"Error" (Printexc.to_string e) ()
>>= Html.send)
let get_cont_state cont =
let redir =
match cont.path with
| ContSiteHome -> Redirection home
| ContSiteAdmin -> Redirection admin
| ContSiteElection uuid ->
Redirection (preapply ~service:election_home (uuid, ()))
in
fun () -> Redirection.send redir
let () =
Any.register ~service:set_consent (fun cont () ->
let () = Web_state.set_consent_cookie () in
get_cont_state cont ())
let () =
Any.register ~service:election_nh_ciphertexts (fun uuid () ->
Lwt.try_bind
(fun () ->
let@ s = Storage.with_transaction in
Public_archive.get_nh_ciphertexts s uuid)
(fun x -> String.send (x, "application/json"))
(function
| Election_not_found _ -> fail_http `Not_found | e -> Lwt.reraise e))
let () =
Any.register ~service:set_language (fun (lang, cont) () ->
let exp = Unix.gettimeofday () +. (10. *. 365. *. 86400.) in
let () =
Eliom_state.set_cookie ~exp ~name:"belenios-lang" ~value:lang ()
in
get_cont_state cont ())
let forbidden () =
let* l = get_preferred_gettext () in
let open (val l) in
let msg = s_ "You are not allowed to access this page!" in
Pages_common.generic_page ~title:(s_ "Forbidden") msg ()
>>= Html.send ~code:403
end