diff --git a/auth/builder_web_auth.ml b/auth/builder_web_auth.ml index e044b57..e05e0ca 100644 --- a/auth/builder_web_auth.ml +++ b/auth/builder_web_auth.ml @@ -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 = diff --git a/bin/builder_db.ml b/bin/builder_db.ml index c55672a..be5bce3 100644 --- a/bin/builder_db.ml +++ b/bin/builder_db.ml @@ -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 diff --git a/bin/migrations/builder_migrations.ml b/bin/migrations/builder_migrations.ml index 9ad011f..8ae15d2 100644 --- a/bin/migrations/builder_migrations.ml +++ b/bin/migrations/builder_migrations.ml @@ -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 diff --git a/bin/migrations/m20210608.ml b/bin/migrations/m20210608.ml new file mode 100644 index 0000000..5b66686 --- /dev/null +++ b/bin/migrations/m20210608.ml @@ -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) () diff --git a/db/builder_db.ml b/db/builder_db.ml index fc2eac0..da79b16 100644 --- a/db/builder_db.ml +++ b/db/builder_db.ml @@ -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; diff --git a/db/builder_db.mli b/db/builder_db.mli index 9cdb99c..3639297 100644 --- a/db/builder_db.mli +++ b/db/builder_db.mli @@ -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 : diff --git a/db/representation.ml b/db/representation.ml index dc7378d..dc59122 100644 --- a/db/representation.ml +++ b/db/representation.ml @@ -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 diff --git a/lib/authorization.ml b/lib/authorization.ml new file mode 100644 index 0000000..3a24ad3 --- /dev/null +++ b/lib/authorization.ml @@ -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 () diff --git a/lib/builder_web.ml b/lib/builder_web.ml index ac0376e..aad9388 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -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)); ] diff --git a/lib/model.ml b/lib/model.ml index 85ece75..b7735d7 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -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 = diff --git a/lib/model.mli b/lib/model.mli index 3542d17..5b46d48 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -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 -> diff --git a/test/builder_db.ml b/test/builder_db.ml index 892afe2..69a1dd9 100644 --- a/test/builder_db.ml +++ b/test/builder_db.ml @@ -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