Add an access_list to grant per-job user upload permissions

Fixes #36

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 =

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

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

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

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)
+           scrypt_n, scrypt_r, scrypt_p, restricted)
-         VALUES (?, ?, ?, ?, ?, ?)
+         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;

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 :

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

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

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));
   ]

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 >|=
+  Db.find_opt Builder_db.User.get_user username
-  Option.map snd
+
+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 =

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 ->

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
+        Format.fprintf ppf "user:%s;(%d,%d,%d);%B;%a;%a" username
-          scrypt_n scrypt_r scrypt_p
+          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