User authentication and upload endpoint

auth/builder_web_auth.ml

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

auth/dune

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

bin/builder_db.ml

@@ -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
+  or_die 1 (do_migrate dbpath)
-  | Ok () -> ()
+
-  | Error e ->
+let user_mod action dbpath username =
-    Format.eprintf "Database error: %a" Caqti_error.pp e;
+  let r =
-    exit 1
+    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

bin/builder_web_app.ml

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

bin/dune

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

db/builder_db.ml

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

db/builder_db.mli

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

db/dune

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

db/representation.ml

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

lib/builder_web.ml

@@ -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) =

lib/model.ml

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

lib/model.mli

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