Maj terminée. Pour consulter la release notes associée voici le lien :
https://about.gitlab.com/releases/2021/07/07/critical-security-release-gitlab-14-0-4-released/

web_site.ml 4.8 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
module type CONFIG = sig
  val name : string
  val path : string list
  val source_file : string
34
  val instances : Web_auth.auth_instance list
35
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 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 58 59
  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
60 61
    open Eliom_parameter

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

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

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

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

Stephane Glondu's avatar
Stephane Glondu committed
79
    let saved_service = Eliom_reference.eref ~scope
80 81
      (module struct let s = home end : SAVED_SERVICE)

82 83 84 85 86
    let cont () =
      lwt x = Eliom_reference.get saved_service in
      let module X = (val x : SAVED_SERVICE) in
      return X.s

87 88 89 90 91
    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
92 93
  end

Stephane Glondu's avatar
Stephane Glondu committed
94 95
  include S

96
  module T = Web_templates.Make (S)
Stephane Glondu's avatar
Stephane Glondu committed
97

Stephane Glondu's avatar
Stephane Glondu committed
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
  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
113
      | None ->
Stephane Glondu's avatar
Stephane Glondu committed
114 115 116 117 118 119 120 121 122
        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"
123
    (fun () () -> return C.source_file)
Stephane Glondu's avatar
Stephane Glondu committed
124

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

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

end