Store files on disk

This commit is contained in:
Reynir Björnsson 2021-01-21 17:51:58 +01:00
parent 841dabcc03
commit 0f98541feb
4 changed files with 62 additions and 20 deletions

View file

@ -1,12 +1,13 @@
open Opium
let t = Result.get_ok (Builder_web.init "builder.sqlite3")
let app =
let app t =
App.empty
|> App.cmd_name "Builder Web"
|> Builder_web.add_routes t
let () =
Mirage_crypto_rng_unix.initialize ();
App.run_command app
let () = Mirage_crypto_rng_unix.initialize () in
let datadir = Fpath.v "/var/db/builder-web/" in
let t = Result.get_ok (Builder_web.init "builder.sqlite3" datadir) in
App.run_command (app t)

View file

@ -12,17 +12,20 @@ let pp_error ppf = function
| #Model.error as e -> Model.pp_error ppf e
type 'a t = {
pool : (Caqti_lwt.connection, [> db_error ] as 'a) Caqti_lwt.Pool.t
pool : (Caqti_lwt.connection, [> db_error ] as 'a) Caqti_lwt.Pool.t;
datadir : Fpath.t;
}
let realm = "builder-web"
let init ?(pool_size = 10) dbpath =
let init ?(pool_size = 10) dbpath datadir =
Caqti_lwt.connect_pool
~max_size:pool_size
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
|> Result.map (fun pool ->
{ pool = (pool :> (Caqti_lwt.connection, [> db_error ]) Caqti_lwt.Pool.t); })
|> Result.map (fun pool -> {
pool = (pool :> (Caqti_lwt.connection, [> db_error ]) Caqti_lwt.Pool.t);
datadir;
})
let pp_exec ppf (job, uuid, _, _, _, _, _) =
Format.fprintf ppf "%s(%a)" job.Builder.name Uuidm.pp uuid
@ -181,7 +184,7 @@ let routes t =
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
let* r = Caqti_lwt.Pool.use (Model.add_build t.datadir exec) t.pool in
match r with
| Ok () ->
Lwt.return (Response.of_plain_text "Success!")

View file

@ -5,11 +5,12 @@ module Log = (val Logs.src_log src : Logs.LOG)
module type CONN = Caqti_lwt.CONNECTION
type error = [ Caqti_error.call_or_retrieve | `Not_found | `File_error of Fpath.t ]
type error = [ Caqti_error.call_or_retrieve | `Not_found | `File_error of Fpath.t | `Msg of string ]
let pp_error ppf = function
| `Not_found -> Format.fprintf ppf "value not found in database"
| `File_error path -> Format.fprintf ppf "error reading file %a" Fpath.pp path
| `Msg e -> Format.fprintf ppf "error %s" e
| #Caqti_error.call_or_retrieve as e ->
Caqti_error.pp ppf e
@ -55,16 +56,52 @@ 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 save file data =
let open Lwt.Infix in
Lwt_io.open_file ~mode:Lwt_io.Output (Fpath.to_string file) >>= fun oc ->
Lwt_io.write oc data >>= fun () ->
Lwt_io.close oc
let add_build (job, uuid, console, start, finish, result, artifacts) (module Db : CONN) =
let save_exec build_dir exec =
let cs = Builder.Asn.exec_to_cs exec in
save Fpath.(build_dir / "full") (Cstruct.to_string cs)
let save_file dir (filepath, data) =
let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
let localpath = Fpath.append dir filepath in
Lwt.bind
(save localpath data)
(fun () -> Lwt.return { Builder_db.filepath; localpath; sha256 })
let save_all basedir ((job, uuid, _, _, _, _, artifacts) as exec) =
let build_dir = Fpath.(basedir / job.Builder.name / Uuidm.to_string uuid) in
let input_dir = Fpath.(build_dir / "input") in
let output_dir = Fpath.(build_dir / "output") in
Lwt.return (Bos.OS.Dir.create build_dir) >>= (fun created ->
if not created
then Lwt_result.fail (`Msg "build directory already exists")
else Lwt_result.return ()) >>= fun () ->
Lwt.return (Bos.OS.Dir.create input_dir) >>= fun _ ->
Lwt.return (Bos.OS.Dir.create output_dir) >>= fun _ ->
Lwt.catch
(fun () ->
let open Lwt.Infix in
save_exec build_dir exec >>= fun () ->
Lwt_list.map_s (save_file input_dir) job.Builder.files >>= fun input_files ->
Lwt_list.map_s (save_file output_dir) artifacts >>= fun artifacts ->
Lwt_result.return (artifacts, input_files))
(function
| Unix.Unix_error (e, _, _) ->
Lwt_result.fail (`Msg (Unix.error_message e))
| e -> Lwt.fail e)
let add_build
basedir
((job, uuid, console, start, finish, result, _) as exec)
(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
save_all basedir exec >>= fun (artifacts, input_files) ->
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;
@ -75,10 +112,10 @@ let add_build (job, uuid, console, start, finish, result, artifacts) (module Db
r >>= fun () ->
Db.exec Build_artifact.add (file, id))
(Lwt_result.return ())
(List.map (dummy_save (Fpath.v output_dir)) artifacts) >>= fun () ->
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)
input_files

View file

@ -1,4 +1,4 @@
type error = [ Caqti_error.call_or_retrieve | `Not_found | `File_error of Fpath.t ]
type error = [ Caqti_error.call_or_retrieve | `Not_found | `File_error of Fpath.t | `Msg of string ]
val pp_error : Format.formatter -> error -> unit
@ -22,6 +22,7 @@ val user : string -> Caqti_lwt.connection ->
val add_build :
Fpath.t ->
(Builder.job * Uuidm.t * (int * string) list * Ptime.t * Ptime.t *
Builder.execution_result * (Fpath.t * string) list) ->
Caqti_lwt.connection ->