User authentication and upload endpoint

pull/19/head
Reynir Björnsson 2 years ago
parent 1771c47989
commit 01babd0d0d
  1. 52
      auth/builder_web_auth.ml
  2. 3
      auth/dune
  3. 84
      bin/builder_db.ml
  4. 1
      bin/builder_web_app.ml
  5. 4
      bin/dune
  6. 63
      db/builder_db.ml
  7. 22
      db/builder_db.mli
  8. 2
      db/dune
  9. 11
      db/representation.ml
  10. 43
      lib/builder_web.ml
  11. 32
      lib/model.ml
  12. 10
      lib/model.mli

@ -0,0 +1,52 @@
let prf : Mirage_crypto.Hash.hash = `SHA256
let default_count = 160_000
let dk_len = 32l
type user_info = {
username : string;
password_hash : Cstruct.t;
password_salt : Cstruct.t;
password_iter : int;
}
module SMap = Map.Make(String)
type t = user_info SMap.t
let user_info_to_sexp { username; password_hash; password_salt; password_iter } =
Sexplib.Sexp.(List [
Atom "user_info";
Atom username;
Atom (Cstruct.to_string password_hash);
Atom (Cstruct.to_string password_salt);
Sexplib.Conv.sexp_of_int password_iter;
])
let user_info_of_sexp =
let open Sexplib.Sexp in
function
| List [ Atom "user_info";
Atom username;
Atom password_hash;
Atom password_salt;
(Atom _ ) as password_iter; ] ->
{ username;
password_hash = Cstruct.of_string password_hash;
password_salt = Cstruct.of_string password_salt;
password_iter = Sexplib.Conv.int_of_sexp password_iter; }
| sexp ->
Sexplib.Conv.of_sexp_error "Auth_store.user_info_of_sexp: bad sexp" sexp
let h count salt password =
Pbkdf.pbkdf2 ~prf ~count ~dk_len ~salt ~password:(Cstruct.of_string password)
let hash ~username ~password =
let salt = Mirage_crypto_rng.generate 16 in
let password_iter = default_count in
let password_hash = h password_iter salt password in
{ username; password_hash; password_salt = salt; password_iter }
let verify_password password user_info =
Cstruct.equal
(h user_info.password_iter user_info.password_salt password)
user_info.password_hash

@ -0,0 +1,3 @@
(library
(name builder_web_auth)
(libraries pbkdf mirage-crypto-rng sexplib))

@ -1,5 +1,11 @@
open Rresult.R.Infix
let or_die exit_code = function
| Ok r -> r
| Error e ->
Format.eprintf "Database error: %a" Caqti_error.pp e;
exit exit_code
let save_data outputdir (filepath, data) =
let localpath = Fpath.(outputdir // filepath) in
(* FIXME: return an error?! *)
@ -117,11 +123,49 @@ let do_migrate dbpath =
Builder_db.migrate
let migrate () dbpath =
match do_migrate dbpath with
| Ok () -> ()
| Error e ->
Format.eprintf "Database error: %a" Caqti_error.pp e;
exit 1
or_die 1 (do_migrate dbpath)
let user_mod action dbpath username =
let r =
Caqti_blocking.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
print_string "Password: ";
flush stdout;
(* FIXME: getpass *)
let password = read_line () in
let user_info = Builder_web_auth.hash ~username ~password in
match action with
| `Add ->
Db.exec Builder_db.User.add user_info
| `Update ->
Db.exec Builder_db.User.update_user user_info
in
or_die 1 r
let user_add () dbpath username = user_mod `Add dbpath username
let user_update () dbpath username = user_mod `Update dbpath username
let user_list () dbpath =
let r =
Caqti_blocking.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.iter_s Builder_db.User.get_all
(fun username -> Ok (print_endline username))
()
in
or_die 1 r
let user_remove () dbpath username =
let r =
Caqti_blocking.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.exec Builder_db.User.remove_user username
in
or_die 1 r
let help man_format cmds = function
| None -> `Help (man_format, None)
@ -142,6 +186,12 @@ let dbpath_new =
opt string "builder.sqlite3" &
info ~doc ["dbpath"])
let username =
let doc = "username" in
Cmdliner.Arg.(required &
pos 0 (some string) None &
info ~doc ~docv:"USERNAME" [])
let datadir =
let doc = Cmdliner.Arg.info ~doc:"builder data dir" ["datadir"] in
Cmdliner.Arg.(value &
@ -175,6 +225,26 @@ let add_cmd =
(Cmdliner.Term.(pure add $ setup_log $ dbpath $ datadir),
Cmdliner.Term.info ~doc ~man "add")
let user_add_cmd =
let doc = "add a user" in
(Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ username),
Cmdliner.Term.info ~doc "user-add")
let user_update_cmd =
let doc = "update a user password" in
(Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ username),
Cmdliner.Term.info ~doc "user-update")
let user_remove_cmd =
let doc = "remove a user" in
(Cmdliner.Term.(pure user_remove $ setup_log $ dbpath $ username),
Cmdliner.Term.info ~doc "user-remove")
let user_list_cmd =
let doc = "list all users" in
(Cmdliner.Term.(pure user_list $ setup_log $ dbpath),
Cmdliner.Term.info ~doc "user-list")
let help_cmd =
let topic =
let doc = "Command to get help on" in
@ -190,7 +260,9 @@ let default_cmd =
Cmdliner.Term.info ~doc "builder-db"
let () =
Mirage_crypto_rng_unix.initialize ();
Cmdliner.Term.eval_choice
default_cmd
[help_cmd; add_cmd; migrate_cmd]
[help_cmd; add_cmd; migrate_cmd;
user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd]
|> Cmdliner.Term.exit

@ -8,4 +8,5 @@ let app =
|> Builder_web.add_routes t
let () =
Mirage_crypto_rng_unix.initialize ();
App.run_command app

@ -2,10 +2,10 @@
(public_name builder_web)
(name builder_web_app)
(modules builder_web_app)
(libraries builder_web))
(libraries builder_web mirage-crypto-rng.unix))
(executable
(public_name builder-db)
(name builder_db)
(modules builder_db)
(libraries builder_db caqti.blocking uri bos fmt logs logs.cli logs.fmt cmdliner))
(libraries builder_db caqti.blocking uri bos fmt logs logs.cli logs.fmt cmdliner mirage-crypto-rng.unix))

@ -327,14 +327,77 @@ module Build = struct
end
module User = struct
let migrate =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE user (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
username VARCHAR(255) NOT NULL UNIQUE,
password_hash BLOB NOT NULL,
password_salt BLOB NOT NULL,
password_iter INTEGER NOT NULL
)
|}
let rollback =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE IF EXISTS user"
let get_user =
Caqti_request.find_opt
Caqti_type.string
(Caqti_type.tup2 id user_info)
{| SELECT id, username, password_hash, password_salt, password_iter
FROM user
WHERE username = ?
|}
let get_all =
Caqti_request.collect
Caqti_type.unit
Caqti_type.string
"SELECT username FROM user"
let add =
Caqti_request.exec
user_info
{| INSERT INTO user (username, password_hash, password_salt, password_iter)
VALUES (?, ?, ?, ?)
|}
let remove =
Caqti_request.exec
id
"DELETE FROM user WHERE id = ?"
let remove_user =
Caqti_request.exec
Caqti_type.string
"DELETE FROM user WHERE username = ?"
let update_user =
Caqti_request.exec
user_info
{| UPDATE user
SET password_hash = ?2,
password_salt = ?3,
password_iter = ?4
WHERE username = ?1
|}
end
let migrate = [
Job.migrate;
Build.migrate;
Build_artifact.migrate;
Build_file.migrate;
User.migrate;
]
let rollback = [
User.rollback;
Build_file.migrate;
Build_artifact.rollback;
Build.rollback;

@ -108,6 +108,28 @@ sig
val add : (t, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
end
module User : 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_user :
(string, id * Builder_web_auth.user_info,
[< `Many | `One | `Zero > `One `Zero ])
Caqti_request.t
val get_all :
(unit, string, [ `Many | `One | `Zero ]) Caqti_request.t
val add :
(Builder_web_auth.user_info, unit, [< `Many | `One | `Zero > `Zero ])
Caqti_request.t
val remove : (id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val remove_user :
(string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val update_user :
(Builder_web_auth.user_info, unit, [< `Many | `One | `Zero > `Zero ])
Caqti_request.t
end
val migrate :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t list
val rollback :

@ -1,3 +1,3 @@
(library
(name builder_db)
(libraries builder caqti caqti-driver-sqlite3 asn1-combinators mirage-crypto))
(libraries builder caqti caqti-driver-sqlite3 asn1-combinators mirage-crypto builder_web_auth))

@ -72,3 +72,14 @@ let console =
let encode console = Ok (Asn.console_to_cs console) in
let decode data = Asn.console_of_cs data in
Caqti_type.custom ~encode ~decode cstruct
let user_info =
let rep = Caqti_type.(tup4 string cstruct cstruct int) in
let encode { Builder_web_auth.username; password_hash;
password_salt; password_iter } =
Ok (username, password_hash, password_salt, password_iter)
in
let decode (username, password_hash, password_salt, password_iter) =
Ok { Builder_web_auth.username; password_hash; password_salt; password_iter }
in
Caqti_type.custom ~encode ~decode rep

@ -15,6 +15,8 @@ type 'a t = {
pool : (Caqti_lwt.connection, [> db_error ] as 'a) Caqti_lwt.Pool.t
}
let realm = "builder-web"
let init ?(pool_size = 10) dbpath =
Caqti_lwt.connect_pool
~max_size:pool_size
@ -39,6 +41,29 @@ let mime_lookup path =
then "application/octet-stream"
else Magic_mime.lookup (Fpath.to_string path)
let authorized t handler = fun req ->
let unauthorized =
Response.of_plain_text "Forbidden!\n" ~status:`Unauthorized
|> Response.add_header ("WWW-Authenticate", Auth.string_of_challenge (Basic realm))
in
match Request.authorization req with
| None | Some (Other _) ->
Lwt.return unauthorized
| Some (Basic (username, password)) ->
let* user_info = Caqti_lwt.Pool.use (Model.user username) t.pool in
match user_info with
| Ok (Some user_info) ->
if Builder_web_auth.verify_password password user_info
then handler req
else Lwt.return unauthorized
| Ok None ->
ignore (Builder_web_auth.hash ~username ~password);
Lwt.return unauthorized
| Error e ->
Log.warn (fun m -> m "Error getting user: %a" pp_error e);
Response.of_plain_text "Internal server error\n" ~status:`Internal_server_error
|> Lwt.return
let routes t =
let builder _req =
let+ jobs = Caqti_lwt.Pool.use Model.jobs t.pool in
@ -144,12 +169,30 @@ let routes t =
|> Lwt.return
in
let upload req =
let* body = Request.to_plain_text req in
match Builder.Asn.exec_of_cs (Cstruct.of_string body) with
| Error (`Msg e) ->
Log.warn (fun m -> m "Received bad builder ASN.1");
Log.debug (fun m -> m "Parse error: %s" e);
Lwt.return (Response.of_plain_text "Bad request\n" ~status:`Bad_request)
| Ok exec ->
let* r = Caqti_lwt.Pool.use (Model.add_build exec) t.pool in
match r with
| Ok () ->
Lwt.return (Response.of_plain_text "Success!")
| Error e ->
Log.warn (fun m -> m "Error saving build: %a" pp_error e);
Lwt.return (Response.of_plain_text "Internal server error\n" ~status:`Internal_server_error)
in
[
App.get "/" builder;
App.get "/job/:job/" job;
App.get "/job/:job/build/:build/" job_build;
App.get "/job/:job/build/:build/f/**" job_build_file;
App.get "/refresh" refresh;
App.post "/upload" (authorized t upload);
]
let add_routes t (app : App.t) =

@ -50,3 +50,35 @@ let job job (module Db : CONN) =
let jobs (module Db : CONN) =
Db.collect_list Builder_db.Job.get_all () >|=
List.map snd
let user username (module Db : CONN) =
Db.find_opt Builder_db.User.get_user username >|=
Option.map snd
let dummy_save base (filepath, data) =
let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
let localpath = Fpath.append base filepath in
{ Builder_db.filepath; localpath; sha256 }
let add_build (job, uuid, console, start, finish, result, artifacts) (module Db : CONN) =
let open Builder_db in
let job_name = job.Builder.name in
let output_dir = Fmt.strf "/var/db/builder/%s/%a/output" job_name Uuidm.pp uuid in
let input_dir = Fmt.strf "/var/db/builder/%s/%a/input" job_name Uuidm.pp uuid in
Db.exec Job.try_add job_name >>= fun () ->
Db.find Job.get_id_by_name job_name >>= fun job_id ->
Db.exec Build.add { Build.uuid; start; finish; result;
console; script = job.Builder.script; job_id } >>= fun () ->
Db.find last_insert_rowid () >>= fun id ->
List.fold_left
(fun r file ->
r >>= fun () ->
Db.exec Build_artifact.add (file, id))
(Lwt_result.return ())
(List.map (dummy_save (Fpath.v output_dir)) artifacts) >>= fun () ->
List.fold_left
(fun r file ->
r >>= fun () ->
Db.exec Build_file.add (file, id))
(Lwt_result.return ())
(List.map (dummy_save (Fpath.v input_dir)) job.Builder.files)

@ -16,3 +16,13 @@ val job : string -> Caqti_lwt.connection ->
val jobs : Caqti_lwt.connection ->
(string list, [> error ]) result Lwt.t
val user : string -> Caqti_lwt.connection ->
(Builder_web_auth.user_info option, [> error ]) result Lwt.t
val add_build :
(Builder.job * Uuidm.t * (int * string) list * Ptime.t * Ptime.t *
Builder.execution_result * (Fpath.t * string) list) ->
Caqti_lwt.connection ->
(unit, [> error ]) result Lwt.t

Loading…
Cancel
Save