Merge pull request #47 from quantifyearth/pf341-save-failed-builds

Handle failing commands more gracefully

specs/shark.failure.md

@@ -0,0 +1,40 @@
+
+# Markdown Shark Support
+
+The `shark` executable also can work with markdown documents. Two blocks can be
+used to run shell-like commands within your markdown documents. The first is
+`shark-build` commands. These allow you to specify a build script that is then
+built and can be referenced as the context for future `shark-run` blocks.
+
+## Shark Build
+
+```shark-build:gdal-env
+((from osgeo/gdal:ubuntu-small-3.6.3)
+ (run (shell "mkdir -p /data && echo 'Something for the log!'")))
+```
+
+Once we have a GDAL environment available to us, we can write shell fragments
+using that environment.
+
+## Shark Run
+
+```shark-run:gdal-env
+$ gdal --version > /data/gdal.version
+```
+
+Shark keeps track of inputs and outputs. In the next code block, Shark knows to wire
+up `/data/gdal.version` into the container.
+
+```shark-run:gdal-env
+$ cat /data/gdal.version
+```
+
+## Shark Publish
+
+Shark allows you to export data directly from the Shark world using a publish block. By default
+this will publish to a `_shark` directory in the current working directory. Use the same file path
+conventions to export data blobs.
+
+```shark-publish
+/data/gdal.version
+```

src/bin/main.ml

@@ -80,6 +80,7 @@ let build ~fs ~net ~domain_mgr () store spec conf src_dir secrets fetcher =
       Ok ()
   | Error `Cancelled -> Error "Cancelled at user's request"
   | Error (`Msg m) -> Error (Fmt.str "Build step failed: %s" m)
+  | Error (`Failed (id, m)) -> Error (Fmt.str "Build %s failed: %s" id m)
 
 let run ~fs ~net ~domain_mgr () store conf id fetcher =
   run_eventloop @@ fun () ->
@@ -139,14 +140,14 @@ let md ~fs ~net ~domain_mgr ~proc () no_run store conf file port fetcher jobs
   let pool = Eio.Pool.create jobs (fun () -> ()) in
   let store = Lwt_eio.run_lwt @@ fun () -> store in
   let f ~build_cache code_block block =
-    if no_run then code_block
+    if no_run then (code_block, `Continue)
     else
       match Shark.Block.kind block with
       | `Publish ->
           let cb, _blk =
             Shark.Md.process_publish_block store ast (code_block, block)
           in
-          cb
+          (cb, `Continue)
       | `Build ->
           let _alias, _id, cb =
             Shark.Build_cache.with_build build_cache @@ fun _build_cache ->
@@ -156,21 +157,31 @@ let md ~fs ~net ~domain_mgr ~proc () no_run store conf file port fetcher jobs
             in
             (Shark.Block.alias blk, Option.get (Shark.Block.hash blk), cb)
           in
-          cb
+          (cb, `Continue)
       | `Run ->
-          let cb, _result_block =
+          let cb, _result_block, stop =
             Shark.Md.process_run_block ~env_override ~fs ~build_cache ~pool
               store ast obuilder (code_block, block)
           in
-          cb
+          (cb, stop)
   in
 
-  let document = Shark.Md.map_blocks doc ~f in
-
+  let document, stopped = Shark.Md.map_blocks doc ~f in
+  let doc_string = Cmarkit_commonmark.of_doc document in
   Eio.Switch.run @@ fun sw ->
-  let run_server () =
+  let run () =
     match port with
-    | None -> Fmt.pr "%s" (Cmarkit_commonmark.of_doc document)
+    | None -> (
+        match stopped with
+        | Some reason ->
+            Fmt.epr "%a\n%s"
+              Fmt.(styled (`Fg `Red) string)
+              ("BUILD FAILED: " ^ reason)
+              doc_string;
+            Error "Build failed"
+        | None ->
+            Fmt.pr "%s" doc_string;
+            Ok ())
     | Some port ->
         let output_path = Eio.Path.(fs / Filename.temp_file "shark-md" "run") in
         Eio.Path.save ~create:(`If_missing 0o644) output_path
@@ -182,8 +193,7 @@ let md ~fs ~net ~domain_mgr ~proc () no_run store conf file port fetcher jobs
         and server = Cohttp_eio.Server.make ~callback:handler () in
         Cohttp_eio.Server.run socket server ~on_error:log_warning
   in
-  run_server ();
-  Ok ()
+  run ()
 
 let template ~clock ~fs () file directory =
   run_eventloop ~clock @@ fun () ->

src/lib/md.ml

@@ -4,27 +4,35 @@ open Eio
 let ( / ) = Eio.Path.( / )
 
 module CommandResult = struct
-  type t = { build_hash : string; output : string; command : string }
+  type t = { build_hash : string; output : string option; command : string }
 
-  let v ~build_hash ~output ~command = { build_hash; output; command }
+  let v ?output ~build_hash command = { build_hash; output; command }
   let _build_hash r = r.build_hash
   let output r = r.output
   let command r = r.command
 end
 
 let map_blocks (doc : Cmarkit.Doc.t) ~f =
   let build_cache = Build_cache.v () in
-  let block _mapper = function
-    | Cmarkit.Block.Code_block (node, meta) -> (
-        match Block.of_code_block node with
-        | Some block ->
-            let new_block = f ~build_cache node block in
-            `Map (Some (Cmarkit.Block.Code_block (new_block, meta)))
-        | None -> `Default)
-    | _ -> `Default
+  let stop_processing = ref None in
+  let block _mapper v =
+    if Option.is_some !stop_processing then `Default
+    else
+      match v with
+      | Cmarkit.Block.Code_block (node, meta) -> (
+          match Block.of_code_block node with
+          | Some block ->
+              let new_block, continue = f ~build_cache node block in
+              (match continue with
+              | `Continue -> ()
+              | `Stop reason -> stop_processing := Some reason);
+              `Map (Some (Cmarkit.Block.Code_block (new_block, meta)))
+          | None -> `Default)
+      | _ -> `Default
   in
   let mapper = Cmarkit.Mapper.make ~block () in
-  Cmarkit.Mapper.map_doc mapper doc
+  let doc = Cmarkit.Mapper.map_doc mapper doc in
+  (doc, !stop_processing)
 
 type builder =
   | Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder
@@ -54,7 +62,7 @@ let process_build_block ?(src_dir = ".") (Builder ((module Builder), builder))
       match Lwt_eio.run_lwt @@ fun () -> Builder.build builder context spec with
       | Error `Cancelled -> failwith "Cancelled by user"
       | Error (`Msg m) -> failwith m
-      | Ok id ->
+      | Ok id | Error (`Failed (id, _)) ->
           let block_with_hash = Block.with_hash block id in
           (* Update hyperblock hash *)
           let hb = Ast.find_hyperblock_from_block ast block |> Option.get in
@@ -132,6 +140,14 @@ let get_paths ~fs (Obuilder.Store_spec.Store ((module Store), store)) hash
       in
       List.map find_files_in_store outputs
 
+type processed_output = {
+  cmd_result : CommandResult.t;
+  success : bool;
+  build_hash : Obuilder.S.id;
+  workdir : string;
+  env : (string * string) list;
+}
+
 let process_run_block ?(env_override = []) ~fs ~build_cache ~pool store ast
     (Builder ((module Builder), builder)) (_code_block, block) =
   let hyperblock = Ast.find_hyperblock_from_block ast block |> Option.get in
@@ -168,68 +184,88 @@ let process_run_block ?(env_override = []) ~fs ~build_cache ~pool store ast
           (Leaf.outputs l)
       in
 
-      let spec build_hash pwd environment leaf cmdstr =
-        let open Obuilder_spec in
-        stage ~from:(`Build build_hash)
-          ([ user_unix ~uid:0 ~gid:0; workdir pwd ]
-          @ List.map (fun (k, v) -> env k v) environment
+      let spec ~build_hash ~workdir environment leaf cmdstr =
+        Obuilder_spec.stage ~from:(`Build build_hash)
+          ([
+             Obuilder_spec.user_unix ~uid:0 ~gid:0;
+             Obuilder_spec.workdir workdir;
+           ]
+          @ List.map (fun (k, v) -> Obuilder_spec.env k v) environment
           @ target_dirs leaf
           (* @ links *)
-          @ [ run ~network:[ "host" ] ~rom "%s" cmdstr ])
+          @ [ Obuilder_spec.run ~network:[ "host" ] ~rom "%s" cmdstr ])
       in
-      let process pool (_outputs, build_hash, pwd, env) leaf cmdstr :
-          CommandResult.t * string * string * (string * string) list =
+      let process pool (_outputs, build_hash, workdir, env) leaf cmdstr =
         Eio.Pool.use pool @@ fun () ->
-        Logs.info (fun f ->
-            f "Running spec %a" Obuilder_spec.pp
-              (spec build_hash pwd env leaf cmdstr));
         let command = Leaf.command leaf in
+        Logs.debug (fun f -> f "Processing command: %a" Command.pp command);
         match Command.name command with
         | "cd" ->
-            ( CommandResult.v ~build_hash ~output:"" ~command:cmdstr,
-              build_hash,
-              Fpath.to_string (List.nth (Command.file_args command) 0),
-              env )
+            (* If a command block is a call to `cd` we treat this similarly to Docker's
+               WORKDIR command which changes the working directory of the context *)
+            let cmd_result = CommandResult.v ~build_hash cmdstr in
+            {
+              cmd_result;
+              build_hash;
+              success = true;
+              workdir = Fpath.to_string (List.nth (Command.file_args command) 0);
+              env;
+            }
         | "export" ->
-            let parts =
+            (* `export` is treated like ENV in Docker, only supporting a single key=value for now. *)
+            let key, default_value =
               String.concat (List.tl (Command.raw_args command))
-              |> String.cuts ~sep:"="
+              |> String.cut ~sep:"="
+              |> function
+              | Some (k, v) -> (k, v)
+              | None ->
+                  Fmt.failwith "Malformed export command: %a" Command.pp command
             in
-            let key = List.nth parts 0 and default_value = List.nth parts 1 in
             let value =
               match List.assoc_opt key env_override with
               | None -> default_value
               | Some v -> v
             in
-            ( CommandResult.v ~build_hash ~output:""
-                ~command:(Fmt.str "export %s=%s" key value),
-              build_hash,
-              pwd,
-              (key, value) :: List.remove_assoc key env )
+            let cmd_result =
+              CommandResult.v ~build_hash (Fmt.str "export %s=%s" key value)
+            in
+            {
+              cmd_result;
+              build_hash;
+              success = true;
+              workdir;
+              env = (key, value) :: List.remove_assoc key env;
+            }
         | _ -> (
+            (* Otherwise we run a command using obuilder *)
             let buf = Buffer.create 128 in
             let log = log `Run buf in
             let context = Obuilder.Context.v ~log ~src_dir:"." () in
+            let spec = spec ~build_hash ~workdir env leaf cmdstr in
+            Logs.info (fun f -> f "Running spec: %a" Obuilder_spec.pp spec);
             match
-              Lwt_eio.run_lwt @@ fun () ->
-              Builder.build builder context
-                (spec build_hash pwd env leaf cmdstr)
+              Lwt_eio.run_lwt @@ fun () -> Builder.build builder context spec
             with
             | Ok id ->
-                ( CommandResult.v ~build_hash:id ~output:(Buffer.contents buf)
-                    ~command:cmdstr,
-                  id,
-                  pwd,
-                  env )
+                {
+                  cmd_result =
+                    CommandResult.v ~build_hash:id ~output:(Buffer.contents buf)
+                      cmdstr;
+                  build_hash = id;
+                  success = true;
+                  workdir;
+                  env;
+                }
             | Error `Cancelled -> failwith "Cancelled by user"
-            | Error (`Msg _m) ->
-                ( CommandResult.v ~build_hash ~output:(Buffer.contents buf)
-                    ~command:cmdstr,
-                  build_hash,
-                  pwd,
-                  env ))
+            | Error (`Msg m) -> failwith m
+            | Error (`Failed (id, msg)) ->
+                let cmd_result =
+                  CommandResult.v ~build_hash:id
+                    ~output:(msg ^ "\n" ^ Buffer.contents buf)
+                    cmdstr
+                in
+                { cmd_result; success = false; build_hash; workdir; env })
       in
-
       let outer_process acc leaf =
         let inputs = Leaf.inputs leaf in
         let input_and_hashes =
@@ -269,22 +305,26 @@ let process_run_block ?(env_override = []) ~fs ~build_cache ~pool store ast
             [] paths
         in
         let inputs = Leaf.to_string_for_inputs leaf l in
-        let l = Fiber.List.map (process pool acc leaf) inputs in
+        let processed_blocks = Fiber.List.map (process pool acc leaf) inputs in
         let results, _hash, _pwd, _env = acc in
-        let _, hash, pwd, env = List.hd l in
-        (l :: results, hash, pwd, env)
+        let { build_hash; workdir; env; _ } = List.hd processed_blocks in
+        (processed_blocks :: results, build_hash, workdir, env)
       in
 
       let ids_and_output_and_cmd, _hash, _pwd, _env =
         List.fold_left outer_process ([], build, "/root", []) commands
       in
       let last = List.hd ids_and_output_and_cmd in
-      let _, id, _, _ = List.hd last in
+      let { build_hash = id; _ } = List.hd last in
 
       let body =
         List.fold_left
-          (fun s (r, _, _, _) ->
-            s @ [ CommandResult.command r; CommandResult.output r ])
+          (fun s { cmd_result = r; _ } ->
+            s
+            @ [
+                CommandResult.command r;
+                (match CommandResult.output r with Some o -> o | None -> "");
+              ])
           []
           (List.concat (List.rev ids_and_output_and_cmd))
         |> List.filter (fun v -> not (String.equal "" v))
@@ -293,11 +333,24 @@ let process_run_block ?(env_override = []) ~fs ~build_cache ~pool store ast
       in
 
       List.iter
-        (fun (_, id, _, _) -> Ast.Hyperblock.update_hash hyperblock id)
+        (fun { build_hash = id; _ } -> Ast.Hyperblock.update_hash hyperblock id)
         last;
       let block = Block.with_hash block id in
       let info_string = (Block.to_info_string block, Cmarkit.Meta.none) in
-      (Cmarkit.Block.Code_block.make ~info_string body, block)
+      (* TODO: We should be able to continue procressing other blocks if only one fails
+         here, but I would like to restructure the code to support this better and have
+         ideas for that. For now, a single failure here will stop the procressing. *)
+      let stop = List.find_opt (fun { success; _ } -> not success) last in
+      let action =
+        match stop with
+        | None -> `Continue
+        | Some r -> (
+            match r.cmd_result.output with
+            | Some o -> `Stop o
+            | None -> `Stop "No output")
+      in
+
+      (Cmarkit.Block.Code_block.make ~info_string body, block, action)
   | _ -> failwith "expected run"
 
 let copy ?chown ~src ~dst () =