From 7853eea49be90e920ff311dd2df45f831ac55d7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Wed, 9 Oct 2024 18:42:01 +0200 Subject: [PATCH] Add code for formatting a disk --- mirage/partitions.ml | 97 ++++++++++++++++++++++++++++++++++++++++---- mirage/unikernel.ml | 39 ++++++++++++++---- 2 files changed, 120 insertions(+), 16 deletions(-) diff --git a/mirage/partitions.ml b/mirage/partitions.ml index c438b3c..35748a6 100644 --- a/mirage/partitions.ml +++ b/mirage/partitions.ml @@ -12,6 +12,20 @@ module Make(BLOCK : Mirage_block.S) = struct sha512s : Part.t ; } + (* 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 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') + 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] *) @@ -38,14 +52,6 @@ module Make(BLOCK : Mirage_block.S) = struct | 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 = @@ -88,4 +94,79 @@ module Make(BLOCK : Mirage_block.S) = struct 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 } + + let format block ~sectors_cache ~sectors_git = + let* { size_sectors; sector_size; _ } = BLOCK.get_info block in + let ( let*? ) = Lwt_result.bind 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*? () = + if size_sectors < + (* protective MBR + GPT header + GPT table *) + let ( + ) = Int64.add in + 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 + Lwt.return_error (`Msg "too small disk") + else Lwt_result.return () + in + 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:(utf16be_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:(utf16be_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:(utf16be_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:(utf16be_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; + BLOCK.write block 0L [ buf ] + |> Lwt_result.map_error (fun e -> `Block e) end diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index 01fa5b3..139375e 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -43,14 +43,19 @@ module K = struct Arg.(value & opt int 80 doc) let sectors_cache = - let doc = "Number of sectors reserved for each checksum cache (md5, sha512)." in + let doc = "Number of sectors reserved for each checksum cache (md5, sha512). Only used with --initialize-disk." in let doc = Arg.info ~doc ["sectors-cache"] in Arg.(value & opt int64 Int64.(mul 4L 2048L) doc) let sectors_git = - let doc = "Number of sectors reserved for git dump." in + let doc = "Number of sectors reserved for git dump. Only used with --initialize-disk" in let doc = Arg.info ~doc ["sectors-git"] in Arg.(value & opt int64 Int64.(mul 40L (mul 2L 1024L)) doc) + + let initialize_disk = + let doc = "Initialize the disk with a partition table. THIS IS DESTRUCTIVE!" in + let doc = Arg.info ~doc ["initialize-disk"] in + Arg.(value & flag doc) let ignore_local_git = let doc = "Ignore restoring locally saved git repository." in @@ -66,12 +71,13 @@ module K = struct ; port : int ; sectors_cache : int64 ; sectors_git : int64 + ; initialize_disk : bool ; ignore_local_git : bool } let v check verify_sha256 remote parallel_downloads hook_url port - sectors_cache sectors_git ignore_local_git = + sectors_cache sectors_git initialize_disk ignore_local_git = { check; verify_sha256; remote; parallel_downloads; hook_url; port - ; sectors_cache; sectors_git; ignore_local_git } + ; sectors_cache; sectors_git; initialize_disk; ignore_local_git } let setup = Term.(const v @@ -83,6 +89,7 @@ module K = struct $ port $ sectors_cache $ sectors_git + $ initialize_disk $ ignore_local_git) end @@ -1011,10 +1018,9 @@ stamp: %S module Paf = Paf_mirage.Make(Stack.TCP) - let start block _time _pclock stack git_ctx http_ctx - { K.check; verify_sha256; remote; parallel_downloads; hook_url - ; port; sectors_cache; sectors_git; ignore_local_git } = - Part.connect block >>= fun { Part.tar ; git_dump; md5s ; sha512s } -> + let start_mirror { Part.tar; git_dump; md5s; sha512s } stack git_ctx http_ctx + check verify_sha256 remote parallel_downloads hook_url port + ignore_local_git = KV.connect tar >>= fun kv -> Cache.connect git_dump >>= fun git_dump -> Cache.connect md5s >>= fun md5s -> @@ -1064,4 +1070,21 @@ stamp: %S go ()); download_archives parallel_downloads disk http_ctx git_kv >>= fun () -> (th >|= fun _v -> ()) + + let start block _time _pclock stack git_ctx http_ctx + { K.check; verify_sha256; remote; parallel_downloads; hook_url + ; port; sectors_cache; sectors_git; initialize_disk; ignore_local_git } = + if initialize_disk then + Part.format block ~sectors_cache ~sectors_git >>= function + | Ok () -> Lwt.return_unit + | Error `Msg e -> + Logs.err (fun m -> m "Error formatting disk: %s" e); + exit Mirage_runtime.argument_error + | Error `Block e -> + Logs.err (fun m -> m "Error formatting disk: %a" BLOCK.pp_write_error e); + exit 2 + else + Part.connect block >>= fun parts -> + start_mirror parts stack git_ctx http_ctx check verify_sha256 remote + parallel_downloads hook_url port ignore_local_git end