Use swapfs
This commit is contained in:
parent
f9620e9011
commit
456340562d
3 changed files with 102 additions and 29 deletions
|
|
@ -18,6 +18,7 @@ let mirror =
|
|||
package "gptar" ;
|
||||
package "oneffs" ;
|
||||
package "digestif" ;
|
||||
package "swapfs" ;
|
||||
]
|
||||
(block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue