Provide overrides for front matter input specifications

src/bin/main.ml

@@ -123,21 +123,29 @@ let edit ~proc ~net ~fs () file port =
   Cohttp_eio.Server.run socket server ~on_error:log_warning
 
 let md ~fs ~net ~domain_mgr ~proc () no_run store conf file port fetcher jobs
-    src_dir env_override =
+    src_dir env_override input_override =
+  let import_map =
+    List.map
+      (fun (k, v) ->
+        match Fpath.of_string v with
+        | Ok p -> (k, p)
+        | Error (`Msg msg) -> Fmt.failwith "Not a valid path %s: %s" v msg)
+      input_override
+  in
+
   run_eventloop @@ fun () ->
   let ((_, store) as s) = store_or_default store in
   let (Builder ((module Builder), _builder) as obuilder) =
     create_builder ~fs ~net ~domain_mgr fetcher s conf
   in
   Fun.protect ~finally:(fun () -> ()) @@ fun () ->
-  let doc =
-    In_channel.with_open_bin file @@ fun ic ->
-    Cmarkit.Doc.of_string (In_channel.input_all ic)
-  in
-
   let file_path = Eio.Path.(fs / file) in
   let template_markdown = Eio.Path.load file_path in
-  let ast = Shark.Ast.of_sharkdown ~template_markdown in
+  let ast, markdown =
+    Shark.Ast.of_sharkdown ~concrete_paths:import_map template_markdown
+  in
+
+  let doc = Cmarkit.Doc.of_string markdown in
 
   let pool = Eio.Pool.create jobs (fun () -> ()) in
   let store = Lwt_eio.run_lwt @@ fun () -> store in
@@ -151,7 +159,12 @@ let md ~fs ~net ~domain_mgr ~proc () no_run store conf file port fetcher jobs
           (* First we translate the import statement to a build block *)
           let uid = string_of_int !import_uid in
           incr import_uid;
-          let cb, blk = Shark.Md.translate_import_block ~uid block in
+          let (cb, blk), src_dir_opt =
+            Shark.Md.translate_import_block ~uid block
+          in
+          let import_src_dir =
+            match src_dir_opt with Some x -> x | None -> src_dir
+          in
           (* Now we build the block *)
           (* Import block digests need to be mapped to this build hash *)
           let hb =
@@ -166,7 +179,8 @@ let md ~fs ~net ~domain_mgr ~proc () no_run store conf file port fetcher jobs
           let _alias, _id, cb =
             Shark.Build_cache.with_build build_cache @@ fun _build_cache ->
             let cb, blk =
-              Shark.Md.process_build_block ~src_dir ~hb obuilder ast (cb, blk)
+              Shark.Md.process_build_block ~src_dir:import_src_dir ~hb obuilder
+                ast (cb, blk)
             in
             ( Shark.Block.alias blk,
               option_get ~msg:"Block hash for import" (Shark.Block.hash blk),
@@ -337,6 +351,11 @@ let env_override =
           KEY=VALUE."
        ~docv:"ENVIRONMENT" [ "e" ]
 
+let input_override =
+  Arg.value
+  @@ Arg.(opt_all (pair ~sep:'=' string string)) []
+  @@ Arg.info ~doc:"Provide input file names KEY=VALUE." ~docv:"INPUT" [ "i" ]
+
 let build ~fs ~net ~domain_mgr ~clock =
   let doc = "Build a spec file." in
   let info = Cmd.info "build" ~doc in
@@ -361,7 +380,8 @@ let md ~fs ~net ~domain_mgr ~proc ~clock =
     Term.(
       const (md ~fs ~net ~domain_mgr ~proc ~clock)
       $ setup_log $ no_run $ store $ Obuilder.Native_sandbox.cmdliner
-      $ markdown_file $ port $ fetcher $ jobs $ src_dir $ env_override)
+      $ markdown_file $ port $ fetcher $ jobs $ src_dir $ env_override
+      $ input_override)
 
 let editor ~proc ~net ~fs ~clock =
   let doc = "Run the editor for a markdown file" in

src/lib/ast/ast.ml

@@ -216,12 +216,40 @@ let pass_one_on_list inputs section_list =
 
 let to_list ast = List.map snd ast.nodes
 
-let of_sharkdown ~template_markdown =
-  let metadata, sections =
+let synthesize_import_block input_map input_override_map =
+  let imports =
+    List.map
+      (fun (k, p) ->
+        let dest = List.assoc k input_map in
+        (p, dest))
+      input_override_map
+  in
+  let codeblock =
+    List.fold_left
+      (fun acc (src, dst) ->
+        acc
+        ^ Printf.sprintf "%s %s\n" (Fpath.to_string src) (Fpath.to_string dst))
+      "" imports
+  in
+  let block = Block.import codeblock in
+  ("imports", [ block_to_superblock block ])
+
+let synthesize_unmapped_import_block input_map =
+  let codeblock =
+    List.fold_left
+      (fun acc (src, dst) ->
+        acc ^ Printf.sprintf "%s %s\n" src (Fpath.to_string dst))
+      "" input_map
+  in
+  let block = Block.import codeblock in
+  ("imports", [ block_to_superblock block ])
+
+let of_sharkdown ?concrete_paths template_markdown =
+  let metadata, sections, markdown =
     match String.cuts ~sep:"---" template_markdown with
     | [ frontmatter; markdown ] | [ ""; frontmatter; markdown ] ->
-        (parse_frontmatter frontmatter, parse_markdown markdown)
-    | [ markdown ] -> (Frontmatter.empty, parse_markdown markdown)
+        (parse_frontmatter frontmatter, parse_markdown markdown, markdown)
+    | [ markdown ] -> (Frontmatter.empty, parse_markdown markdown, markdown)
     | _ -> failwith "Malformed frontmatter/markdown file"
   in
 
@@ -239,11 +267,40 @@ let of_sharkdown ~template_markdown =
       sections
   in
 
+  let input_map = Frontmatter.input_map metadata in
+  let synthesized_sections =
+    match input_map with
+    | [] -> []
+    | _ -> (
+        match concrete_paths with
+        | Some concrete_paths ->
+            [ synthesize_import_block input_map concrete_paths ]
+        | None -> [ synthesize_unmapped_import_block input_map ])
+  in
+
+  let expanded_markdown =
+    List.fold_left
+      (fun acc (name, bs) ->
+        let title = Printf.sprintf "# %s\n\n" name in
+        let body =
+          List.fold_left
+            (fun acc b ->
+              Printf.sprintf "```%s\n%s\n```\n\n"
+                (Block.to_info_string b.block)
+                (Block.body b.block)
+              ^ acc)
+            "\n" bs
+        in
+
+        (title ^ body) ^ acc)
+      markdown synthesized_sections
+  in
+
+  let expanded_sections = synthesized_sections @ detailed_sections in
+
   (* we can only infer the dependancy graph globally, so we need to do this at the top level before
      then working out the DAG. *)
-  let pass1 =
-    pass_one_on_list (Frontmatter.inputs metadata) detailed_sections
-  in
+  let pass1 = pass_one_on_list [] expanded_sections in
 
   (* Now I have the global graph implicitly, turn the list into a graph of blocks *)
   let all_hyperblocks = List.concat_map Section.blocks pass1 in
@@ -273,7 +330,7 @@ let of_sharkdown ~template_markdown =
          id_all_hyperblocks)
   in
 
-  { nodes = id_all_hyperblocks; edges }
+  ({ nodes = id_all_hyperblocks; edges }, expanded_markdown)
 
 let find_id_of_block ast ib =
   let d = Block.digest ib in

src/lib/ast/ast.mli

@@ -30,7 +30,14 @@ type t [@@deriving sexp]
 (** An AST instance *)
 
 val pp : t Fmt.t
-val of_sharkdown : template_markdown:string -> t
+
+val of_sharkdown :
+  ?concrete_paths:(string * Fpath.t) list -> string -> t * string
+(** [of_sharkdown] takes in the sharkdown document and generates and AST. If the frontmatter contains
+    declarations of external inputs they can be overridden by supplying [concerte_paths] that maps the input
+    name to a file path. In addition to the AST the sharkdown document is returned, with the body section
+    being updated for any autogenerated blocks. *)
+
 val find_id_of_block : t -> Block.t -> block_id option
 val block_by_id : t -> block_id -> Hyperblock.t option
 val find_hyperblock_from_block : t -> Block.t -> Hyperblock.t option

src/lib/block.ml

@@ -80,7 +80,7 @@ let to_info_string = function
       ^ match hash with Some hash -> ":" ^ hash | None -> "")
   | Publish _ -> "shark-publish"
   | Import { hash; alias; _ } -> (
-      Fmt.str "shark-run"
+      Fmt.str "shark-import"
       ^ (match alias with Some alias -> ":" ^ alias | None -> "")
       ^ match hash with Some hash -> ":" ^ hash | None -> "")
 
@@ -138,15 +138,67 @@ let imports = function
   | Import { body; _ } ->
       let cut_import s =
         match String.cut ~sep:" " s with
-        | Some (url, path) -> (url, path)
-        | None -> Fmt.failwith "Invalid import statement %s" s
+        | Some (url, path) -> (
+            match Fpath.of_string path with
+            | Ok path -> (Uri.of_string url, path)
+            | Error (`Msg msg) ->
+                Fmt.failwith "Error parsing path %s: %s" path msg)
+        | None -> Fmt.failwith "Invalid import statement '%s'" s
       in
-      let imports = String.cuts ~sep:"\n" body in
-      List.map cut_import imports
+      String.cuts ~sep:"\n" (String.trim body) |> List.map cut_import
 
 let digest : t -> string = function
   | Import { body; _ }
   | Publish { body; _ }
   | Run { body; _ }
   | Build { body; _ } ->
       Digest.string body
+
+let import_spec b =
+  let open Obuilder_spec in
+  (* TODO: Support multi-import statements *)
+  let url, target_path = imports b |> List.hd in
+  match Uri.scheme url with
+  | None | Some "file" ->
+      (* Choose better image, just need tools to import? *)
+      let fpath =
+        match Fpath.of_string (Uri.path url) with
+        | Ok p -> p
+        | Error (`Msg msg) ->
+            Fmt.failwith "Failed to parse path %s: %s" (Uri.path url) msg
+      in
+      let src_dir, path = Fpath.split_base fpath in
+      let src_dir = Fpath.rem_empty_seg src_dir in
+      ( stage ~from:(`Image "alpine")
+          [
+            (* shell [ "/bin/sh"; "-c" ]; *)
+            (* run "mkdir -p %s" (Fpath.to_string (Fpath.parent path)); *)
+            copy [ Fpath.to_string path ] ~dst:(Fpath.to_string target_path);
+          ],
+        Some (Fpath.to_string src_dir) )
+  | Some "http" | Some "https" -> (
+      let src_path = Uri.path url in
+      match String.cut ~rev:true ~sep:"." src_path with
+      | Some (_, "git") ->
+          (* Choose better image, just need tools to import? *)
+          ( stage ~from:(`Image "alpine")
+              [
+                shell [ "/bin/sh"; "-c" ];
+                run ~network:[ "host" ] "apk add --no-cache git";
+                run ~network:[ "host" ] "mkdir -p /data && git clone %s %s"
+                  (Uri.to_string url)
+                  (Fpath.to_string target_path);
+              ],
+            None )
+      | _ ->
+          (* Choose better image, just need tools to import? *)
+          ( stage ~from:(`Image "alpine")
+              [
+                shell [ "/bin/sh"; "-c" ];
+                run ~network:[ "host" ] "apk add --no-cache curl";
+                run ~network:[ "host" ] "mkdir -p /data && curl -O %s %s"
+                  (Fpath.to_string target_path)
+                  (Uri.to_string url);
+              ],
+            None ))
+  | Some scheme -> Fmt.failwith "Unsupported import scheme %s" scheme

src/lib/block.mli

@@ -68,7 +68,10 @@ val body : t -> string
 val output : t -> [ `Directory of string ]
 (** The output of a publish block *)
 
-val imports : t -> (string * string) list
+val imports : t -> (Uri.t * Fpath.t) list
 (** The imports from an import block i.e. a list of [URL, Path] pairs. *)
 
 val digest : t -> string
+
+val import_spec : t -> Obuilder_spec.t * string option
+(** For a shark-import block generate the spec to execute to enact the import. *)

src/lib/dotrenderer.ml

@@ -40,6 +40,27 @@ let render_publish_to_dot ppf command =
         (Datafile.id datafile) process_index label)
     (Leaf.inputs command)
 
+let render_import_to_dot ppf command =
+  let process_index = Leaf.id command in
+  List.iter
+    (fun datafile ->
+      let label =
+        match Datafile.subpath datafile with
+        | Some x -> Fmt.str ",label=\"%s\"" x
+        | None -> ""
+      in
+      Format.fprintf ppf "\tn%d->n%d[penwidth=\"2.0\"%s];\n"
+        (Datafile.id datafile) process_index label)
+    (Leaf.inputs command);
+  Format.fprintf ppf "\tn%d[shape=\"cylinder\",label=\"%s\"];\n" process_index
+    (Uri.pct_encode (Command.name (Leaf.command command)));
+  List.iter
+    (fun datafile ->
+      Format.fprintf ppf "\tn%d->n%d[penwidth=\"2.0\"];\n" process_index
+        (Datafile.id datafile))
+    (Leaf.outputs command);
+  Format.fprintf ppf "\n"
+
 let datafile_to_dot ppf datafile =
   Format.fprintf ppf "\tn%d[shape=\"cylinder\",label=\"%s\"];\n"
     (Datafile.id datafile)
@@ -83,6 +104,7 @@ let render_ast_to_dot ppf hyperblocks : unit =
 
       let renderer =
         match kind with
+        | `Import -> render_import_to_dot
         | `Run -> render_command_to_dot
         | `Publish -> render_publish_to_dot
         | _ -> fun _a _b -> ()
@@ -94,7 +116,7 @@ let render_ast_to_dot ppf hyperblocks : unit =
   Format.fprintf ppf "}\n"
 
 let render ~template_markdown =
-  Ast.of_sharkdown ~template_markdown
-  |> Ast.to_list
+  Ast.of_sharkdown template_markdown
+  |> fst |> Ast.to_list
   |> render_ast_to_dot Format.str_formatter;
   Format.flush_str_formatter ()

src/lib/dune

@@ -3,6 +3,6 @@
 (library
  (name shark)
  (public_name shark)
- (libraries eio str yaml lwt_eio cmarkit obuilder fpath)
+ (libraries eio str yaml lwt_eio cmarkit obuilder fpath uri)
  (preprocess
   (pps ppx_sexp_conv)))

src/lib/frontmatter.ml

@@ -65,3 +65,4 @@ let of_toplevel_yaml = function
 let of_string s = String.trim s |> Yaml.of_string |> Result.map of_toplevel_yaml
 let variables t = t.variables
 let inputs t = List.map (fun (_, v) -> v) t.inputs
+let input_map t = t.inputs

src/lib/frontmatter.mli

@@ -6,3 +6,4 @@ val empty : t
 val of_string : string -> (t, [ `Msg of string ]) result
 val variables : t -> (string * string list) list
 val inputs : t -> Fpath.t list
+val input_map : t -> (string * Fpath.t) list