Skip to content

GitLab

B
belenios
Commit 96f09d36 authored by Stephane Glondu's avatar Stephane Glondu
Browse files
Options

Split Registration into Web_site and Web_main

parent 60cb2f27
Hide whitespace changes
Inline Side-by-side
Showing with 200 additions and 112 deletions
src/web/server.mllib
View file @ 96f09d36
......@@ -10,4 +10,5 @@ Auth_cas
Web_election
Election
Templates
Registration
Web_site
Web_main
src/web/registration.ml → src/web/web_main.ml
View file @ 96f09d36
......@@ -142,122 +142,27 @@ 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. *)
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
~path:[]
~get_params:unit
()
let source_code = service
~path:["belenios.tar.gz"]
~get_params:unit
()
let get_randomness = service
~path:["get-randomness"]
~get_params:unit
()
let saved_service = Eliom_reference.eref
~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
end
include S
module T = Templates.Make (S)
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 ->
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
lwt source_file =
match !source_file with
| Some f ->
lwt b = file_exists f in
if b then (
return f
) else (
Printf.ksprintf failwith "file %s does not exist" f
)
| None -> failwith "missing <source> in configuration"
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"))
)
(** Build up the site *)
module Site_config = struct
let name = "site"
let path = []
let source_file = source_file
let instances = !auth_instances
end
module Site = Web_site.Make (Site_config)
let populate accu f s = Lwt_stream.fold_s f s accu
......@@ -265,6 +170,11 @@ 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
(match !main_election_uuid with
| Some u when u = W.election.e_params.e_uuid ->
Site.set_main_election election
| _ -> ()
);
lwt public_creds =
Lwt_io.lines_of_file public_creds_fname |>
populate SSet.empty (fun c accu ->
......
src/web/web_signatures.mli
View file @ 96f09d36
......@@ -262,7 +262,11 @@ module type SITE_SERVICES = sig
include CORE_SERVICES
include CONT_SERVICE
include AUTH_SERVICES
val register_election : election_config -> (module WEB_ELECTION) Lwt.t
val set_main_election : (module WEB_ELECTION) -> unit
val unset_main_election : unit -> unit
end
module type TEMPLATES = sig
......
src/web/web_site.ml 0 → 100644
View file @ 96f09d36
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* 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/>. *)
(**************************************************************************)
open Lwt
open Util
open Serializable_t
open Signatures
open Web_serializable_j
open Web_common
open Web_signatures
module type CONFIG = sig
val name : string
val path : string list
val source_file : string
val instances : Auth_common.auth_instance list
end
module Make (C : CONFIG) : SITE_SERVICES = struct
open Eliom_service
open Eliom_registration
module Auth = Auth_common.Make (C)
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. *)
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
~path:[]
~get_params:unit
()
let source_code = service
~path:["belenios.tar.gz"]
~get_params:unit
()
let get_randomness = service
~path:["get-randomness"]
~get_params:unit
()
let saved_service = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(module struct let s = home end : SAVED_SERVICE)
let cont () =
lwt x = Eliom_reference.get saved_service in
let module X = (val x : SAVED_SERVICE) in
return X.s
let register_election config = !register_election_ref config
let set_main_election x = main_election := Some x
let unset_main_election () = main_election := None
end
include S
module T = Templates.Make (S)
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
| None ->
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 () () -> return C.source_file)
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"))
)
end
src/web/web_site.mli 0 → 100644
View file @ 96f09d36
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2014 Inria *)
(* *)
(* 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/>. *)
(**************************************************************************)
open Web_signatures
module type CONFIG = sig
val name : string
val path : string list
val source_file : string
val instances : Auth_common.auth_instance list
end
module Make (C : CONFIG) : SITE_SERVICES
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