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.76 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_t
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 auth_config : auth_config list
35
end
Stephane Glondu's avatar
Stephane Glondu committed
36

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

41 42
  let make_path x = C.path @ x

43
  module Auth = Web_auth.Make (C)
Stephane Glondu's avatar
Stephane Glondu committed
44 45 46 47 48 49 50

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

Stephane Glondu's avatar
Stephane Glondu committed
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. *)

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

Stephane Glondu's avatar
Stephane Glondu committed
63 64
    let scope = Eliom_common.default_session_scope

Stephane Glondu's avatar
Stephane Glondu committed
65
    let home = service
66
      ~path:(make_path [""])
Stephane Glondu's avatar
Stephane Glondu committed
67
      ~get_params:unit
68 69
      ()

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

    let get_randomness = service
76
      ~path:(make_path ["get-randomness"])
Stephane Glondu's avatar
Stephane Glondu committed
77 78 79
      ~get_params:unit
      ()

Stephane Glondu's avatar
Stephane Glondu committed
80 81
    let cont = Eliom_reference.eref ~scope
      (fun () () -> Eliom_registration.Redirection.send home)
82

83 84 85 86 87
    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
88 89
  end

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

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

94 95 96 97
  let () = register_election_ref := fun election_data web_params ->
    let module D = (val election_data : ELECTION_DATA) in
    let module P = (val web_params : WEB_PARAMS) in
    let module R = Web_election.Make (D) (P) in
Stephane Glondu's avatar
Stephane Glondu committed
98
    let module W = R.W in
99
    let module X : EMPTY = R.Register (S) (T) in
Stephane Glondu's avatar
Stephane Glondu committed
100
    let election = (module W : WEB_ELECTION) in
101 102
    let election_ro = (module W : WEB_ELECTION_RO) in
    if W.featured then featured := election_ro :: !featured;
Stephane Glondu's avatar
Stephane Glondu committed
103 104
    return election

105
  let () = let module X : EMPTY = Auth.Register (S) (T.Login (S)) in ()
Stephane Glondu's avatar
Stephane Glondu committed
106 107 108

  let () = Any.register ~service:home
    (fun () () ->
Stephane Glondu's avatar
Stephane Glondu committed
109
      Eliom_reference.unset cont >>
Stephane Glondu's avatar
Stephane Glondu committed
110
      match !main_election with
Stephane Glondu's avatar
Stephane Glondu committed
111
      | None ->
Stephane Glondu's avatar
Stephane Glondu committed
112 113 114 115 116 117 118 119 120
        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"
121
    (fun () () -> return C.source_file)
Stephane Glondu's avatar
Stephane Glondu committed
122

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

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

end