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