Mise à jour terminée. Pour connaître les apports de la version 13.8.4 par rapport à notre ancienne version vous pouvez lire les "Release Notes" suivantes :
https://about.gitlab.com/releases/2021/02/11/security-release-gitlab-13-8-4-released/
https://about.gitlab.com/releases/2021/02/05/gitlab-13-8-3-released/

Commit 0544f53e authored by Stephane Glondu's avatar Stephane Glondu

Restructure Registration

 - define Registration.Site of type SITE_SERVICES
 - split election initialization in two parts:
   1. (inside Site) define a generic register_election
      function supposed to be callable from a running server
   2. (outside Site) register all elections that have
      been declared in the configuration file
 - main_election and featured election are no longer computed, but
   mutated dynamically
 - less things exported in WEB_SERVICES
parent 9dbe5b04
......@@ -27,35 +27,21 @@ open Lwt
open Web_common
open Web_signatures
(** Global initialization *)
(* FIXME: the following should be in configuration file... but
<maxrequestbodysize> doesn't work *)
let () = Ocsigen_config.set_maxrequestbodysizeinmemory 128000
module EMap = Map.Make(Uuidm)
module AclSet = Set.Make(struct
type t = Web_serializable_t.acl
let compare = compare
end)
let ( / ) = Filename.concat
let file_exists x =
try_lwt
Lwt_unix.(access x [R_OK]) >>
return true
with _ ->
return false
let () = CalendarLib.Time_Zone.(change Local)
let populate accu f s = Lwt_stream.fold_s f s accu
(** Parse configuration from <eliom> *)
let datadirs = ref []
let data_dirs = ref []
let source_file = ref None
let main_election = ref None
let main_election_uuid = ref None
let auth_instances = ref []
let () = CalendarLib.Time_Zone.(change Local)
let () =
Eliom_config.get_config () |>
let open Simplexmlparser in
......@@ -67,11 +53,14 @@ let () =
| Element ("source", ["file", file], []) ->
source_file := Some file
| Element ("data", ["dir", dir], []) ->
datadirs := dir :: !datadirs
data_dirs := dir :: !data_dirs
| Element ("rewrite-prefix", ["src", src; "dst", dst], []) ->
set_rewrite_prefix ~src ~dst
| Element ("main-election", ["uuid", uuid], []) ->
main_election := Some uuid
(match Uuidm.of_string uuid with
| Some u -> main_election_uuid := Some u
| None -> failwith "Incorrect UUID in configuration <main-election> tag"
)
| Element ("auth", ["name", auth_instance],
[Element (auth_system, auth_config, [])]) ->
let open Auth_common in
......@@ -82,12 +71,7 @@ let () =
"invalid configuration for tag %s in belenios"
tag
let main_election = match !main_election with
| None -> None
| Some u ->
match Uuidm.of_string u with
| Some u -> Some u
| None -> failwith "Incorrect UUID in configuration <main-election> tag"
(** Parse configuration from other sources *)
let get_single_line x =
match_lwt Lwt_stream.get x with
......@@ -101,9 +85,18 @@ let get_single_line x =
return None
)
let process_datadir dir =
let ( / ) = Filename.concat
let file_exists x =
try_lwt
Lwt_unix.(access x [R_OK]) >>
return true
with _ ->
return false
let parse_election_dir dir =
Ocsigen_messages.debug (fun () ->
"Using data from " ^ dir ^ "..."
"Loading data from " ^ dir ^ "..."
);
lwt index =
Lwt_io.chars_of_file (dir/"index.json") |>
......@@ -116,7 +109,7 @@ let process_datadir dir =
let params_fname = path/"election.json" in
let public_keys_fname = path/"public_keys.jsons" in
Ocsigen_messages.debug (fun () ->
"-- registering " ^ subdir
"-- loading " ^ subdir
);
lwt raw_election =
Lwt_io.lines_of_file params_fname |>
......@@ -135,56 +128,47 @@ let process_datadir dir =
) else return empty_metadata
in
let public_creds_fname = path/"public_creds.txt" in
lwt public_creds =
Lwt_io.lines_of_file public_creds_fname |>
populate SSet.empty (fun c accu ->
return (SSet.add c accu)
)
in
let featured = item.datadir_featured in
let election = Web_election.(make {
raw_election; metadata; featured;
params_fname; public_keys_fname;
}) in
let module X = (val election : WEB_ELECTION) in
X.B.inject_creds public_creds >>
return election
(* public credentials will be parsed later *)
return Web_election.({
raw_election;
metadata;
featured = item.datadir_featured;
params_fname;
public_keys_fname;
}, public_creds_fname)
) index
lwt election_table =
Lwt_list.fold_left_s (fun accu d ->
process_datadir d >>=
wrap1 @@ List.fold_left (fun accu election ->
let module X = (val election : WEB_ELECTION) in
let uuid = X.election.e_params.e_uuid in
EMap.add uuid election accu
) accu
) EMap.empty !datadirs
let get_election_by_uuid x =
try_lwt
EMap.find x election_table |> return
with Not_found ->
raise_lwt Eliom_common.Eliom_404
let get_featured_elections () =
EMap.fold (fun uuid e res ->
let module X = (val e : WEB_ELECTION) in
if X.featured then
e :: res
else res
) election_table [] |> return
module SAuth = Auth_common.Make (struct
let name = "site"
let path = []
let instances = !auth_instances
end)
module SSite = struct
lwt election_configs =
Lwt_list.map_p parse_election_dir !data_dirs >>=
wrap1 List.flatten
(** Build up the site *)
module Site : SITE_SERVICES = struct
open Eliom_service
open Eliom_registration
module Auth = Auth_common.Make (struct
let name = "site"
let path = []
let instances = !auth_instances
end)
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. *)
module Services : SITE_SERVICES = struct
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
open Eliom_parameter
let home = service
......@@ -206,79 +190,87 @@ module SSite = struct
~scope:Eliom_common.default_session_scope
(module struct let s = home end : SAVED_SERVICE)
let register_election config = !register_election_ref config
let cont () =
lwt x = Eliom_reference.get saved_service in
let module X = (val x : SAVED_SERVICE) in
return X.s
include SAuth.Services
end
module Register (S : SITE_SERVICES) (T : TEMPLATES) : EMPTY = struct
open Services
open Eliom_registration
include S
module T = Templates.Make (S)
let () =
match main_election with
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
let u = W.election.e_params.e_uuid in
if !main_election_uuid = Some u then main_election := Some election;
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
| None ->
Html5.register ~service:home
(fun () () ->
Eliom_reference.unset saved_service >>
lwt featured = get_featured_elections () in
T.home ~featured ()
)
| Some uuid ->
let election = get_election_by_uuid uuid |> Lwt_main.run in
let module W = (val election : WEB_ELECTION) in
Redirection.register ~service:home
(fun () () ->
Eliom_reference.unset saved_service >>
return W.S.home
)
let () = File.register
~service:source_code
~content_type:"application/x-gzip"
(fun () () -> match !source_file with
| None -> fail_http 404
| Some f -> return f
)
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"
(fun () () -> match !source_file with
| None -> fail_http 404
| Some f -> return f
)
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)
)
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"))
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)
)
end
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"))
)
end
module S = SSite.Services
module T = Templates.Make (S)
let () =
let module X : EMPTY = SAuth.Register (S) (T) in
let module X : EMPTY = SSite.Register (S) (T) in
()
let () =
EMap.iter (fun _ election ->
let populate accu f s = Lwt_stream.fold_s f s accu
lwt () =
Lwt_list.iter_s (fun (config, public_creds_fname) ->
lwt election = Site.register_election config in
let module W = (val election : WEB_ELECTION) in
let module X : EMPTY = W.Register (S) (T.Election (W)) in
()
) election_table
lwt public_creds =
Lwt_io.lines_of_file public_creds_fname |>
populate SSet.empty (fun c accu ->
return (SSet.add c accu)
)
in
W.B.inject_creds public_creds >>
return ()
) election_configs
This diff is collapsed.
......@@ -21,15 +21,13 @@
open Serializable_builtin_t
open Serializable_t
open Signatures
open Web_serializable_t
open Web_signatures
type config = {
raw_election : string;
metadata : metadata;
featured : bool;
params_fname : string;
public_keys_fname : string;
}
module type REGISTRATION = sig
module W : WEB_ELECTION
module Register (S : SITE_SERVICES) (T : ELECTION_TEMPLATES) : EMPTY
end
val make : config -> (module WEB_ELECTION)
val make : election_config -> (module REGISTRATION)
......@@ -35,6 +35,14 @@ module type SAVED_SERVICE = sig
Eliom_service.service
end
type election_config = {
raw_election : string;
metadata : metadata;
featured : bool;
params_fname : string;
public_keys_fname : string;
}
module type CORE_SERVICES = sig
val home :
......@@ -147,18 +155,6 @@ module type ELECTION_SERVICES = sig
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val create_confirm :
unit ->
(unit, unit,
[> `Attached of
([> `Internal of [> `Coservice ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ], unit, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val ballot : string option Eliom_reference.eref
end
......@@ -213,12 +209,6 @@ module type AUTH_SERVICES = sig
end
module type SITE_SERVICES = sig
include CORE_SERVICES
include CONT_SERVICE
include AUTH_SERVICES
end
module type WEB_BALLOT_BOX = sig
module Ballots : MONADIC_MAP_RO
with type 'a m = 'a Lwt.t
......@@ -276,7 +266,13 @@ module type WEB_ELECTION = sig
module B : WEB_BALLOT_BOX
module S : ELECTION_SERVICES
module Register (S : SITE_SERVICES) (T : ELECTION_TEMPLATES) : EMPTY
end
module type SITE_SERVICES = sig
include CORE_SERVICES
include CONT_SERVICE
include AUTH_SERVICES
val register_election : election_config -> (module WEB_ELECTION) Lwt.t
end
module type TEMPLATES = sig
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment