diff --git a/mirage/config.ml b/mirage/config.ml index 0d864f9..6a4dcbc 100644 --- a/mirage/config.ml +++ b/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" ; ] diff --git a/mirage/partitions.ml b/mirage/partitions.ml new file mode 100644 index 0000000..c438b3c --- /dev/null +++ b/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 diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index 50c9a30..2b94efc 100644 --- a/mirage/unikernel.ml +++ b/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