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 9.61 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 spool_dir : string
35
  val auth_config : auth_config list
36
end
Stephane Glondu's avatar
Stephane Glondu committed
37

38 39 40 41
let rec list_remove x = function
  | [] -> []
  | y :: ys -> if x = y then ys else y :: (list_remove x ys)

42 43 44 45 46 47 48 49 50 51 52 53
let get_single_line x =
  match_lwt Lwt_stream.get x with
  | None -> return None
  | Some _ as line ->
    lwt b = Lwt_stream.is_empty x in
    if b then (
      return line
    ) else (
      Lwt_stream.junk_while (fun _ -> true) x >>
      return None
    )

54
module Make (C : CONFIG) : SITE = struct
55
  open Eliom_service
Stephane Glondu's avatar
Stephane Glondu committed
56 57
  open Eliom_registration

58 59 60 61 62
  module C = struct
    include C
    let kind = `Site
  end

63 64
  let make_path x = C.path @ x

65
  module Auth = Web_auth.Make (C)
Stephane Glondu's avatar
Stephane Glondu committed
66

67 68 69 70 71 72 73 74 75 76 77 78 79
  let store = Ocsipersist.open_store C.name

  (* Persistent table, used to initialize the server. *)
  let election_ptable = Ocsipersist.open_table (C.name ^ "_elections")

  (* In-memory table, indexed by UUID, contains closures. *)
  let election_table = ref SMap.empty

  lwt main_election =
    Ocsipersist.make_persistent store "main_election" None

  lwt featured =
    Ocsipersist.make_persistent store "featured_elections" []
Stephane Glondu's avatar
Stephane Glondu committed
80 81 82 83

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

85
  let import_election_ref = ref (fun _ -> assert false)
Stephane Glondu's avatar
Stephane Glondu committed
86 87 88 89 90

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

91
  module S : SITE = struct
Stephane Glondu's avatar
Stephane Glondu committed
92
    include Auth.Services
93
    include Auth.Handlers
Stephane Glondu's avatar
Stephane Glondu committed
94 95
    open Eliom_parameter

Stephane Glondu's avatar
Stephane Glondu committed
96 97
    let scope = Eliom_common.default_session_scope

Stephane Glondu's avatar
Stephane Glondu committed
98
    let home = service
99
      ~path:(make_path [""])
Stephane Glondu's avatar
Stephane Glondu committed
100
      ~get_params:unit
101 102
      ()

103 104 105 106 107
    let admin = service
      ~path:(make_path ["admin"])
      ~get_params:unit
      ()

Stephane Glondu's avatar
Stephane Glondu committed
108
    let source_code = service
109
      ~path:(make_path ["belenios.tar.gz"])
Stephane Glondu's avatar
Stephane Glondu committed
110 111 112 113
      ~get_params:unit
      ()

    let get_randomness = service
114
      ~path:(make_path ["get-randomness"])
Stephane Glondu's avatar
Stephane Glondu committed
115 116 117
      ~get_params:unit
      ()

Stephane Glondu's avatar
Stephane Glondu committed
118 119
    let cont = Eliom_reference.eref ~scope
      (fun () () -> Eliom_registration.Redirection.send home)
120

121
    let import_election f = !import_election_ref f
122

123 124 125 126 127 128 129 130 131 132 133 134 135 136
    let add_featured_election x =
      lwt the_featured = Ocsipersist.get featured in
      if List.mem x the_featured then (
        return ()
      ) else if SMap.mem x !election_table then (
        Ocsipersist.set featured (x :: the_featured)
      ) else (
        Lwt.fail Not_found
      )

    let remove_featured_election x =
      lwt the_featured = Ocsipersist.get featured in
      Ocsipersist.set featured (list_remove x the_featured)

137 138 139 140 141 142 143 144 145
    let set_main_election x =
      if SMap.mem x !election_table then (
        Ocsipersist.set main_election (Some x)
      ) else (
        Lwt.fail Not_found
      )

    let unset_main_election () =
      Ocsipersist.set main_election None
146

Stephane Glondu's avatar
Stephane Glondu committed
147 148
  end

Stephane Glondu's avatar
Stephane Glondu committed
149 150
  include S

151
  module T = Web_templates.Make (S)
Stephane Glondu's avatar
Stephane Glondu committed
152

153 154 155 156 157 158 159 160 161 162 163
  let register_election params web_params =
    let module P = (val params : ELECTION_PARAMS) in
    let uuid = Uuidm.to_string P.params.e_uuid in
    let module D = struct
      module G = P.G
      let election = {
        e_params = P.params;
        e_pks = None;
        e_fingerprint = P.fingerprint;
      }
    end in
164 165
    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
166
    let module W = R.W in
167
    let module X : EMPTY = R.Register (S) (T) in
Stephane Glondu's avatar
Stephane Glondu committed
168
    let election = (module W : WEB_ELECTION) in
169
    election_table := SMap.add uuid election !election_table;
Stephane Glondu's avatar
Stephane Glondu committed
170 171
    return election

172
  let () = import_election_ref := fun f ->
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
    lwt raw_election =
      Lwt_io.lines_of_file f.f_election |>
      get_single_line >>=
      (function
      | Some e -> return e
      | None -> Printf.ksprintf
        failwith "%s must contain a single line" f.f_election
      )
    in
    let params = Group.election_params_of_string raw_election in
    let module P = (val params : ELECTION_PARAMS) in
    let uuid = Uuidm.to_string P.params.e_uuid in
    lwt exists =
      try_lwt
        lwt _ = Ocsipersist.find election_ptable uuid in
        return true
      with Not_found -> return false
    in
    if exists then (
      return None
    ) else (
194 195
      let ( / ) = Filename.concat in
      let dir = C.spool_dir/uuid in
196 197 198 199 200
      lwt metadata =
        Lwt_io.chars_of_file f.f_metadata |>
        Lwt_stream.to_string >>=
        wrap1 metadata_of_string
      in
201 202 203 204 205 206 207 208 209 210 211
      lwt () =
        Lwt_unix.mkdir dir 0o700 >>
        Lwt_io.(with_file Output (dir/"election.json") (fun oc ->
          write_line oc raw_election
        )) >>
        Lwt_io.(with_file Output (dir/"public_keys.jsons") (fun oc ->
          with_file Input f.f_public_keys (fun ic ->
            read_chars ic |> write_chars oc
          )
        ))
      in
212 213
      let module X = struct
        let metadata = metadata
214
        let dir = dir
215 216 217 218 219 220 221 222 223 224 225 226
      end in
      let web_params = (module X : WEB_PARAMS) in
      Ocsipersist.add election_ptable uuid (raw_election, web_params) >>
      lwt election = register_election params web_params in
      let module W = (val election : WEB_ELECTION) in
      begin try_lwt
        let () =
          Ocsigen_messages.debug (fun () ->
            Printf.sprintf "Injecting credentials for %s" uuid
          )
        in
        Lwt_io.lines_of_file f.f_public_creds |>
227 228
        Lwt_stream.iter_s W.B.inject_cred >>
        W.B.update_files ()
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246
      with Not_found ->
        return ()
      end >>
      return (Some election)
    )

  lwt () =
    Ocsipersist.iter_step (fun uuid (raw_election, web_params) ->
      let params = Group.election_params_of_string raw_election in
      lwt election = register_election params web_params in
      let module W = (val election : WEB_ELECTION) in
      assert (uuid = Uuidm.to_string W.election.e_params.e_uuid);
      Ocsigen_messages.debug (fun () ->
        Printf.sprintf "Initialized election %s from persistent store" uuid
      );
      return ()
    ) election_ptable

247
  let () = let module X : EMPTY = Auth.Register (S) (T.Login (S)) in ()
Stephane Glondu's avatar
Stephane Glondu committed
248 249 250

  let () = Any.register ~service:home
    (fun () () ->
Stephane Glondu's avatar
Stephane Glondu committed
251
      Eliom_reference.unset cont >>
252
      match_lwt Ocsipersist.get main_election with
Stephane Glondu's avatar
Stephane Glondu committed
253
      | None ->
254 255 256 257 258 259 260 261 262 263
        lwt featured =
          Ocsipersist.get featured >>=
          Lwt_list.map_p (fun x ->
            let module W = (val SMap.find x !election_table : WEB_ELECTION) in
            return (module W : WEB_ELECTION_RO)
          )
        in
        T.home ~featured () >>= Html5.send
      | Some x ->
        let module W = (val SMap.find x !election_table : WEB_ELECTION) in
Stephane Glondu's avatar
Stephane Glondu committed
264 265 266
        Redirection.send W.S.home
    )

267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
  let () = Html5.register ~service:admin
    (fun () () ->
      let cont () () = Redirection.send admin in
      Eliom_reference.set S.cont cont >>
      lwt elections =
        match_lwt get_user () with
        | None -> return []
        | Some u ->
          SMap.fold (fun _ w accu ->
            let module W = (val w : WEB_ELECTION) in
            if W.metadata.e_owner = Some u then (
              (module W : WEB_ELECTION_RO) :: accu
            ) else (
              accu
            )
          ) !election_table [] |> List.rev |> return
      in
      T.admin ~elections ()
    )

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

Stephane Glondu's avatar
Stephane Glondu committed
292 293 294 295 296 297 298 299 300
  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
301 302
      )

Stephane Glondu's avatar
Stephane Glondu committed
303 304 305 306 307 308 309 310
  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
311 312

end