diff --git a/mirage/config.ml b/mirage/config.ml index ec220b9..399f977 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -18,6 +18,7 @@ let mirror = package "gptar" ; package "oneffs" ; package "digestif" ; + package "swapfs" ; ] (block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job) diff --git a/mirage/partitions.ml b/mirage/partitions.ml index 2c1d19f..575f79b 100644 --- a/mirage/partitions.ml +++ b/mirage/partitions.ml @@ -7,12 +7,14 @@ module Make(BLOCK : Mirage_block.S) = struct type partitions = { tar : Part.t ; + swap : Part.t ; git_dump : Part.t ; md5s : Part.t ; sha512s : Part.t ; } (* I just made these ones up... *) + let swap_guid = Uuidm.of_string "76515dc1-953f-4c59-8b41-90011bdddfcd" |> Option.get 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 @@ -54,33 +56,37 @@ module Make(BLOCK : Mirage_block.S) = struct let connect block = let* info = BLOCK.get_info block in let* gpt = read_partition_table info block in - let tar, git_dump, md5s, sha512s = + let tar, swap, git_dump, md5s, sha512s = match List.fold_left - (fun (tar, git_dump, md5s, sha512s) p -> + (fun (tar, swap, git_dump, md5s, sha512s) p -> if String.equal p.Gpt.Partition.name (utf16be_of_ascii "tar") then - (Some p, git_dump, md5s, sha512s) + (Some p, swap, git_dump, md5s, sha512s) else if String.equal p.name (utf16be_of_ascii "git_dump") then - (tar, Some p, md5s, sha512s) + (tar, swap, Some p, md5s, sha512s) else if String.equal p.name (utf16be_of_ascii "md5s") then - (tar, git_dump, Some p, sha512s) + (tar, swap, git_dump, Some p, sha512s) else if String.equal p.name (utf16be_of_ascii "sha512s") then - (tar, git_dump, md5s, Some p) + (tar, swap, git_dump, md5s, Some p) + else if String.equal p.name + (utf16be_of_ascii "swap") + then + (tar, Some p, git_dump, md5s, sha512s) else Format.kasprintf failwith "Unknown partition %S" p.name) - (None, None, None, None) + (None, None, None, None, None) gpt.partitions with - | (Some tar, Some git_dump, Some md5s, Some sha512s) -> - (tar, git_dump, md5s, sha512s) + | (Some tar, Some swap, Some git_dump, Some md5s, Some sha512s) -> + (tar, swap, git_dump, md5s, sha512s) | _ -> failwith "not all partitions found :(" in @@ -91,11 +97,11 @@ module Make(BLOCK : Mirage_block.S) = struct let (part, _after) = Part.subpartition len after in part in - let tar = get_part tar and git_dump = get_part git_dump + let tar = get_part tar and swap = get_part swap and git_dump = get_part git_dump and md5s = get_part md5s and sha512s = get_part sha512s in - { tar ; git_dump ; md5s ; sha512s } + { tar ; swap; git_dump ; md5s ; sha512s } - let format block ~sectors_cache ~sectors_git = + let format block ~sectors_cache ~sectors_git ~sectors_swap = 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 @@ -144,18 +150,27 @@ module Make(BLOCK : Mirage_block.S) = struct (Int64.pred md5s.starting_lba) |> Result.get_ok in + let swap = + Gpt.Partition.make + ~name:(utf16be_of_ascii "swap") + ~type_guid:swap_guid + ~attributes + (Int64.sub git_dump.starting_lba sectors_swap) + (Int64.pred git_dump.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) + (Int64.pred swap.starting_lba) |> Result.get_ok in let gpt = let partitions = - [ tar; git_dump; md5s; sha512s ] + [ tar; swap; git_dump; md5s; sha512s ] in Gpt.make ~sector_size ~disk_sectors:size_sectors partitions |> Result.get_ok diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index be5b29e..e95436e 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -53,6 +53,11 @@ module K = struct let doc = Arg.info ~doc ["sectors-git"] in Mirage_runtime.register_arg Arg.(value & opt int64 Int64.(mul 40L (mul 2L 1024L)) doc) + let sectors_swap = + let doc = "Number of sectors reserved for swap. Only used with --initialize-disk" in + let doc = Arg.info ~doc ["sectors-swap"] in + Mirage_runtime.register_arg Arg.(value & opt int64 Int64.(mul 1024L 2048L) 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 @@ -75,6 +80,7 @@ module Make module Part = Partitions.Make(BLOCK) module KV = Tar_mirage.Make_KV_RW(Pclock)(Part) module Cache = OneFFS.Make(Part) + module Swap = Swapfs.Make(Part) module Store = Git_kv.Make(Pclock) module SM = Map.Make(String) @@ -189,13 +195,14 @@ module Make dev : KV.t ; dev_md5s : Cache.t ; dev_sha512s : Cache.t ; + dev_swap : Swap.t ; } let pending = Mirage_kv.Key.v "pending" let to_delete = Mirage_kv.Key.v "to-delete" - let empty dev dev_md5s dev_sha512s = { md5s = SM.empty ; sha512s = SM.empty ; dev; dev_md5s; dev_sha512s } + let empty dev dev_md5s dev_sha512s dev_swap = { md5s = SM.empty ; sha512s = SM.empty ; dev; dev_md5s; dev_sha512s ; dev_swap } let marshal_sm (sm : string SM.t) = let version = char_of_int 1 in @@ -355,7 +362,10 @@ module Make Lwt.return_ok (digests, `Fixed_body (size, offset)) | `Unknown -> active_add_bytes url (String.length data); - Lwt.return_ok (digests, `Unknown data) + let h = Swap.empty t.dev_swap in + Swap.append h data >|= function + | Ok () -> Ok (digests, `Unknown h) + | Error swap_err -> Error (`Swap swap_err) end | `Fixed_body (size, offset) -> KV.set_partial t.dev key ~offset data @@ -364,9 +374,11 @@ module Make let offset = Optint.Int63.(add offset (of_int len)) in active_add_bytes url len; Lwt.return_ok (digests, `Fixed_body (size, offset)) - | `Unknown body -> + | `Unknown h -> active_add_bytes url (String.length data); - Lwt.return_ok (digests, `Unknown (body ^ data)) + Swap.append h data >|= function + | Ok () -> Ok (digests, `Unknown h) + | Error swap_err -> Error (`Swap swap_err) let check_csums_digests csums digests = let csums' = Archive_checksum.digests_to_hm digests in @@ -376,7 +388,32 @@ module Make (fun (h, csum) -> String.equal csum (HM.find h csums)) common_bindings - let finalize_write t (hash, csum) ~url (body : [ `Unknown of string | `Fixed_body of int64 * Optint.Int63.t | `Init ]) csums digests = + let set_from_handle dev dest h = + let size = Optint.Int63.of_int64 (Swap.size h) in + KV.allocate dev dest size >>= fun r -> + let rec loop offset = + if offset = Swap.size h then + Lwt.return_ok () + else + let length = Int64.(to_int (min 4096L (sub (Swap.size h) offset))) in + Swap.get_partial h ~offset ~length >>= fun r -> + match r with + | Error e -> Lwt.return (Error (`Swap e)) + | Ok data -> + KV.set_partial dev dest ~offset:(Optint.Int63.of_int64 offset) data + >>= fun r -> + match r with + | Error e -> Lwt.return (Error (`Write_error e)) + | Ok () -> + loop Int64.(add offset (of_int length)) + in + match r with + | Ok () -> + loop 0L + | Error e -> + Lwt.return (Error (`Write_error e)) + + let finalize_write t (hash, csum) ~url (body : [ `Unknown of Swap.handle | `Fixed_body of int64 * Optint.Int63.t | `Init ]) csums digests = let sizes_match, body_size_in_header = match body with | `Fixed_body (reported, actual) -> Optint.Int63.(equal (of_int64 reported) actual), true @@ -390,12 +427,18 @@ module Make and sha512 = Ohex.encode Digestif.SHA512.(to_raw_string (get digests.sha512)) in let dest = Mirage_kv.Key.v sha256 in begin match body with - | `Unknown body -> + | `Unknown h -> Logs.info (fun m -> m "downloaded %s, now writing" url); - KV.set t.dev dest body + Lwt_result.bind + (Lwt.finalize (fun () -> set_from_handle t.dev source h) + (fun () -> Swap.free h)) + (fun () -> + KV.rename t.dev ~source ~dest + |> Lwt_result.map_error (fun e -> `Write_error e)) | `Fixed_body (_reported_size, _actual_size) -> Logs.info (fun m -> m "downloaded %s" url); KV.rename t.dev ~source ~dest + |> Lwt_result.map_error (fun e -> `Write_error e) | `Init -> assert false end >|= function | Ok () -> @@ -403,9 +446,13 @@ module Make t.md5s <- SM.add md5 sha256 t.md5s; t.sha512s <- SM.add sha512 sha256 t.sha512s | Error e -> - Logs.err (fun m -> m "Write failure for %s: %a" url KV.pp_write_error e); + let pp_error ppf = function + | `Write_error e -> KV.pp_write_error ppf e + | `Swap e -> Swap.pp_error ppf e + in + Logs.err (fun m -> m "Write failure for %s: %a" url pp_error e); add_failed url (Ptime.v (Pclock.now_d_ps ())) - (Fmt.str "Write failure for %s: %a" url KV.pp_write_error e) + (Fmt.str "Write failure for %s: %a" url pp_error e) else begin (if sizes_match then begin add_failed url (Ptime.v (Pclock.now_d_ps ())) @@ -447,11 +494,11 @@ module Make end (* on disk, we use a flat file system where the filename is the sha256 of the data *) - let init ~verify_sha256 dev dev_md5s dev_sha512s = + let init ~verify_sha256 dev dev_md5s dev_sha512s dev_swap = KV.list dev Mirage_kv.Key.empty >>= function | Error e -> Logs.err (fun m -> m "error %a listing kv" KV.pp_error e); assert false | Ok entries -> - let t = empty dev dev_md5s dev_sha512s in + let t = empty dev dev_md5s dev_sha512s dev_swap in Cache.read t.dev_md5s >>= fun r -> (match r with | Ok Some s -> @@ -946,6 +993,14 @@ stamp: %S add_failed url (Ptime.v (Pclock.now_d_ps ())) (Fmt.str "write error: %a" KV.pp_write_error e); Lwt.return_unit + | Error `Swap e -> + Logs.err (fun m -> m "%s: swap error %a %a" + url + Mirage_kv.Key.pp (Disk.pending_key quux) + Swap.pp_error e); + add_failed url (Ptime.v (Pclock.now_d_ps ())) + (Fmt.str "swap error: %a" Swap.pp_error e); + Lwt.return_unit | Ok (digests, body) -> Disk.finalize_write disk quux ~url body csums digests end @@ -980,13 +1035,14 @@ stamp: %S module Paf = Paf_mirage.Make(Stack.TCP) - let start_mirror { Part.tar; git_dump; md5s; sha512s } stack git_ctx http_ctx = + let start_mirror { Part.tar; swap; git_dump; md5s; sha512s } stack git_ctx http_ctx = KV.connect tar >>= fun kv -> Cache.connect git_dump >>= fun git_dump -> Cache.connect md5s >>= fun md5s -> Cache.connect sha512s >>= fun sha512s -> + Swap.connect swap >>= fun swap -> 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 -> + Disk.init ~verify_sha256:(K.verify_sha256 ()) kv md5s sha512s swap >>= fun disk -> let remote = K.remote () in if K.check () then Lwt.return_unit @@ -1035,9 +1091,10 @@ stamp: %S let start block _time _pclock stack git_ctx http_ctx = let initialize_disk = K.initialize_disk () and sectors_cache = K.sectors_cache () - and sectors_git = K.sectors_git () in + and sectors_git = K.sectors_git () + and sectors_swap = K.sectors_swap () in if initialize_disk then - Part.format block ~sectors_cache ~sectors_git >>= function + Part.format block ~sectors_cache ~sectors_git ~sectors_swap >>= function | Ok () -> Logs.app (fun m -> m "Successfully initialized the disk! You may restart now without --initialize-disk."); Lwt.return_unit