Add utility to create formatted disk images

For now we assume the presence of the GPT header and provide no way to
format such a disk image. WIP.

mirage/config.ml

@@ -82,6 +82,8 @@ let mirror =
       package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ;
       package ~min:"2.2.0" "tar-mirage" ;
       package ~max:"0.2.0" "mirage-block-partition" ;
+      package "gpt" ;
+      package "gptar" ~pin:"git+https://github.com/reynir/gptar.git" ;
       package "oneffs" ;
     ]
     (block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job)

mirage/unikernel.ml

@@ -1031,17 +1031,83 @@ stamp: %S
 
   module Paf = Paf_mirage.Make(Stack.TCP)
 
+  let read_partition_table info block =
+    let b = Cstruct.create info.Mirage_block.sector_size in
+    (* We will ignore the protective MBR at lba [0L] *)
+    BLOCK.read block 1L [b] >>= fun r ->
+    match r with
+    | Error e ->
+      Format.kasprintf failwith "Reading partition table: %a"
+        BLOCK.pp_error e
+    | Ok () ->
+      match Gpt.unmarshal b ~sector_size:info.Mirage_block.sector_size with
+      | Error e ->
+        Format.kasprintf failwith "Reading partition table: %s" e
+      | Ok (`Read_partition_table (lba, sectors), k) ->
+        let b = Cstruct.create (sectors * info.Mirage_block.sector_size) in
+        BLOCK.read block lba [b] >>= fun r ->
+        match r with
+        | Error e ->
+          Format.kasprintf failwith "Reading partition table: %a"
+            BLOCK.pp_error e
+        | Ok () ->
+          match k b with
+          | Error e ->
+            Format.kasprintf failwith "Reading partition table: %s" e
+          | Ok gpt -> Lwt.return gpt
+
+  let get_partitions info block =
+    let utf16be_of_ascii s =
+      String.init 72
+        (fun i ->
+           if i mod 2 = 0 && i / 2 < String.length s then
+             s.[i/2]
+           else
+             '\000')
+    in
+    read_partition_table info block >>= fun gpt ->
+    let tar, git_dump, md5s, sha512s =
+      match
+        List.fold_left
+          (fun (tar, git_dump, md5s, sha512s) p ->
+             if String.equal p.Gpt.Partition.name
+                 (utf16be_of_ascii "tar")
+             then
+               (Some p, git_dump, md5s, sha512s)
+             else if String.equal p.name
+                 (utf16be_of_ascii "git_dump")
+             then
+               (tar, Some p, md5s, sha512s)
+             else if String.equal p.name
+                 (utf16be_of_ascii "md5s")
+             then
+               (tar, git_dump, Some p, sha512s)
+             else if String.equal p.name
+                 (utf16be_of_ascii "sha512s")
+             then
+               (tar, git_dump, md5s, Some p)
+             else
+               Format.kasprintf failwith "Unknown partition %S" p.name)
+          (None, None, None, None)
+          gpt.partitions
+      with
+      | (Some tar, Some git_dump, Some md5s, Some sha512s) ->
+        (tar, git_dump, md5s, sha512s)
+      | _ ->
+        failwith "not all partitions found :("
+    in
+    Part.connect 0L block >>= fun (_empty, p) ->
+    let get_part part =
+      let len = Int64.(succ (sub part.Gpt.Partition.ending_lba part.starting_lba)) in
+      let (_before, after) = Part.subpartition part.starting_lba p in
+      let (part, _after) = Part.subpartition len after in
+      part
+    in
+    Lwt.return (get_part tar, get_part git_dump, get_part md5s, get_part sha512s)
+
   let start block _time _pclock stack git_ctx http_ctx =
     BLOCK.get_info block >>= fun info ->
-    let sectors_cache = Key_gen.sectors_cache () in
+    get_partitions info block >>= fun (kv, git_dump, md5s, sha512s) ->
-    let sectors_git = Key_gen.sectors_git () in
-    let git_start =
-      let cache_size = Int64.(mul 2L sectors_cache) in
-      Int64.(sub info.size_sectors (add cache_size sectors_git))
-    in
-    Part.connect git_start block >>= fun (kv, rest) ->
-    let git_dump, rest = Part.subpartition sectors_git rest in
-    let md5s, sha512s = Part.subpartition sectors_cache rest in
     KV.connect kv >>= fun kv ->
     Cache.connect md5s >>= fun md5s ->
     Cache.connect sha512s >>= fun sha512s ->

mkimg/bin/dune

@@ -0,0 +1,3 @@
+(executable
+ (name mkimg)
+ (libraries unix cstruct gptar gpt uuidm cmdliner))

mkimg/bin/mkimg.ml

@@ -0,0 +1,148 @@
+(* I just made these ones up... *)
+let tar_guid = Uuidm.of_string "53cd6812-46cc-474e-a141-30b3aed85f53" |> Option.get
+let cache_guid = Uuidm.of_string "22ab9cf5-6e51-45c2-998a-862e23aab264" |> Option.get
+let git_guid = Uuidm.of_string "30faa50a-4c9d-47ff-a1a5-ecfb3401c027" |> Option.get
+
+(* GPT uses a 72 byte utf16be encoded string for partition names *)
+let gptutf16be_of_ascii s =
+  String.init 72
+    (fun i ->
+       if i mod 2 = 0 && i / 2 < String.length s then
+         s.[i/2]
+       else
+         '\000')
+
+let jump dest sector_size size_sectors sectors_cache sectors_git =
+  let ( let* ) = Result.bind in
+  let* () =
+    if sector_size < 0 then Error "negative sector size"
+    else if size_sectors < 0L then Error "negative size"
+    else if sectors_cache < 0L then Error "negative cache size"
+    else if sectors_git < 0L then Error "negative git dump size"
+    else Ok ()
+  in
+  let* () =
+    if sector_size >= 512 && sector_size land (pred sector_size) == 0 then
+      Ok ()
+    else Error "sector size must be a power of two greater than or equal 512"
+  in
+  (* ocaml-gpt uses a fixed size partition entries table. Create an empty GPT
+     to figure out the first usable LBA *)
+  let empty =
+    Gpt.make ~sector_size ~disk_sectors:size_sectors []
+    |> Result.get_ok
+  in
+  let* () =
+    let ( + ) = Int64.add in
+    if size_sectors <
+       (* protective MBR + GPT header + GPT table *)
+       empty.first_usable_lba +
+       min 1L (Int64.of_int (2 * Tar.Header.length / sector_size)) + sectors_cache + sectors_cache + sectors_git
+       + 1L (* backup GPT header *) then
+      Error "too small size"
+    else Ok ()
+  in
+  (* TODO: handle exceptions *)
+  let fd = Unix.openfile dest Unix.[ O_WRONLY; O_CREAT ] 0o664 in
+  Unix.ftruncate fd (sector_size * Int64.to_int size_sectors);
+  let gpt =
+    let partitions =
+      (* Current implementation of [Gpt.Partition.make] only returns [Ok _] or
+         raises [Invalid_argument _] :/ *)
+      let attributes = 1L in
+      let sha512s =
+        Gpt.Partition.make
+          ~name:(gptutf16be_of_ascii "sha512s")
+          ~type_guid:cache_guid
+          ~attributes
+          Int64.(succ (sub empty.last_usable_lba sectors_cache))
+          empty.last_usable_lba
+        |> Result.get_ok
+      in
+      let md5s =
+        Gpt.Partition.make
+          ~name:(gptutf16be_of_ascii "md5s")
+          ~type_guid:cache_guid
+          ~attributes
+          (Int64.sub sha512s.starting_lba sectors_cache)
+          (Int64.pred sha512s.starting_lba)
+        |> Result.get_ok
+      in
+      let git_dump =
+        Gpt.Partition.make
+          ~name:(gptutf16be_of_ascii "git_dump")
+          ~type_guid:git_guid
+          ~attributes
+          (Int64.sub md5s.starting_lba sectors_git)
+          (Int64.pred md5s.starting_lba)
+        |> Result.get_ok
+      in
+      let tar =
+        Gpt.Partition.make
+          ~name:(gptutf16be_of_ascii "tar")
+          ~type_guid:tar_guid
+          ~attributes
+          empty.first_usable_lba
+          (Int64.pred git_dump.starting_lba)
+        |> Result.get_ok
+      in
+      [ tar; git_dump; md5s; sha512s ]
+    in
+    Gpt.make ~sector_size ~disk_sectors:size_sectors partitions
+    |> Result.get_ok
+  in
+  let buf =
+    Cstruct.create (sector_size * (Int64.to_int gpt.first_usable_lba + 2 * Tar.Header.length))
+  in
+  Gptar.marshal_header ~sector_size buf gpt;
+  Gpt.marshal_partition_table ~sector_size
+    (Cstruct.shift buf (sector_size * Int64.to_int gpt.partition_entry_lba))
+    gpt;
+  let s = Cstruct.to_string buf in
+  ignore (Unix.write_substring fd s 0 (String.length s));
+  ignore (Unix.lseek fd (Int64.to_int gpt.backup_lba * sector_size) Unix.SEEK_SET);
+  (* Let's reuse the buffer *)
+  let buf = Cstruct.sub buf 0 sector_size in
+  Cstruct.memset buf 0;
+  Gpt.marshal_header ~sector_size ~primary:false buf gpt;
+  let s = Cstruct.to_string buf in
+  ignore (Unix.write_substring fd s 0 (String.length s));
+  Unix.close fd;
+  Ok ()
+
+open Cmdliner
+
+let dest =
+  Arg.(required & pos 0 (some string) None &
+       info ~docv:"DEST" [])
+
+let sector_size =
+  let doc = "Sector size or block size to use" in
+  (* TODO: should be a power of two >= 512 *)
+  Arg.(value & opt int 512 &
+       info ~doc ~docv:"SECTOR-SIZE" ["sector-size"])
+
+let size_sectors =
+  let doc = "Size of disk image in terms of sectors" in
+  Arg.(value & opt int64 (Int64.mul 1024L 2048L) &
+       info ~doc ~docv:"SIZE-SECTORS" ["size-sectors"])
+
+let sectors_cache =
+  let doc = "Number of sectors reserved for each checksum cache (md5, sha512)." in
+  Arg.(value & opt int64 (Int64.mul 4L 2048L) &
+       info ~doc ~docv:"SECTORS-CACHE" ["sectors-cache"])
+
+let sectors_git =
+  let doc = "Number of sectors reserved for git dump." in
+  Arg.(value & opt int64 (Int64.mul 40L 2048L) &
+       info ~doc ~docv:"SECTORS-GIT" ["sectors-git"])
+
+let command =
+  let info =
+    Cmd.info "mkimg"
+  in
+  Cmd.v info
+    Term.(const jump $ dest $ sector_size $ size_sectors $ sectors_cache $ sectors_git)
+
+let () =
+  exit (Cmdliner.Cmd.eval_result command)

mkimg/dune-project

@@ -0,0 +1,2 @@
+(lang dune 3.14)
+(name mkimg)