templates.ml 10.2 KB
Newer Older
Stephane Glondu's avatar
Stephane Glondu committed
1
open Util
2
open Serializable_t
Stephane Glondu's avatar
Stephane Glondu committed
3
4
open Eliom_content.Html5.F

Stephane Glondu's avatar
Stephane Glondu committed
5
(* TODO: these pages should be redesigned *)
Stephane Glondu's avatar
Stephane Glondu committed
6

Stephane Glondu's avatar
Stephane Glondu committed
7
8
let site_title = "Election Server"
let welcome_message = "Welcome!"
Stephane Glondu's avatar
Stephane Glondu committed
9

Stephane Glondu's avatar
Stephane Glondu committed
10
let format_user u =
Stephane Glondu's avatar
Stephane Glondu committed
11
  em [pcdata (Web_common.string_of_user u)]
Stephane Glondu's avatar
Stephane Glondu committed
12

13
let base ~auth_systems ~title ~content =
14
  lwt user = Eliom_reference.get Services.user in
Stephane Glondu's avatar
Stephane Glondu committed
15
  Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang "en"]
Stephane Glondu's avatar
Stephane Glondu committed
16
    (head (Eliom_content.Html5.F.title (pcdata title)) [])
Stephane Glondu's avatar
Stephane Glondu committed
17
    (body [
Stephane Glondu's avatar
Stephane Glondu committed
18
      div ~a:[a_id "header"] [
Stephane Glondu's avatar
Stephane Glondu committed
19
        div [
20
          div ~a:[a_style "float: left;"] [
Stephane Glondu's avatar
Stephane Glondu committed
21
22
            a ~service:Services.home [pcdata site_title] ();
          ];
23
          div ~a:[a_style "float: right; text-align: right;"] (
Stephane Glondu's avatar
Stephane Glondu committed
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
            match user with
            | Some user ->
              [
                div [
                  pcdata "Logged in as ";
                  format_user user;
                  pcdata ".";
                ];
                div [
                  a ~service:Services.logout [pcdata "Log out"] ();
                  pcdata ".";
                ];
              ]
            | None ->
              [
                div [
                  pcdata "Not logged in.";
                ];
42
43
                let auth_systems = List.map (fun (name, service) ->
                  a ~service [pcdata name] ()
44
                ) auth_systems in
45
46
47
48
49
                div (
                  [ pcdata "Login: " ] @
                  list_join (pcdata ", ") auth_systems @
                  [ pcdata "." ]
                );
Stephane Glondu's avatar
Stephane Glondu committed
50
51
              ]
          );
52
          div ~a:[a_style "clear: both;"] [];
Stephane Glondu's avatar
Stephane Glondu committed
53
        ];
Stephane Glondu's avatar
Stephane Glondu committed
54
      ];
Stephane Glondu's avatar
Stephane Glondu committed
55
      div ~a:[a_id "content"] content;
Stephane Glondu's avatar
Stephane Glondu committed
56
57
58
59
60
61
      hr ();
      div ~a:[a_id "footer"; a_style "text-align: center;" ] [
        pcdata "Powered by ";
        a ~service:Services.source_code [pcdata "Belenios"] ();
        pcdata ".";
      ]
Stephane Glondu's avatar
Stephane Glondu committed
62
     ]))
Stephane Glondu's avatar
Stephane Glondu committed
63

Stephane Glondu's avatar
Stephane Glondu committed
64
65
66
67
68
69
70
71
72
73
74
type answer = {
  count : int;
  answer : string;
  winner : bool;
}

type question = {
  answers : answer list;
  question : string;
}

75
let format_election_result e r =
76
  let open Services in
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
  Array.mapi (fun i q ->
    let q' = e.e_questions.(i) in
    let question = q'.q_question in
    let answers = Array.mapi (fun j a ->
      let answer = q'.q_answers.(j) in
      let count = a in
      (answer, count)
    ) q |> Array.to_list
    in
    let (winners, _) = List.fold_left
      (fun (ws, v) ((_, c) as w) ->
        if c > v then ([w], c)
        else if c = v then (w::ws, v)
        else (ws, v)
      ) ([], 0) answers
    in
    let answers = List.map
      (fun ((answer, count) as x) ->
        let winner = List.memq x winners in
        { answer; count; winner }
      ) answers
    in
    { question; answers }
100
  ) r.result |>
101
  Array.to_list
102

103
let format_one_featured_election e =
Stephane Glondu's avatar
Stephane Glondu committed
104
105
  li [
    h3 [
Stephane Glondu's avatar
Stephane Glondu committed
106
      a ~service:Services.(preapply_uuid election_index e)
107
        [pcdata e.Web_common.params.e_name] ();
Stephane Glondu's avatar
Stephane Glondu committed
108
    ];
109
    p [pcdata e.Web_common.params.e_description];
110
111
  ]

112
let index ~auth_systems ~featured =
113
  lwt user = Eliom_reference.get Services.user in
Stephane Glondu's avatar
Stephane Glondu committed
114
115
116
117
118
119
120
121
122
123
124
125
126
127
  let featured_box = match featured with
    | _::_ ->
      div [
        h2 [pcdata "Current featured elections"];
        ul (List.map format_one_featured_election featured);
      ]
    | [] ->
      div [
        pcdata "No featured elections at the moment.";
      ]
  in
  let content = [
    h1 [pcdata site_title];
    div [
Stephane Glondu's avatar
Stephane Glondu committed
128
129
      pcdata welcome_message;
      featured_box;
Stephane Glondu's avatar
Stephane Glondu committed
130
131
    ];
  ] in
132
  base ~auth_systems ~title:site_title ~content
Stephane Glondu's avatar
Stephane Glondu committed
133

Stephane Glondu's avatar
Stephane Glondu committed
134
let dummy_login ~service =
Stephane Glondu's avatar
Stephane Glondu committed
135
  let form = post_form ~service
Stephane Glondu's avatar
Stephane Glondu committed
136
    (fun name ->
Stephane Glondu's avatar
Stephane Glondu committed
137
138
139
      [
        tablex [tbody [
          tr [
Stephane Glondu's avatar
Stephane Glondu committed
140
141
            th [label ~a:[a_for name] [pcdata "Username:"]];
            td [string_input ~a:[a_maxlength 50] ~input_type:`Text ~name ()];
Stephane Glondu's avatar
Stephane Glondu committed
142
143
144
145
146
147
          ]]
        ];
        div [
          string_input ~input_type:`Submit ~value:"Login" ();
        ]
      ]) ()
Stephane Glondu's avatar
Stephane Glondu committed
148
149
150
151
152
153
  in
  let content = [
    h1 [pcdata "Login"];
    form;
  ] in
  base ~title:"Login" ~content
Stephane Glondu's avatar
Stephane Glondu committed
154

Stephane Glondu's avatar
Stephane Glondu committed
155
156
157
let format_date (date, _) =
  CalendarLib.Printer.Precise_Fcalendar.sprint "%a, %d %b %Y %T %z" date

Stephane Glondu's avatar
Stephane Glondu committed
158
159
160
161
162
163
164
let make_button ~service contents =
  let uri = Eliom_uri.make_string_uri ~service () in
  Printf.ksprintf unsafe_data (* FIXME: unsafe *)
    "<button onclick=\"location.href='%s';\">%s</button>"
    uri
    contents

165
let election_view ~auth_systems ~election ~user =
166
167
  let module X = (val election : Web_common.WEB_ELECTION) in
  let election = X.data in
168
  let service = Services.(preapply_uuid election_raw election) in
Stephane Glondu's avatar
Stephane Glondu committed
169
  lwt permissions =
Stephane Glondu's avatar
Stephane Glondu committed
170
    let open Web_common in
Stephane Glondu's avatar
Stephane Glondu committed
171
172
173
174
175
176
177
    match election.can_vote with
      | Any ->
        Lwt.return [ pcdata "Anyone can vote in this election." ]
      | Restricted p ->
        match user with
          | None ->
            Lwt.return [
178
              pcdata "Log in to check if you can vote. Alternatively, you can try to vote and log in at the last moment.";
Stephane Glondu's avatar
Stephane Glondu committed
179
180
181
182
183
184
185
186
187
            ]
          | Some u ->
            lwt b = p u in
            let can = if b then pcdata "can" else pcdata "cannot" in
            Lwt.return [
              pcdata "You ";
              can;
              pcdata " vote in this election.";
            ]
188
  in
189
190
191
  let voting_period = match X.P.metadata with
    | Some m ->
      [
Stephane Glondu's avatar
Stephane Glondu committed
192
193
194
195
        pcdata "This election starts on ";
        em [pcdata (format_date m.e_voting_starts_at)];
        pcdata " and ends on ";
        em [pcdata (format_date m.e_voting_ends_at)];
196
197
198
199
200
201
202
        pcdata ".";
      ]
    | None ->
      [
        pcdata "This election starts and ends at the administrator's discretion."
      ]
  in
Stephane Glondu's avatar
Stephane Glondu committed
203
  let audit_info = div [
Stephane Glondu's avatar
Stephane Glondu committed
204
    h3 [pcdata "Audit Info"];
Stephane Glondu's avatar
Stephane Glondu committed
205
    div [
Stephane Glondu's avatar
Stephane Glondu committed
206
      div [
Stephane Glondu's avatar
Stephane Glondu committed
207
        pcdata "Election fingerprint: ";
Stephane Glondu's avatar
Stephane Glondu committed
208
        code [ pcdata election.Web_common.fingerprint ];
Stephane Glondu's avatar
Stephane Glondu committed
209
      ];
Stephane Glondu's avatar
Stephane Glondu committed
210
      div [
Stephane Glondu's avatar
Stephane Glondu committed
211
212
213
        pcdata "Election data: ";
        a ~service [ pcdata "parameters" ] ();
        pcdata ", ";
214
215
216
217
        a ~service:Services.(preapply_uuid election_public_creds election) [
          pcdata "public credentials"
        ] ();
        pcdata ", ";
Stephane Glondu's avatar
Stephane Glondu committed
218
219
220
221
        a ~service:Services.(preapply_uuid election_public_keys election) [
          pcdata "trustee public keys"
        ] ();
        pcdata ", ";
222
        a ~service:Services.(preapply_uuid election_ballots election) [
Stephane Glondu's avatar
Stephane Glondu committed
223
          pcdata "ballots";
Stephane Glondu's avatar
Stephane Glondu committed
224
        ] ();
Stephane Glondu's avatar
Stephane Glondu committed
225
        pcdata ".";
Stephane Glondu's avatar
Stephane Glondu committed
226
      ];
Stephane Glondu's avatar
Stephane Glondu committed
227
228
    ]
  ] in
Stephane Glondu's avatar
Stephane Glondu committed
229
  let content = [
230
    h1 [ pcdata election.Web_common.params.e_name ];
Stephane Glondu's avatar
Stephane Glondu committed
231
    p ~a:[a_style "margin: 1em; padding: 2pt; font-style: italic; border: 1pt solid;"] [
232
      pcdata election.Web_common.params.e_description
Stephane Glondu's avatar
Stephane Glondu committed
233
    ];
234
    p voting_period;
Stephane Glondu's avatar
Stephane Glondu committed
235
    p permissions;
236
    div [
Stephane Glondu's avatar
Stephane Glondu committed
237
      div [
Stephane Glondu's avatar
Stephane Glondu committed
238
239
240
        make_button
          ~service:(Services.(preapply_uuid election_vote election))
          "Go to the booth";
241
        pcdata " or ";
Stephane Glondu's avatar
Stephane Glondu committed
242
243
244
        make_button
          ~service:(Services.(preapply_uuid election_cast election))
          "Submit a raw ballot";
245
246
      ];
    ];
Stephane Glondu's avatar
Stephane Glondu committed
247
    br ();
Stephane Glondu's avatar
Stephane Glondu committed
248
    audit_info;
Stephane Glondu's avatar
Stephane Glondu committed
249
  ] in
250
  base ~auth_systems ~title:election.Web_common.params.e_name ~content
Stephane Glondu's avatar
Stephane Glondu committed
251

252
253
254
let election_cast_raw ~election =
  let module X = (val election : Web_common.WEB_ELECTION) in
  let election = X.data in
Stephane Glondu's avatar
Stephane Glondu committed
255
256
  let form_rawballot = post_form ~service:Services.election_cast_post
    (fun (name, _) ->
257
258
259
260
261
      [
        div [pcdata "Please paste your raw ballot in JSON format in the following box:"];
        div [textarea ~a:[a_rows 10; a_cols 40] ~name ()];
        div [string_input ~input_type:`Submit ~value:"Submit" ()];
      ]
262
    ) election.Web_common.params.e_uuid
263
  in
Stephane Glondu's avatar
Stephane Glondu committed
264
265
266
267
268
269
270
271
272
273
  let form_upload = post_form ~service:Services.election_cast_post
    (fun (_, name) ->
      [
        div [pcdata "Alternatively, you can also upload a file containing your ballot:"];
        div [
          pcdata "File: ";
          file_input ~name ();
        ];
        div [string_input ~input_type:`Submit ~value:"Submit" ()];
      ]
274
    ) election.Web_common.params.e_uuid
Stephane Glondu's avatar
Stephane Glondu committed
275
  in
276
  let content = [
277
    h1 [ pcdata election.Web_common.params.e_name ];
Stephane Glondu's avatar
Stephane Glondu committed
278
279
280
281
    h3 [ pcdata "Submit by copy/paste" ];
    form_rawballot;
    h3 [ pcdata "Submit by file" ];
    form_upload;
282
  ] in
283
  base ~title:election.Web_common.params.e_name ~content
284

285
let ballot_received ~election ~confirm ~user ~can_vote =
286
  let name = election.Web_common.params.e_name in
Stephane Glondu's avatar
Stephane Glondu committed
287
  let user_div = match user with
288
    | Some u when can_vote ->
Stephane Glondu's avatar
Stephane Glondu committed
289
290
291
292
293
294
295
296
297
      let service = confirm () in
      post_form ~service (fun () -> [
        div [
          pcdata "I am ";
          format_user u;
          pcdata " and ";
          string_input ~input_type:`Submit ~value:"I confirm my vote" ();
          pcdata ".";
        ]
298
      ]) election.Web_common.params.e_uuid
299
300
301
302
    | Some _ ->
      div [
        pcdata "You cannot vote in this election!";
      ]
Stephane Glondu's avatar
Stephane Glondu committed
303
304
305
306
307
    | None ->
      div [
        pcdata "Please log in to confirm your vote.";
      ]
  in
Stephane Glondu's avatar
Stephane Glondu committed
308
309
  let content = [
    h1 [ pcdata name ];
Stephane Glondu's avatar
Stephane Glondu committed
310
311
312
313
314
315
    p [
      pcdata "Your ballot for ";
      em [pcdata name];
      pcdata " has been received, but not recorded yet.";
    ];
    user_div;
316
317
318
319
320
321
    p [
      a ~service:(Services.(preapply_uuid election_index election)) [
        pcdata "Go back to election"
      ] ();
      pcdata ".";
    ];
Stephane Glondu's avatar
Stephane Glondu committed
322
323
324
325
  ] in
  base ~title:name ~content

let do_cast_ballot ~election ~result =
326
  let name = election.Web_common.params.e_name in
Stephane Glondu's avatar
Stephane Glondu committed
327
328
329
  let content = [
    h1 [ pcdata name ];
    p [
Stephane Glondu's avatar
Stephane Glondu committed
330
      pcdata "Your ballot for ";
Stephane Glondu's avatar
Stephane Glondu committed
331
      em [pcdata name];
Stephane Glondu's avatar
Stephane Glondu committed
332
      (match result with
Stephane Glondu's avatar
Stephane Glondu committed
333
         | `Valid hash -> pcdata (" has been accepted, its hash is " ^ hash ^ ".")
334
         | `Error e -> pcdata (" is rejected, because " ^ Web_common.explain_error e ^ ".")
Stephane Glondu's avatar
Stephane Glondu committed
335
      );
Stephane Glondu's avatar
Stephane Glondu committed
336
    ];
337
    p [
Stephane Glondu's avatar
Stephane Glondu committed
338
339
340
341
342
      a ~service:(Services.(preapply_uuid election_index election)) [
        pcdata "Go back to election"
      ] ();
      pcdata ".";
    ];
Stephane Glondu's avatar
Stephane Glondu committed
343
344
  ] in
  base ~title:name ~content
Stephane Glondu's avatar
Stephane Glondu committed
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361

let election_update_credential ~election =
  let module X = (val election : Web_common.WEB_ELECTION) in
  let election = X.data in
  let form = post_form ~service:Services.election_update_credential
    (fun (old, new_) ->
      [
        div [
          pcdata "Hash of the old credential: ";
          string_input ~name:old ~input_type:`Text ~a:[a_size 64] ();
        ];
        div [
          pcdata "New credential: ";
          string_input ~name:new_ ~input_type:`Text ~a:[a_size 617] ();
        ];
        div [string_input ~input_type:`Submit ~value:"Submit" ()];
      ]
362
    ) election.Web_common.params.e_uuid
Stephane Glondu's avatar
Stephane Glondu committed
363
364
  in
  let content = [
365
    h1 [ pcdata election.Web_common.params.e_name ];
Stephane Glondu's avatar
Stephane Glondu committed
366
367
    form;
  ] in
368
  base ~title:election.Web_common.params.e_name ~content