web_site.ml 11.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/>.                                       *)
(**************************************************************************)

22
open Lwt
23
open Serializable_j
24
open Signatures
25
open Common
Stephane Glondu's avatar
Stephane Glondu committed
26
open Web_serializable_j
27
open Web_common
28
open Web_signatures
Stephane Glondu's avatar
Stephane Glondu committed
29

30 31 32 33
module type CONFIG = sig
  val name : string
  val path : string list
  val source_file : string
34
  val spool_dir : string
35
  val auth_config : auth_config list
36
end
Stephane Glondu's avatar
Stephane Glondu committed
37

38 39 40 41
let rec list_remove x = function
  | [] -> []
  | y :: ys -> if x = y then ys else y :: (list_remove x ys)

42 43 44 45 46 47 48 49 50 51 52 53
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
    )

54
module Make (C : CONFIG) : SITE = struct
55
  open Eliom_service
Stephane Glondu's avatar
Stephane Glondu committed
56 57
  open Eliom_registration

58 59 60 61 62
  module C = struct
    include C
    let kind = `Site
  end

63 64
  let make_path x = C.path @ x

65
  module Auth = Web_auth.Make (C)
66
  module Random = MakeLwtRandom (struct let rng = make_rng () end)
Stephane Glondu's avatar
Stephane Glondu committed
67

68 69 70 71 72 73 74 75 76 77 78 79 80
  let store = Ocsipersist.open_store C.name

  (* Persistent table, used to initialize the server. *)
  let election_ptable = Ocsipersist.open_table (C.name ^ "_elections")

  (* In-memory table, indexed by UUID, contains closures. *)
  let election_table = ref SMap.empty

  lwt main_election =
    Ocsipersist.make_persistent store "main_election" None

  lwt featured =
    Ocsipersist.make_persistent store "featured_elections" []
Stephane Glondu's avatar
Stephane Glondu committed
81 82 83 84

  (* The following reference is there to cut a dependency loop:
     S.register_election depends on S (via Templates). It will be set
     to a proper value once we have called Templates.Make. *)
85

86
  let import_election_ref = ref (fun _ -> assert false)
Stephane Glondu's avatar
Stephane Glondu committed
87 88 89 90 91

  (* We use an intermediate module S that will be passed to Templates
     and Web_election. S is not meant to leak and will be included
     in the returned module later. *)

92
  module S : SITE = struct
Stephane Glondu's avatar
Stephane Glondu committed
93
    include Auth.Services
94
    include Auth.Handlers
Stephane Glondu's avatar
Stephane Glondu committed
95 96
    open Eliom_parameter

Stephane Glondu's avatar
Stephane Glondu committed
97 98
    let scope = Eliom_common.default_session_scope

Stephane Glondu's avatar
Stephane Glondu committed
99
    let home = service
100
      ~path:(make_path [""])
Stephane Glondu's avatar
Stephane Glondu committed
101
      ~get_params:unit
102 103
      ()

104 105 106 107 108
    let admin = service
      ~path:(make_path ["admin"])
      ~get_params:unit
      ()

Stephane Glondu's avatar
Stephane Glondu committed
109
    let source_code = service
110
      ~path:(make_path ["belenios.tar.gz"])
Stephane Glondu's avatar
Stephane Glondu committed
111 112 113 114
      ~get_params:unit
      ()

    let get_randomness = service
115
      ~path:(make_path ["get-randomness"])
Stephane Glondu's avatar
Stephane Glondu committed
116 117 118
      ~get_params:unit
      ()

Stephane Glondu's avatar
Stephane Glondu committed
119 120
    let cont = Eliom_reference.eref ~scope
      (fun () () -> Eliom_registration.Redirection.send home)
121

122
    let import_election f = !import_election_ref f
123

124 125 126 127 128 129 130 131 132 133 134 135 136 137
    let add_featured_election x =
      lwt the_featured = Ocsipersist.get featured in
      if List.mem x the_featured then (
        return ()
      ) else if SMap.mem x !election_table then (
        Ocsipersist.set featured (x :: the_featured)
      ) else (
        Lwt.fail Not_found
      )

    let remove_featured_election x =
      lwt the_featured = Ocsipersist.get featured in
      Ocsipersist.set featured (list_remove x the_featured)

138 139 140 141 142 143 144 145 146
    let set_main_election x =
      if SMap.mem x !election_table then (
        Ocsipersist.set main_election (Some x)
      ) else (
        Lwt.fail Not_found
      )

    let unset_main_election () =
      Ocsipersist.set main_election None
147

Stephane Glondu's avatar
Stephane Glondu committed
148 149
  end

Stephane Glondu's avatar
Stephane Glondu committed
150 151
  include S

152
  module T = Web_templates.Make (S)
Stephane Glondu's avatar
Stephane Glondu committed
153

154 155 156 157 158 159 160 161 162 163 164
  let register_election params web_params =
    let module P = (val params : ELECTION_PARAMS) in
    let uuid = Uuidm.to_string P.params.e_uuid in
    let module D = struct
      module G = P.G
      let election = {
        e_params = P.params;
        e_pks = None;
        e_fingerprint = P.fingerprint;
      }
    end in
165 166
    let module P = (val web_params : WEB_PARAMS) in
    let module R = Web_election.Make (D) (P) in
167
    (module R : Web_election.REGISTRABLE), fun () ->
168 169 170 171 172 173 174 175 176 177
      (* starting from here, we do side-effects on the running server *)
      let module R = R.Register (struct end) in
      let module W = R.W in
      let module X : EMPTY = R.Register (S) (T) in
      let election = (module W : WEB_ELECTION) in
      election_table := SMap.add uuid election !election_table;
      election

  (* Mutex to avoid simultaneous registrations of the same election *)
  let registration_mutex = Lwt_mutex.create ()
Stephane Glondu's avatar
Stephane Glondu committed
178

179
  let () = import_election_ref := fun f ->
180 181 182 183 184 185 186 187 188 189
    Lwt_mutex.lock registration_mutex >>
    try_lwt
      lwt raw_election =
        Lwt_io.lines_of_file f.f_election |>
        get_single_line >>=
        (function
        | Some e -> return e
        | None -> Printf.ksprintf
          failwith "%s must contain a single line" f.f_election
        )
190
      in
191 192 193 194 195 196 197 198
      let params = Group.election_params_of_string raw_election in
      let module P = (val params : ELECTION_PARAMS) in
      let uuid = Uuidm.to_string P.params.e_uuid in
      lwt exists =
        try_lwt
          lwt _ = Ocsipersist.find election_ptable uuid in
          return true
        with Not_found -> return false
199
      in
200 201 202 203 204 205 206 207 208
      if exists then (
        return None
      ) else (
        let ( / ) = Filename.concat in
        let dir = C.spool_dir/uuid in
        lwt metadata =
          Lwt_io.chars_of_file f.f_metadata |>
          Lwt_stream.to_string >>=
          wrap1 metadata_of_string
209
        in
210 211 212 213 214
        let module X = struct
          let metadata = metadata
          let dir = dir
        end in
        let web_params = (module X : WEB_PARAMS) in
215 216 217 218
        let r, do_register = register_election params web_params in
        let module R = (val r : Web_election.REGISTRABLE) in
        let module G = R.W.G in
        let module KG = Election.MakeSimpleDistKeyGen (G) (Random) in
219
        let public_keys = Lwt_io.lines_of_file f.f_public_keys in
220 221 222 223 224 225 226 227 228
        lwt pks = Lwt_stream.(
          clone public_keys |>
          map (trustee_public_key_of_string G.read) |>
          to_list >>= wrap1 Array.of_list
        ) in
        if not (Array.forall KG.check pks) then
          failwith "Public keys are invalid.";
        if not G.(R.W.election.e_params.e_public_key =~ KG.combine pks) then
          failwith "Public keys mismatch with election public key.";
229 230 231 232 233 234 235 236 237
        let public_creds = Lwt_io.lines_of_file f.f_public_creds in
        lwt () = Lwt_stream.(
          clone public_creds |>
          iter_s (fun x ->
            if not G.(check @@ of_string x) then (
              Lwt.fail @@ Failure "Public credentials are invalid."
            ) else return ()
          )
        ) in
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
        let module R = struct
          let discard () = Lwt_mutex.unlock registration_mutex
          let register () =
            if not (Lwt_mutex.is_locked registration_mutex) then
              failwith "This election can no longer be registered.";
            try_lwt
              Lwt_unix.mkdir dir 0o700 >>
              Lwt_io.(with_file Output (dir/"election.json") (fun oc ->
                write_line oc raw_election
              )) >>
              Lwt_io.(with_file Output (dir/"public_keys.jsons") (fun oc ->
                write_lines oc public_keys
              )) >>
              let election = do_register () in
              let module W = (val election : WEB_ELECTION) in
              let () =
                Ocsigen_messages.debug (fun () ->
                  Printf.sprintf "Injecting credentials for %s" uuid
                )
              in
258
              public_creds |>
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
              Lwt_stream.iter_s W.B.inject_cred >>
              W.B.update_files () >>
              Ocsipersist.add election_ptable uuid (raw_election, web_params) >>
              let () = Lwt_mutex.unlock registration_mutex in
              return election
            with e ->
              Lwt_mutex.unlock registration_mutex;
              Lwt.fail e
        end in
        (* until here, no side-effects on the running server *)
        return @@ Some (module R : REGISTRABLE_ELECTION)
      )
    with e ->
      Lwt_mutex.unlock registration_mutex;
      Lwt.fail e
274 275 276 277

  lwt () =
    Ocsipersist.iter_step (fun uuid (raw_election, web_params) ->
      let params = Group.election_params_of_string raw_election in
278 279
      let _, do_register = register_election params web_params in
      let election = do_register () in
280 281 282 283 284 285 286 287
      let module W = (val election : WEB_ELECTION) in
      assert (uuid = Uuidm.to_string W.election.e_params.e_uuid);
      Ocsigen_messages.debug (fun () ->
        Printf.sprintf "Initialized election %s from persistent store" uuid
      );
      return ()
    ) election_ptable

288
  let () = let module X : EMPTY = Auth.Register (S) (T.Login (S)) in ()
Stephane Glondu's avatar
Stephane Glondu committed
289 290 291

  let () = Any.register ~service:home
    (fun () () ->
Stephane Glondu's avatar
Stephane Glondu committed
292
      Eliom_reference.unset cont >>
293
      match_lwt Ocsipersist.get main_election with
Stephane Glondu's avatar
Stephane Glondu committed
294
      | None ->
295 296 297 298 299 300 301 302 303 304
        lwt featured =
          Ocsipersist.get featured >>=
          Lwt_list.map_p (fun x ->
            let module W = (val SMap.find x !election_table : WEB_ELECTION) in
            return (module W : WEB_ELECTION_RO)
          )
        in
        T.home ~featured () >>= Html5.send
      | Some x ->
        let module W = (val SMap.find x !election_table : WEB_ELECTION) in
Stephane Glondu's avatar
Stephane Glondu committed
305 306 307
        Redirection.send W.S.home
    )

308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327
  let () = Html5.register ~service:admin
    (fun () () ->
      let cont () () = Redirection.send admin in
      Eliom_reference.set S.cont cont >>
      lwt elections =
        match_lwt get_user () with
        | None -> return []
        | Some u ->
          SMap.fold (fun _ w accu ->
            let module W = (val w : WEB_ELECTION) in
            if W.metadata.e_owner = Some u then (
              (module W : WEB_ELECTION_RO) :: accu
            ) else (
              accu
            )
          ) !election_table [] |> List.rev |> return
      in
      T.admin ~elections ()
    )

Stephane Glondu's avatar
Stephane Glondu committed
328 329 330
  let () = File.register
    ~service:source_code
    ~content_type:"application/x-gzip"
331
    (fun () () -> return C.source_file)
Stephane Glondu's avatar
Stephane Glondu committed
332

Stephane Glondu's avatar
Stephane Glondu committed
333 334 335 336 337 338 339 340 341
  let do_get_randomness =
    let prng = Lazy.lazy_from_fun (Lwt_preemptive.detach (fun () ->
      Cryptokit.Random.(pseudo_rng (string secure_rng 16))
    )) in
    let mutex = Lwt_mutex.create () in
    fun () ->
      Lwt_mutex.with_lock mutex (fun () ->
        lwt prng = Lazy.force prng in
        return Cryptokit.Random.(string prng 32)
Stephane Glondu's avatar
Stephane Glondu committed
342 343
      )

Stephane Glondu's avatar
Stephane Glondu committed
344 345 346 347 348 349 350 351
  let () = String.register
    ~service:get_randomness
    (fun () () ->
      lwt r = do_get_randomness () in
      Cryptokit.(transform_string (Base64.encode_compact ()) r) |>
      (fun x -> string_of_randomness { randomness=x }) |>
      (fun x -> return (x, "application/json"))
    )
Stephane Glondu's avatar
Stephane Glondu committed
352 353

end