mirage/config.ml

@@ -14,6 +14,8 @@ let mirror =
       package ~min:"3.0.0" ~sublibs:[ "gz" ] "tar" ;
       package ~min:"3.0.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" ;
       package "digestif" ;
     ]

mirage/partitions.ml

@@ -0,0 +1,91 @@
+open Lwt.Syntax
+
+module Make(BLOCK : Mirage_block.S) = struct
+  module Part = Mirage_block_partition.Make(BLOCK)
+
+  include Part
+
+  type partitions = {
+    tar : Part.t ;
+    git_dump : Part.t ;
+    md5s : Part.t ;
+    sha512s : Part.t ;
+  }
+
+  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] *)
+    let* r = BLOCK.read block 1L [b] in
+    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
+        let* r = BLOCK.read block lba [b] in
+        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 connect 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
+    let* info = BLOCK.get_info block in
+    let* gpt = read_partition_table info block in
+    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
+    let+ (_empty, p) = Part.connect 0L block in
+    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
+    let tar = get_part tar and git_dump = get_part git_dump
+    and md5s = get_part md5s and sha512s = get_part sha512s in
+    { tar ; git_dump ; md5s ; sha512s }
+end

mirage/unikernel.ml

@@ -67,7 +67,7 @@ module Make
   (_ : sig end)
   (HTTP : Http_mirage_client.S) = struct
 
-  module Part = Mirage_block_partition.Make(BLOCK)
+  module Part = Partitions.Make(BLOCK)
   module KV = Tar_mirage.Make_KV_RW(Pclock)(Part)
   module Cache = OneFFS.Make(Part)
   module Store = Git_kv.Make(Pclock)
@@ -985,18 +985,11 @@ stamp: %S
   module Paf = Paf_mirage.Make(Stack.TCP)
 
   let start block _time _pclock stack git_ctx http_ctx =
-    BLOCK.get_info block >>= fun info ->
-    let git_start =
-      let cache_size = Int64.(mul 2L (K.sectors_cache ())) in
-      Int64.(sub info.size_sectors (add cache_size (K.sectors_git ())))
-    in
-    Part.connect git_start block >>= fun (kv, rest) ->
-    let git_dump, rest = Part.subpartition (K.sectors_git ()) rest in
-    let md5s, sha512s = Part.subpartition (K.sectors_cache ()) rest in
-    KV.connect kv >>= fun kv ->
+    Part.connect block >>= fun { Part.tar ; git_dump; md5s ; sha512s } ->
+    KV.connect tar >>= fun kv ->
+    Cache.connect git_dump >>= fun git_dump ->
     Cache.connect md5s >>= fun md5s ->
     Cache.connect sha512s >>= fun sha512s ->
-    Cache.connect git_dump >>= fun git_dump ->
     Logs.info (fun m -> m "Available bytes in tar storage: %Ld" (KV.free kv));
     Disk.init ~verify_sha256:(K.verify_sha256 ()) kv md5s sha512s >>= fun disk ->
     let remote = K.remote () in