Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

web_site.ml 4.73 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
Stephane Glondu's avatar
Stephane Glondu committed
23
open Util
24
open Serializable_t
25
open Signatures
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 34 35
module type CONFIG = sig
  val name : string
  val path : string list
  val source_file : string
  val instances : Auth_common.auth_instance list
end
Stephane Glondu's avatar
Stephane Glondu committed
36

37
module Make (C : CONFIG) : SITE_SERVICES = struct
38
  open Eliom_service
Stephane Glondu's avatar
Stephane Glondu committed
39 40
  open Eliom_registration

41
  module Auth = Auth_common.Make (C)
Stephane Glondu's avatar
Stephane Glondu committed
42 43 44 45 46 47 48

  let main_election = ref None
  let featured = ref []

  (* 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. *)
49

Stephane Glondu's avatar
Stephane Glondu committed
50 51 52 53 54 55 56 57
  let register_election_ref = ref (fun _ -> assert false)

  (* 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. *)

  module S : SITE_SERVICES = struct
    include Auth.Services
Stephane Glondu's avatar
Stephane Glondu committed
58 59 60 61 62
    open Eliom_parameter

    let home = service
      ~path:[]
      ~get_params:unit
63 64
      ()

Stephane Glondu's avatar
Stephane Glondu committed
65 66 67 68 69 70 71 72 73 74
    let source_code = service
      ~path:["belenios.tar.gz"]
      ~get_params:unit
      ()

    let get_randomness = service
      ~path:["get-randomness"]
      ~get_params:unit
      ()

75 76 77 78
    let saved_service = Eliom_reference.eref
      ~scope:Eliom_common.default_session_scope
      (module struct let s = home end : SAVED_SERVICE)

79 80 81 82 83
    let cont () =
      lwt x = Eliom_reference.get saved_service in
      let module X = (val x : SAVED_SERVICE) in
      return X.s

84 85 86 87 88
    let register_election config = !register_election_ref config

    let set_main_election x = main_election := Some x
    let unset_main_election () = main_election := None

Stephane Glondu's avatar
Stephane Glondu committed
89 90
  end

Stephane Glondu's avatar
Stephane Glondu committed
91 92
  include S

93
  module T = Web_templates.Make (S)
Stephane Glondu's avatar
Stephane Glondu committed
94

Stephane Glondu's avatar
Stephane Glondu committed
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
  let () = register_election_ref := fun config ->
    let registration = Web_election.make config in
    let module R = (val registration : Web_election.REGISTRATION) in
    let module W = R.W in
    let module X : EMPTY = R.Register (S) (T.Election (W)) in
    let election = (module W : WEB_ELECTION) in
    if W.featured then featured := election :: !featured;
    return election

  let () = let module X : EMPTY = Auth.Register (S) (T) in ()

  let () = Any.register ~service:home
    (fun () () ->
      Eliom_reference.unset saved_service >>
      match !main_election with
Stephane Glondu's avatar
Stephane Glondu committed
110
      | None ->
Stephane Glondu's avatar
Stephane Glondu committed
111 112 113 114 115 116 117 118 119
        T.home ~featured:!featured () >>= Html5.send
      | Some w ->
        let module W = (val w : WEB_ELECTION) in
        Redirection.send W.S.home
    )

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

Stephane Glondu's avatar
Stephane Glondu committed
122 123 124 125 126 127 128 129 130
  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
131 132
      )

Stephane Glondu's avatar
Stephane Glondu committed
133 134 135 136 137 138 139 140
  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
141 142

end