robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add an access_list to grant per-job user upload permissions

Browse source 
Fixes #36
This commit is contained in:
Robur 2021-06-08 14:54:23 +00:00
parent d986d614a8
commit eaf8a609c9
12 changed files with 329 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
auth/builder_web_auth.ml
View file

@ -21,6 +21,7 @@ type password_hash = [ pbkdf2_sha256 | scrypt ]
type 'a user_info = {
username : string;
password_hash : [< password_hash ] as 'a;
restricted : bool;
}
let pbkdf2_sha256 ~params:{ pbkdf2_sha256_iter = count } ~salt ~password =
@ -30,12 +31,13 @@ let scrypt ~params:{ scrypt_n = n; scrypt_r = r; scrypt_p = p } ~salt ~password
Scrypt_kdf.scrypt_kdf ~n ~r ~p ~dk_len:32l ~salt ~password:(Cstruct.of_string password)
let hash ?(scrypt_params=scrypt_params ())
~username ~password () =
~username ~password ~restricted () =
let salt = Mirage_crypto_rng.generate 16 in
let password_hash = scrypt ~params:scrypt_params ~salt ~password in
{
username;
password_hash = `Scrypt (password_hash, salt, scrypt_params)
password_hash = `Scrypt (password_hash, salt, scrypt_params);
restricted;
}
let verify_password password user_info =

64
bin/builder_db.ml
View file

@ -2,7 +2,10 @@ open Rresult.R.Infix
let or_die exit_code = function
| Ok r -> r
| Error e ->
| Error (`Msg msg) ->
Format.eprintf "Error: %s" msg;
exit exit_code
| Error (#Caqti_error.t as e) ->
Format.eprintf "Database error: %a" Caqti_error.pp e;
exit exit_code
@ -20,7 +23,7 @@ let do_migrate dbpath =
let migrate () dbpath =
or_die 1 (do_migrate dbpath)
let user_mod action dbpath scrypt_n scrypt_r scrypt_p username =
let user_mod action dbpath scrypt_n scrypt_r scrypt_p username unrestricted =
let scrypt_params = Builder_web_auth.scrypt_params ?scrypt_n ?scrypt_r ?scrypt_p () in
let r =
Caqti_blocking.connect
@ -30,7 +33,8 @@ let user_mod action dbpath scrypt_n scrypt_r scrypt_p username =
flush stdout;
(* FIXME: getpass *)
let password = read_line () in
let user_info = Builder_web_auth.hash ~scrypt_params ~username ~password () in
let restricted = not unrestricted in
let user_info = Builder_web_auth.hash ~scrypt_params ~username ~password ~restricted () in
match action with
| `Add ->
Db.exec Builder_db.User.add user_info
@ -59,10 +63,37 @@ let user_remove () dbpath username =
Caqti_blocking.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.exec Builder_db.Access_list.remove_all_by_username username >>= fun () ->
Db.exec Builder_db.User.remove_user username
in
or_die 1 r
let access_add () dbpath username jobname =
let r =
Caqti_blocking.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.find_opt Builder_db.User.get_user username >>= function
| None -> Error (`Msg "unknown user")
| Some (user_id, _) ->
Db.find Builder_db.Job.get_id_by_name jobname >>= fun job_id ->
Db.exec Builder_db.Access_list.add (user_id, job_id)
in
or_die 1 r
let access_remove () dbpath username jobname =
let r =
Caqti_blocking.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.find_opt Builder_db.User.get_user username >>= function
| None -> Error (`Msg "unknown user")
| Some (user_id, _) ->
Db.find Builder_db.Job.get_id_by_name jobname >>= fun job_id ->
Db.exec Builder_db.Access_list.remove (user_id, job_id)
in
or_die 1 r
let help man_format cmds = function
| None -> `Help (man_format, None)
| Some cmd ->
@ -112,6 +143,16 @@ let scrypt_p =
opt (some int) None &
info ~doc ["scrypt-p"])
let unrestricted =
let doc = "unrestricted user" in
Cmdliner.Arg.(value & flag & info ~doc [ "unrestricted" ])
let job =
let doc = "job" in
Cmdliner.Arg.(required &
pos 1 (some string) None &
info ~doc ~docv:"JOB" [])
let setup_log =
let setup_log level =
Logs.set_level level;
@ -127,12 +168,12 @@ let migrate_cmd =
let user_add_cmd =
let doc = "add a user" in
(Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username),
(Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
Cmdliner.Term.info ~doc "user-add")
let user_update_cmd =
let doc = "update a user password" in
(Cmdliner.Term.(pure user_update $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username),
(Cmdliner.Term.(pure user_update $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
Cmdliner.Term.info ~doc "user-update")
let user_remove_cmd =
@ -145,6 +186,16 @@ let user_list_cmd =
(Cmdliner.Term.(pure user_list $ setup_log $ dbpath),
Cmdliner.Term.info ~doc "user-list")
let access_add_cmd =
let doc = "grant access to user and job" in
(Cmdliner.Term.(pure access_add $ setup_log $ dbpath $ username $ job),
Cmdliner.Term.info ~doc "access-add")
let access_remove_cmd =
let doc = "remove access to user and job" in
(Cmdliner.Term.(pure access_remove $ setup_log $ dbpath $ username $ job),
Cmdliner.Term.info ~doc "access-remove")
let help_cmd =
let topic =
let doc = "Command to get help on" in
@ -164,5 +215,6 @@ let () =
Cmdliner.Term.eval_choice
default_cmd
[help_cmd; migrate_cmd;
user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd]
user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd;
access_add_cmd; access_remove_cmd]
|> Cmdliner.Term.exit

11
bin/migrations/builder_migrations.ml
View file

@ -135,6 +135,16 @@ let r20210602 =
Cmdliner.Term.(const do_database_action $ const M20210602.rollback $ setup_log $ datadir),
Cmdliner.Term.info ~doc "rollback-2021-06-02"
let m20210608 =
let doc = "add access list" in
Cmdliner.Term.(const do_database_action $ const M20210608.migrate $ setup_log $ datadir),
Cmdliner.Term.info ~doc "migrate-2021-06-08"
let r20210608 =
let doc = "remove access list" in
Cmdliner.Term.(const do_database_action $ const M20210608.rollback $ setup_log $ datadir),
Cmdliner.Term.info ~doc "rollback-2021-06-08"
let help_cmd =
let topic =
let doc = "Migration to get help on" in
@ -161,5 +171,6 @@ let () =
m20210427; r20210427;
m20210531; r20210531;
m20210602; r20210602;
m20210608; r20210608;
]
|> Cmdliner.Term.exit

108
bin/migrations/m20210608.ml Normal file
View file

@ -0,0 +1,108 @@
open Rresult.R.Infix
let new_version = 6L and old_version = 5L
let new_user =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE new_user (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
username VARCHAR(255) NOT NULL UNIQUE,
password_hash BLOB NOT NULL,
password_salt BLOB NOT NULL,
scrypt_n INTEGER NOT NULL,
scrypt_r INTEGER NOT NULL,
scrypt_p INTEGER NOT NULL,
restricted BOOLEAN NOT NULL
)
|}
let old_user =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE new_user (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
username VARCHAR(255) NOT NULL UNIQUE,
password_hash BLOB NOT NULL,
password_salt BLOB NOT NULL,
scrypt_n INTEGER NOT NULL,
scrypt_r INTEGER NOT NULL,
scrypt_p INTEGER NOT NULL
)
|}
let collect_old_user =
Caqti_request.collect
Caqti_type.unit
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64))
"SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p FROM user"
let collect_new_user =
Caqti_request.collect
Caqti_type.unit
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool))
"SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user"
let insert_new_user =
Caqti_request.exec
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool))
"INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
let insert_old_user =
Caqti_request.exec
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64))
"INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p) VALUES (?, ?, ?, ?, ?, ?, ?)"
let drop_user =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE user"
let rename_new_user =
Caqti_request.exec
Caqti_type.unit
"ALTER TABLE new_user RENAME TO user"
let access_list =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE access_list (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
user INTEGER NOT NULL,
job INTEGER NOT NULL,
FOREIGN KEY(user) REFERENCES user(id),
FOREIGN KEY(job) REFERENCES job(id),
UNIQUE(user, job)
)
|}
let rollback_access_list =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE IF EXISTS access_list"
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
Db.exec new_user () >>= fun () ->
Db.collect_list collect_old_user () >>= fun users ->
Grej.list_iter_result (fun (id, username, (password_hash, password_salt), (scrypt_n, scrypt_r, scrypt_p)) ->
Db.exec insert_new_user (id, username, (password_hash, password_salt), (scrypt_n, scrypt_r, scrypt_p, false)))
users >>= fun () ->
Db.exec drop_user () >>= fun () ->
Db.exec rename_new_user () >>= fun () ->
Db.exec access_list () >>= fun () ->
Db.exec (Grej.set_version new_version) ()
let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
Db.exec old_user () >>= fun () ->
Db.collect_list collect_new_user () >>= fun users ->
Grej.list_iter_result (fun (id, username, (password_hash, password_salt), (scrypt_n, scrypt_r, scrypt_p, restricted)) ->
if restricted then Logs.warn (fun m -> m "elevating privileges of restricted user %s" username);
Db.exec insert_old_user (id, username, (password_hash, password_salt), (scrypt_n, scrypt_r, scrypt_p)))
users >>= fun () ->
Db.exec drop_user () >>= fun () ->
Db.exec rename_new_user () >>= fun () ->
Db.exec rollback_access_list () >>= fun () ->
Db.exec (Grej.set_version old_version) ()

59
db/builder_db.ml
View file

@ -4,7 +4,7 @@ open Rep
let application_id = 1234839235l
(* Please update this when making changes! *)
let current_version = 5L
let current_version = 6L
type id = Rep.id
@ -457,7 +457,8 @@ module User = struct
password_salt BLOB NOT NULL,
scrypt_n INTEGER NOT NULL,
scrypt_r INTEGER NOT NULL,
scrypt_p INTEGER NOT NULL
scrypt_p INTEGER NOT NULL,
restricted BOOLEAN NOT NULL
)
|}
@ -471,7 +472,7 @@ module User = struct
Caqti_type.string
(Caqti_type.tup2 id user_info)
{| SELECT id, username, password_hash, password_salt,
scrypt_n, scrypt_r, scrypt_p
scrypt_n, scrypt_r, scrypt_p, restricted
FROM user
WHERE username = ?
|}
@ -486,8 +487,8 @@ module User = struct
Caqti_request.exec
user_info
{| INSERT INTO user (username, password_hash, password_salt,
scrypt_n, scrypt_r, scrypt_p)
VALUES (?, ?, ?, ?, ?, ?)
scrypt_n, scrypt_r, scrypt_p, restricted)
VALUES (?, ?, ?, ?, ?, ?, ?)
|}
let remove =
@ -508,17 +509,62 @@ module User = struct
password_salt = ?3,
scrypt_n = ?4,
scrypt_r = ?5,
scrypt_p = ?6
scrypt_p = ?6,
restricted = ?7
WHERE username = ?1
|}
end
module Access_list = struct
let migrate =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE access_list (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
user INTEGER NOT NULL,
job INTEGER NOT NULL,
FOREIGN KEY(user) REFERENCES user(id),
FOREIGN KEY(job) REFERENCES job(id),
UNIQUE(user, job)
)
|}
let rollback =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE IF EXISTS access_list"
let get =
Caqti_request.find
Caqti_type.(tup2 Rep.id Rep.id)
Rep.id
"SELECT id FROM access_list WHERE user = ? AND job = ?"
let add =
Caqti_request.exec
Caqti_type.(tup2 Rep.id Rep.id)
"INSERT INTO access_list (user, job) VALUES (?, ?)"
let remove =
Caqti_request.exec
Caqti_type.(tup2 Rep.id Rep.id)
"DELETE FROM access_list WHERE user = ? AND job = ?"
let remove_all_by_username =
Caqti_request.exec
Caqti_type.string
"DELETE FROM access_list, user WHERE access_list.user = user.id AND user.username = ?"
end
let migrate = [
Job.migrate;
Build.migrate;
Build_artifact.migrate;
Build_file.migrate;
User.migrate;
Access_list.migrate;
Caqti_request.exec Caqti_type.unit
"CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)";
set_current_version;
@ -526,6 +572,7 @@ let migrate = [
]
let rollback = [
Access_list.rollback;
User.rollback;
Build_file.migrate;
Build_artifact.rollback;

15
db/builder_db.mli
View file

@ -182,6 +182,21 @@ module User : sig
Caqti_request.t
end
module Access_list : sig
val migrate :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val rollback :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val get :
(id * id, id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
val add :
(id * id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val remove :
(id * id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val remove_all_by_username :
(string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
end
val migrate :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t list
val rollback :

12
db/representation.ml
View file

@ -107,18 +107,20 @@ let console =
Caqti_type.custom ~encode ~decode cstruct
let user_info =
let rep = Caqti_type.(tup4 string cstruct cstruct (tup3 int int int)) in
let rep = Caqti_type.(tup4 string cstruct cstruct (tup4 int int int bool)) in
let encode { Builder_web_auth.username;
password_hash = `Scrypt (password_hash, password_salt, {
Builder_web_auth.scrypt_n; scrypt_r; scrypt_p
}) }
});
restricted; }
=
Ok (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p))
Ok (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted))
in
let decode (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p)) =
let decode (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted)) =
Ok { Builder_web_auth.username;
password_hash =
`Scrypt (password_hash, password_salt,
{ Builder_web_auth.scrypt_n;
scrypt_r; scrypt_p }) } in
scrypt_r; scrypt_p });
restricted; } in
Caqti_type.custom ~encode ~decode rep

54
lib/authorization.ml Normal file
View file

@ -0,0 +1,54 @@
let src = Logs.Src.create "authorization" ~doc:"Builder_web authorization"
module Log = (val Logs.src_log src : Logs.LOG)
open Lwt.Syntax
let realm = "builder-web"
let user_info_local = Dream.new_local ~name:"user_info" ()
let authenticate handler = fun req ->
let unauthorized () =
let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in
Dream.respond ~headers ~status:`Unauthorized "Forbidden!"
in
match Dream.header "Authorization" req with
| None -> unauthorized ()
| Some data -> match String.split_on_char ' ' data with
| [ "Basic" ; user_pass ] ->
(match Base64.decode user_pass with
| Error `Msg msg ->
Log.info (fun m -> m "Invalid user / pasword encoding in %S: %S" data msg);
Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
| Ok user_pass -> match String.split_on_char ':' user_pass with
| [] | [_] ->
Log.info (fun m -> m "Invalid user / pasword encoding in %S" data);
Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
| user :: password ->
let pass = String.concat ":" password in
let* user_info = Dream.sql req (Model.user user) in
match user_info with
| Ok (Some (id, user_info)) ->
if Builder_web_auth.verify_password pass user_info
then handler (Dream.with_local user_info_local (id, user_info) req)
else unauthorized ()
| Ok None ->
let _ : _ Builder_web_auth.user_info =
Builder_web_auth.hash ~username:user ~password:pass ~restricted:true () in
unauthorized ()
| Error e ->
Log.warn (fun m -> m "Error getting user: %a" Model.pp_error e);
Dream.respond ~status:`Internal_Server_Error "Internal server error")
| _ ->
Log.warn (fun m -> m "Error retrieving authorization %S" data);
Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
let authorized req job_name =
match Dream.local user_info_local req with
| None -> Lwt.return (Error (`Msg "not authenticated"))
| Some (id, user) ->
if user.restricted then
Dream.sql req (Model.authorized id job_name)
else
Lwt_result.return ()

44
lib/builder_web.ml
View file

@ -12,8 +12,6 @@ let pp_error ppf = function
then Format.fprintf ppf "Wrong database version: %Ld" version
else Format.fprintf ppf "Wrong database application id: %ld" application_id
let realm = "builder-web"
let init_datadir datadir =
let open Rresult.R.Infix in
Bos.OS.Dir.exists datadir >>= (fun exists ->
@ -70,42 +68,6 @@ let if_error ~status ?(log=(fun e -> Log.warn (fun m -> m "%s: %a" (Dream.status
Lwt_result.fail (message, status)
| Ok _ as r -> Lwt.return r
let authorized handler = fun req ->
let unauthorized () =
let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in
Dream.respond ~headers ~status:`Unauthorized "Forbidden!"
in
match Dream.header "Authorization" req with
| None -> unauthorized ()
| Some data -> match String.split_on_char ' ' data with
| [ "Basic" ; user_pass ] ->
(match Base64.decode user_pass with
| Error `Msg msg ->
Log.info (fun m -> m "Invalid user / pasword encoding in %S: %S" data msg);
Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
| Ok user_pass -> match String.split_on_char ':' user_pass with
| [] | [_] ->
Log.info (fun m -> m "Invalid user / pasword encoding in %S" data);
Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
| user :: password ->
let pass = String.concat ":" password in
let* user_info = Dream.sql req (Model.user user) in
match user_info with
| Ok (Some user_info) ->
if Builder_web_auth.verify_password pass user_info
then handler req
else unauthorized ()
| Ok None ->
let _ : _ Builder_web_auth.user_info =
Builder_web_auth.hash ~username:user ~password:pass () in
unauthorized ()
| Error e ->
Log.warn (fun m -> m "Error getting user: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Internal server error")
| _ ->
Log.warn (fun m -> m "Error retrieving authorization %S" data);
Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
let string_of_html =
Format.asprintf "%a" (Tyxml.Html.pp ())
@ -213,8 +175,10 @@ let add_routes datadir =
|> if_error ~status:`Bad_Request "Bad request"
~log:(fun e ->
Log.warn (fun m -> m "Received bad builder ASN.1: %a" pp_error e))
>>= fun ((_, uuid, _, _, _, _, _) as exec) ->
>>= fun (({ name ; _ }, uuid, _, _, _, _, _) as exec) ->
Log.debug (fun m -> m "Received build %a" pp_exec exec);
Authorization.authorized req name
|> if_error ~status:`Forbidden "Forbidden" >>= fun () ->
Dream.sql req (Model.build_exists uuid)
|> if_error ~status:`Internal_Server_Error "Internal server error"
~log:(fun e ->
@ -285,5 +249,5 @@ let add_routes datadir =
Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
Dream.get "/hash" (w hash);
Dream.get "/compare/:build_left/:build_right/opam-switch" (w compare_opam);
Dream.post "/upload" (authorized (w upload));
Dream.post "/upload" (Authorization.authenticate (w upload));
]

8
lib/model.ml
View file

@ -92,8 +92,12 @@ let job_name id (module Db : CONN) =
Db.find Builder_db.Job.get id
let user username (module Db : CONN) =
Db.find_opt Builder_db.User.get_user username >|=
Option.map snd
Db.find_opt Builder_db.User.get_user username
let authorized user_id job_name (module Db : CONN) =
job_id job_name (module Db) >>= fun job_id ->
Db.find Builder_db.Access_list.get (user_id, job_id) >|= fun _id ->
()
let cleanup_staging datadir (module Db : Caqti_lwt.CONNECTION) =
let cleanup_staged staged =

3
lib/model.mli
View file

@ -55,8 +55,9 @@ val job_name : Builder_db.id -> Caqti_lwt.connection ->
(string, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val user : string -> Caqti_lwt.connection ->
(Builder_web_auth.scrypt Builder_web_auth.user_info option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
((Builder_db.id * Builder_web_auth.scrypt Builder_web_auth.user_info) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val authorized : Builder_db.id -> string -> Caqti_lwt.connection -> (unit, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val add_build :
Fpath.t ->

12
test/builder_db.ml
View file

@ -19,17 +19,18 @@ module Testable = struct
let builder_web_auth =
let equal (x : _ Builder_web_auth.user_info) (y : _ Builder_web_auth.user_info) =
x.username = y.username &&
x.restricted = y.restricted &&
match x.password_hash, y.password_hash with
| `Scrypt (hash, salt, params), `Scrypt (hash', salt', params') ->
Cstruct.equal hash hash' &&
Cstruct.equal salt salt' &&
params = params'
in
let pp ppf { Builder_web_auth.username; password_hash } =
let pp ppf { Builder_web_auth.username; password_hash; restricted } =
match password_hash with
| `Scrypt (hash, salt, { Builder_web_auth.scrypt_n; scrypt_r; scrypt_p }) ->
Format.fprintf ppf "user:%s;(%d,%d,%d);%a;%a" username
scrypt_n scrypt_r scrypt_p
Format.fprintf ppf "user:%s;(%d,%d,%d);%B;%a;%a" username
scrypt_n scrypt_r scrypt_p restricted
Cstruct.hexdump_pp hash Cstruct.hexdump_pp salt
in
Alcotest.testable
@ -67,8 +68,9 @@ let setup_db () =
let scrypt_params = Builder_web_auth.scrypt_params
~scrypt_n:1024 ~scrypt_r:1 ()
let username = "test" and password = "testtest"
let restricted = false
(* Bad, but fast *)
let auth = Builder_web_auth.hash ~scrypt_params ~username ~password ()
let auth = Builder_web_auth.hash ~scrypt_params ~username ~password ~restricted ()
let add_test_user (module Db : CONN) =
Db.exec Builder_db.User.add auth
@ -96,7 +98,7 @@ let test_user_remove_user (module Db : CONN) =
let test_user_update (module Db : CONN) =
let auth' = Builder_web_auth.hash ~scrypt_params ~username
~password:"differentpassword" () in
~password:"differentpassword" ~restricted () in
Db.exec Builder_db.User.update_user auth' >>= fun () ->
Db.find_opt Builder_db.User.get_user username >>| fun res ->
let auth_opt = Option.map snd res in