Commit 07dbc36d authored by Stephane Glondu's avatar Stephane Glondu

Move authentication-related stuff to its own module

This is preliminary work to make the authentication system more
flexible. This big refactoring should be semantically equivalent to
the previous commit.

Summary:
 - create Auth_common and Web_signatures
 - split Web_election out of Web_common (to cut dep cycle)
 - move service definitions out of Services
 - functorize Templates
parent d8467999
......@@ -195,3 +195,6 @@ let save_to filename writer x =
Bi_outbuf.add_char ob '\n';
Bi_outbuf.flush_channel_writer ob;
close_out oc;;
module SSet = Set.Make(String)
module SMap = Map.Make(String)
......@@ -62,3 +62,6 @@ val pbkdf2 :
string -> string
val save_to : string -> (Bi_outbuf.t -> 'a -> unit) -> 'a -> unit
module SSet : Set.S with type elt = string
module SMap : Map.S with type key = string
(**************************************************************************)
(* 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 Util
open Web_signatures
open Web_common
type user = {
user_type : string;
user_name : string;
}
type logged_user = {
user_admin : bool;
user_user : user;
}
let string_of_user {user_type; user_name} =
user_type ^ ":" ^ user_name
let user = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
None
let logout = Eliom_service.service
~path:["logout"]
~get_params:Eliom_parameter.unit
()
let create_string_login ~fallback ~post_params =
Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback ~post_params ()
(* TODO: make the authentication system more flexible *)
module Make (C : AUTH_CONFIG) (S : MAIN_SERVICES) (T : TEMPLATES) = struct
let login_dummy = Eliom_service.service
~path:["login-dummy"]
~get_params:Eliom_parameter.unit
()
let login_password = Eliom_service.service
~path:["login-password"]
~get_params:Eliom_parameter.unit
()
let login_admin = Eliom_service.service
~path:["login-admin"]
~get_params:Eliom_parameter.unit
()
let cas_login = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "login"]
~get_params:Eliom_parameter.(string "service")
()
let cas_logout = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "logout"]
~get_params:Eliom_parameter.(string "service")
()
let cas_validate = Eliom_service.external_service
~prefix:C.cas_server
~path:["cas"; "validate"]
~get_params:Eliom_parameter.(string "service" ** string "ticket")
()
let login_cas = Eliom_service.service
~path:["login-cas"]
~get_params:Eliom_parameter.(opt (string "ticket"))
()
let login_default =
if C.enable_dummy then login_dummy
else if C.password_db <> None then login_password
else Eliom_service.preapply login_cas None
let auth_systems =
(if C.enable_cas then [
"CAS", Eliom_service.preapply login_cas None
] else []) @
(if C.password_db <> None then ["password", login_password] else []) @
(if C.enable_dummy then ["dummy", login_dummy] else [])
let () = Eliom_registration.Html5.register
~service:login_dummy
(fun () () ->
if C.enable_dummy then (
let service = create_string_login
~fallback:login_dummy
~post_params:Eliom_parameter.(string "username")
in
let () = Eliom_registration.Redirection.register
~service
~scope:Eliom_common.default_session_scope
(fun () user_name ->
let user_type = "dummy" in
let user_user = {user_type; user_name} in
let user_admin = false in
Eliom_reference.set user (Some {user_admin; user_user}) >>
Web_common.security_log (fun () ->
user_name ^ " successfully logged in using dummy"
) >>
S.get ())
in
T.string_login ~auth_systems ~service ~kind:`Dummy
) else Web_common.fail_http 404
)
let () = Eliom_registration.Html5.register
~service:login_password
(fun () () ->
match C.password_db with
| Some db ->
let service = create_string_login
~fallback:login_password
~post_params:Eliom_parameter.(string "username" ** string "password")
in
let () = Eliom_registration.Redirection.register
~service
~scope:Eliom_common.default_session_scope
(fun () (user_name, password) ->
if (
try
let salt, hashed = SMap.find user_name db in
sha256_hex (salt ^ password) = hashed
with Not_found -> false
) then (
let user_type = "password" in
let user_user = {user_type; user_name} in
let user_admin = false in
Eliom_reference.set user (Some {user_admin; user_user}) >>
security_log (fun () ->
user_name ^ " successfully logged in using password"
) >> S.get ()
) else forbidden ())
in
T.password_login ~auth_systems ~service
| None -> fail_http 404
)
let () = Eliom_registration.Html5.register
~service:login_admin
(fun () () ->
let service = create_string_login
~fallback:login_admin
~post_params:Eliom_parameter.(string "password")
in
let () = Eliom_registration.Redirection.register
~service
~scope:Eliom_common.default_session_scope
(fun () user_name ->
if sha256_hex user_name = C.admin_hash then (
let user_type = "password" in
let user_user = {user_type; user_name} in
let user_admin = true in
Eliom_reference.set user (Some {user_admin; user_user}) >>
security_log (fun () ->
"admin successfully logged in"
) >>
S.get ()
) else forbidden ()
)
in
T.string_login ~auth_systems ~service ~kind:`Admin
)
let next_lf str i =
try Some (String.index_from str i '\n')
with Not_found -> None
let () = Eliom_registration.Redirection.register
~service:login_cas
(fun ticket () -> match ticket with
| Some x ->
let me =
let service = Eliom_service.preapply login_cas None in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
C.rewrite_prefix uri
in
let validation =
let service = Eliom_service.preapply cas_validate (me, x) in
Eliom_uri.make_string_uri ~absolute:true ~service ()
in
lwt reply = Ocsigen_http_client.get_url validation in
(match reply.Ocsigen_http_frame.frame_content with
| Some stream ->
lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
Ocsigen_stream.finalize stream `Success >>
(match next_lf info 0 with
| Some i ->
(match String.sub info 0 i with
| "yes" ->
(match next_lf info (i+1) with
| Some j ->
let user_name = String.sub info (i+1) (j-i-1) in
let user_type = "cas" in
let user_user = {user_type; user_name} in
let user_admin = false in
security_log (fun () ->
user_name ^ " successfully logged in using CAS"
) >>
Eliom_reference.set user
(Some {user_admin; user_user}) >>
S.get ()
| None -> fail_http 502
)
| "no" -> fail_http 401
| _ -> fail_http 502
)
| None -> fail_http 502
)
| None -> fail_http 502
)
| None ->
let service = Eliom_service.preapply login_cas None in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = C.rewrite_prefix uri in
Lwt.return (Eliom_service.preapply cas_login uri)
)
let () = Eliom_registration.Redirection.register
~service:logout
(fun () () ->
lwt u = Eliom_reference.get user in
(* should ballot be unset here or not? *)
Eliom_reference.unset user >>
match u with
| Some u ->
if u.user_user.user_type = "cas" then (
lwt service = S.get () in
let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
let uri = C.rewrite_prefix uri in
security_log (fun () ->
string_of_user u.user_user ^ " logged out, redirecting to CAS"
) >>
Lwt.return (Eliom_service.preapply cas_logout uri)
) else (
security_log (fun () ->
string_of_user u.user_user ^ " logged out"
) >> S.get ()
)
| _ -> S.get ()
)
end
(**************************************************************************)
(* 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/>. *)
(**************************************************************************)
type user = {
user_type : string;
user_name : string;
}
type logged_user = {
user_admin : bool;
user_user : user;
}
val string_of_user : user -> string
val user : logged_user option Eliom_reference.eref
val logout :
(unit, unit,
[> `Attached of
([> `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ], unit, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
open Web_signatures
module Make (C : AUTH_CONFIG) (S : MAIN_SERVICES) (T : TEMPLATES) : AUTH_SERVICES
This diff is collapsed.
......@@ -2,6 +2,8 @@ Util
Serializable_builtin_j
Serializable_j
Web_common
Auth_common
Web_election
Election
Services
Templates
......
......@@ -24,31 +24,6 @@ open Serializable_t
open Eliom_service
open Eliom_parameter
let home = service
~path:[]
~get_params:unit
()
let source_code = service
~path:["belenios.tar.gz"]
~get_params:unit
()
let logout = service
~path:["logout"]
~get_params:unit
()
let create_string_login ~fallback ~post_params =
Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback ~post_params ()
let user = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(None : Web_common.user option)
let ballot = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(None : string option)
......@@ -82,72 +57,17 @@ let string_of_election_file = function
| ESBallots -> "ballots.jsons"
| ESRecords -> "records"
let election_file = Eliom_parameter.user_type
election_file_of_string
string_of_election_file
"file"
let election_dir = service
~path:["elections"]
~get_params:(suffix (uuid ** election_file))
()
let election_index = service
~path:["election"; ""]
~get_params:uuid
()
let election_vote = service
~path:["election"; "vote"]
~get_params:uuid
()
let election_cast = service
~path:["election"; "cast"]
~get_params:uuid
()
let election_cast_post = post_service
~fallback:election_cast
~post_params:(opt (string "encrypted_vote") ** opt (file "encrypted_vote_file"))
()
let election_update_credential_form = service
~path:["election"; "update-cred"]
~get_params:uuid
()
let election_update_credential = post_service
~fallback:election_update_credential_form
~post_params:(string "old_credential" ** string "new_credential")
()
let create_confirm () =
Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback:election_cast
~post_params:Eliom_parameter.unit
()
let get_randomness = service
~path:["get-randomness"]
~get_params:unit
()
let election_booth = static_dir_with_params
~get_params:(string "election_url")
()
let make_booth uuid =
let service = Eliom_service.preapply election_dir (uuid, ESRaw) in
Eliom_service.preapply election_booth (
["booth"; "vote.html"],
Eliom_uri.make_string_uri ~service ()
)
let preapply_uuid s e = Eliom_service.preapply s e.e_uuid
let election_file e f = Eliom_service.preapply election_dir (e.e_uuid, f)
type savable_service =
| Home
......@@ -157,16 +77,3 @@ type savable_service =
let saved_service = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
Home
let to_service = function
| Home -> home
| Cast u -> Eliom_service.preapply election_cast u
| Election u -> Eliom_service.preapply election_index u
open Lwt
let get () =
Eliom_reference.get saved_service >>= wrap1 to_service
let set s =
Eliom_reference.set saved_service s
......@@ -30,17 +30,19 @@ let site_title = "Election Server"
let welcome_message = "Welcome!"
let format_user u =
em [pcdata (Web_common.string_of_user u)]
em [pcdata (Auth_common.(string_of_user u.user_user))]
module Make (S : Web_signatures.MAIN_SERVICES) = struct
let base ~auth_systems ~title ~content =
lwt user = Eliom_reference.get Services.user in
lwt user = Eliom_reference.get Auth_common.user in
Lwt.return (html ~a:[a_dir `Ltr; a_xml_lang "en"]
(head (Eliom_content.Html5.F.title (pcdata title)) [])
(body [
div ~a:[a_id "header"] [
div [
div ~a:[a_style "float: left;"] [
a ~service:Services.home [pcdata site_title] ();
a ~service:S.home [pcdata site_title] ();
];
div ~a:[a_style "float: right; text-align: right;"] (
match user with
......@@ -52,7 +54,7 @@ let base ~auth_systems ~title ~content =
pcdata ".";
];
div [
a ~service:Services.logout [pcdata "Log out"] ();
a ~service:Auth_common.logout [pcdata "Log out"] ();
pcdata ".";
];
]
......@@ -78,7 +80,7 @@ let base ~auth_systems ~title ~content =
hr ();
div ~a:[a_id "footer"; a_style "text-align: center;" ] [
pcdata "Powered by ";
a ~service:Services.source_code [pcdata "Belenios"] ();
a ~service:S.source_code [pcdata "Belenios"] ();
pcdata ".";
]
]))
......@@ -86,14 +88,14 @@ let base ~auth_systems ~title ~content =
let format_one_featured_election e =
li [
h3 [
a ~service:Services.(preapply_uuid election_index e)
a ~service:(Services.preapply_uuid S.election_index e)
[pcdata e.e_name] ();
];
p [pcdata e.e_description];
]
let index ~auth_systems ~featured =
lwt user = Eliom_reference.get Services.user in
lwt user = Eliom_reference.get Auth_common.user in
let featured_box = match featured with
| _::_ ->
div [
......@@ -175,9 +177,9 @@ let make_button ~service contents =
contents
let election_view ~auth_systems ~election ~user =
let open Web_common in
let open Web_election in
let params = election.election.e_params in
let service = Services.(election_file params ESRaw) in
let service = S.election_file params Services.ESRaw in
lwt permissions =
match election.election_web.can_vote with
| Any ->
......@@ -189,7 +191,7 @@ let election_view ~auth_systems ~election ~user =
pcdata "Log in to check if you can vote. Alternatively, you can try to vote and log in at the last moment.";
]
| Some u ->
lwt b = p u in
lwt b = p u.Auth_common.user_user in
let can = if b then pcdata "can" else pcdata "cannot" in
Lwt.return [
pcdata "You ";
......@@ -222,15 +224,15 @@ let election_view ~auth_systems ~election ~user =
pcdata "Election data: ";
a ~service [ pcdata "parameters" ] ();
pcdata ", ";
a ~service:Services.(election_file params ESCreds) [
a ~service:(S.election_file params Services.ESCreds) [
pcdata "public credentials"
] ();
pcdata ", ";
a ~service:Services.(election_file params ESKeys) [
a ~service:(S.election_file params Services.ESKeys) [
pcdata "trustee public keys"
] ();
pcdata ", ";
a ~service:Services.(election_file params ESBallots) [
a ~service:(S.election_file params Services.ESBallots) [
pcdata "ballots";
] ();
pcdata ".";
......@@ -247,11 +249,11 @@ let election_view ~auth_systems ~election ~user =
div [
div [
make_button
~service:(Services.(preapply_uuid election_vote params))
~service:(Services.preapply_uuid S.election_vote params)
"Go to the booth";
pcdata " or ";
make_button
~service:(Services.(preapply_uuid election_cast params))
~service:(Services.preapply_uuid S.election_cast params)
"Submit a raw ballot";
];
];
......@@ -261,9 +263,9 @@ let election_view ~auth_systems ~election ~user =
base ~auth_systems ~title:params.e_name ~content
let election_cast_raw ~election =
let open Web_common in
let open Web_election in
let params = election.election.e_params in
let form_rawballot = post_form ~service:Services.election_cast_post
let form_rawballot = post_form ~service:S.election_cast_post
(fun (name, _) ->
[
div [pcdata "Please paste your raw ballot in JSON format in the following box:"];
......@@ -272,7 +274,7 @@ let election_cast_raw ~election =
]
) params.e_uuid
in
let form_upload = post_form ~service:Services.election_cast_post
let form_upload = post_form ~service:S.election_cast_post
(fun (_, name) ->
[
div [pcdata "Alternatively, you can also upload a file containing your ballot:"];
......@@ -294,7 +296,7 @@ let election_cast_raw ~election =
base ~title:params.e_name ~content
let ballot_received ~election ~confirm ~user ~can_vote =
let open Web_common in
let open Web_election in
let params = election.election.e_params in
let name = params.e_name in
let user_div = match user with
......@@ -327,7 +329,7 @@ let ballot_received ~election ~confirm ~user ~can_vote =
];
user_div;
p [
a ~service:(Services.(preapply_uuid election_index params)) [
a ~service:(Services.preapply_uuid S.election_index params) [
pcdata "Go back to election"
] ();
pcdata ".";
......@@ -336,7 +338,7 @@ let ballot_received ~election ~confirm ~user ~can_vote =
base ~title:name ~content
let do_cast_ballot ~election ~result =
let params = election.Web_common.election.e_params in
let params = election.Web_election.election.e_params in
let name = params.e_name in
let content = [
h1 [ pcdata name ];
......@@ -349,7 +351,7 @@ let do_cast_ballot ~election ~result =
);
];
p [
a ~service:(Services.(preapply_uuid election_index params)) [
a ~service:(Services.preapply_uuid S.election_index params) [
pcdata "Go back to election"
] ();
pcdata ".";
......@@ -358,8 +360,8 @@ let do_cast_ballot ~election ~result =
base ~title:name ~content
let election_update_credential ~election =
let params = election.Web_common.election.e_params in
let form = post_form ~service:Services.election_update_credential
let params = election.Web_election.election.e_params in
let form = post_form ~service:S.election_update_credential
(fun (old, new_) ->
[
div [
......@@ -394,3 +396,5 @@ the hash of a credential, run the following command:";
form;
] in
base ~title:params.e_name ~content
end
......@@ -25,38 +25,6 @@ open Util
open Serializable_builtin_t
open Serializable_t
type user_type = Dummy | Password | CAS | Admin
type user = {
user_name : string;
user_type : user_type;
}
let string_of_user {user_name; user_type} =
match user_type with
| Dummy -> Printf.sprintf "dummy:%s" user_name
| Password -> Printf.sprintf "password:%s" user_name
| CAS -> user_name
| Admin -> Printf.sprintf "admin:%s" user_name
let is_admin = function
| Some { user_name = _; user_type = Admin } -> true
| _ -> false
type acl =
| Any
| Restricted of (user -> bool Lwt.t)
module SSet = Set.Make(String)
type election_web = {
params_fname : string;
public_keys_fname : string;
featured_p : bool;
can_read : acl;
can_vote : acl;
}
let enforce_single_element s =
let open Lwt_stream in
lwt t = next s in
......@@ -157,208 +125,10 @@ let security_log s =
Lwt_io.flush ic
) ic
module type WEB_BALLOT_BOX = sig
module Ballots : Signatures.MONADIC_MAP_RO
with type 'a m = 'a Lwt.t
and type elt = string
and type key = string
module Records : Signatures.MONADIC_MAP_RO
with type 'a m = 'a Lwt.t
and type elt = Serializable_builtin_t.datetime * string
and type key = string
val cast : string -> string * datetime -> string Lwt.t
val inject_creds : SSet.t -> unit Lwt.t
val extract_creds : unit -> SSet.t Lwt.t
val update_cred : old:string -> new_:string -> unit Lwt.t
end
module type WEB_ELECTION_BUNDLE =
Signatures.ELECTION_BUNDLE with type 'a E.m = 'a Lwt.t
module type WEB_BALLOT_BOX_BUNDLE = sig
include WEB_ELECTION_BUNDLE
module B : WEB_BALLOT_BOX
end
type 'a web_election = {
modules : (module WEB_BALLOT_BOX_BUNDLE with type elt = 'a);
election : 'a Signatures.election;
election_web : election_web;
}
let make_web_election raw_election e_meta election_web =
let e_fingerprint = sha256_b64 raw_election in
let wrapped_params = Serializable_j.params_of_string
Serializable_j.read_ff_pubkey raw_election
in
let {ffpk_g = g; ffpk_p = p; ffpk_q = q; ffpk_y = y} = wrapped_params.e_public_key in
let group = {g; p; q} in
let e_params = { wrapped_params with e_public_key = y } in
let election = {e_params; e_meta; e_pks = None; e_fingerprint} in
let module X : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t = struct
type elt = Z.t