Store files on disk

bin/builder_web_app.ml

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

lib/builder_web.ml

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

lib/model.ml

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

lib/model.mli

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