diff --git a/auth/builder_web_auth.ml b/auth/builder_web_auth.ml new file mode 100644 index 0000000..b039803 --- /dev/null +++ b/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 diff --git a/auth/dune b/auth/dune new file mode 100644 index 0000000..82b0e15 --- /dev/null +++ b/auth/dune @@ -0,0 +1,3 @@ +(library + (name builder_web_auth) + (libraries pbkdf mirage-crypto-rng sexplib)) diff --git a/bin/builder_db.ml b/bin/builder_db.ml index 9c0f11e..2ec0af4 100644 --- a/bin/builder_db.ml +++ b/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 - | 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 diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index bb83605..7a90dea 100644 --- a/bin/builder_web_app.ml +++ b/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 diff --git a/bin/dune b/bin/dune index d4972c4..354383d 100644 --- a/bin/dune +++ b/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)) diff --git a/db/builder_db.ml b/db/builder_db.ml index c2c4e3f..4c50ccb 100644 --- a/db/builder_db.ml +++ b/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; diff --git a/db/builder_db.mli b/db/builder_db.mli index 29b4e28..617dbed 100644 --- a/db/builder_db.mli +++ b/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 : diff --git a/db/dune b/db/dune index 9053a9a..e650505 100644 --- a/db/dune +++ b/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)) diff --git a/db/representation.ml b/db/representation.ml index 57d47fd..d1809ff 100644 --- a/db/representation.ml +++ b/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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 5c2f54c..618a15d 100644 --- a/lib/builder_web.ml +++ b/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) = diff --git a/lib/model.ml b/lib/model.ml index 27af823..8d92ca1 100644 --- a/lib/model.ml +++ b/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) diff --git a/lib/model.mli b/lib/model.mli index 37f3743..f73f4f0 100644 --- a/lib/model.mli +++ b/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