Compare commits

..

1 commit
main ... cache

Author SHA1 Message Date
391ca131dc Cache only version 2022-10-07 16:54:17 +02:00
8 changed files with 1120 additions and 1372 deletions

View file

@ -1,67 +0,0 @@
module Hash = struct
type t = (* OpamHash.kind = *) [ `MD5 | `SHA256 | `SHA512 ]
(* Make the compiler check that (t :> Digestif.hash') *)
let _ = fun (h :t) -> (h :> Digestif.hash')
let compare h h' =
match h, h' with
| `SHA512, `SHA512 -> 0
| `SHA512, _ -> 1
| _, `SHA512 -> -1
| `SHA256, `SHA256 -> 0
| `SHA256, _ -> 1
| _, `SHA256 -> -1
| `MD5, `MD5 -> 0
let to_string = function
| `MD5 -> "md5"
| `SHA256 -> "sha256"
| `SHA512 -> "sha512"
let of_string = function
| "md5" -> Ok `MD5
| "sha256" -> Ok `SHA256
| "sha512" -> Ok `SHA512
| h -> Error (`Msg ("unknown hash algorithm: " ^ h))
end
module HM = Map.Make(Hash)
type 'a digests = {
md5 : Digestif.MD5.ctx;
sha256 : Digestif.SHA256.ctx;
sha512 : Digestif.SHA512.ctx;
}
let empty_digests =
{
md5 = Digestif.MD5.empty;
sha256 = Digestif.SHA256.empty;
sha512 = Digestif.SHA512.empty;
}
let update_digests { md5; sha256; sha512 } data =
{
md5 = Digestif.MD5.feed_string md5 data;
sha256 = Digestif.SHA256.feed_string sha256 data;
sha512 = Digestif.SHA512.feed_string sha512 data;
}
let init_write csums =
let hash, csum = HM.max_binding csums in
(hash, csum), empty_digests
let digests_to_hm digests =
HM.empty
|> HM.add `MD5
Digestif.MD5.(to_raw_string (get digests.md5))
|> HM.add `SHA256
Digestif.SHA256.(to_raw_string (get digests.sha256))
|> HM.add `SHA512
Digestif.SHA512.(to_raw_string (get digests.sha512))
let get digests = function
| `MD5 -> Digestif.MD5.(to_raw_string (get digests.md5))
| `SHA256 -> Digestif.SHA256.(to_raw_string (get digests.sha256))
| `SHA512 -> Digestif.SHA512.(to_raw_string (get digests.sha512))

193
mirage/bad.ml Normal file
View file

@ -0,0 +1,193 @@
let archives =
let too_big =
[ "https://github.com/Opsian/opsian-ocaml/releases/download/0.1/0.1.tar.gz" ]
and hash_mismatch = [
"http://cdn.skylable.com/source/libres3-1.3.tar.gz" ;
"http://cdn.skylable.com/source/libres3-0.3.tar.gz" ;
"http://cdn.skylable.com/source/libres3-1.2.tar.gz" ;
"http://cdn.skylable.com/source/libres3-0.9.tar.gz" ;
"http://cdn.skylable.com/source/libres3-0.2.tar.gz" ;
"http://cdn.skylable.com/source/libres3-1.0.tar.gz" ;
"http://cdn.skylable.com/source/libres3-1.1.tar.gz" ;
"http://cdn.skylable.com/source/libres3-0.1.tar.gz" ;
"https://github.com/lemaetech/http-cookie/releases/download/v3.0.0/http-cookie-v3.0.0.tbz" ;
"http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.4.tar.gz" ;
"http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.2.tar.gz" ;
"http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.3.tar.gz" ;
"http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.5.tar.gz" ;
"http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.1.tar.gz" ;
"https://github.com/OCamlPro/ezjs_fetch/archive/0.1.tar.gz" ;
"http://github.com/OCamlPro/typerex-build/archive/1.99.13-beta.tar.gz" ;
"https://github.com/mirage/dyntype/tarball/dyntype-0.8.5" ;
"https://github.com/mirage/dyntype/tarball/dyntype-0.8.3" ;
"https://github.com/mirage/dyntype/tarball/dyntype-0.8.2" ;
"https://github.com/mirage/dyntype/tarball/dyntype-0.8.4" ;
"https://github.com/mirage/mirage-http-unix/archive/v1.0.0.tar.gz" ;
"http://github.com/OCamlPro/typerex-build/archive/1.99.15-beta.tar.gz" ;
"http://github.com/OCamlPro/typerex-build/archive/1.99.14-beta.tar.gz" ;
"https://github.com/paulpatault/ocamlog/archive/v0.1.tar.gz" ;
"https://github.com/pveber/OCaml-R/archive/pre-nyc-refactoring.tar.gz" ;
"https://github.com/paulpatault/ocamlog/archive/v0.2.tar.gz" ;
"http://github.com/OCamlPro/typerex-build/archive/1.99.16-beta.tar.gz" ;
"https://github.com/FStarLang/kremlin/archive/v0.9.6.0.zip" ;
"https://gitlab.com/dailambda/plebeia/-/archive/2.0.2/plebeia-2.0.2.tar.gz" ;
"https://github.com/mirleft/ocaml-tls/archive/0.5.0.tar.gz" ;
"https://github.com/eth-sri/ELINA/archive/1.3.tar.gz" ;
"https://gitlab.com/trustworthy-refactoring/refactorer/-/archive/0.1/refactorer-0.1.zip" ;
"https://github.com/completium/archetype-lang/archive/1.3.3.tar.gz" ;
"https://github.com/chetmurthy/pa_ppx/archive/0.01.tar.gz" ;
"https://github.com/chambart/ocaml-1/archive/lto.tar.gz" ;
"https://github.com/Kappa-Dev/KaSim/archive/v3.5-250915.tar.gz" ;
"https://github.com/bsansouci/bsb-native/archive/1.9.4.tar.gz"
]
and bad_request = [
"http://cgit.freedesktop.org/cairo-ocaml/snapshot/cairo-ocaml-1.2.0.tar.gz"
]
and not_found = [
"http://pw374.github.io/distrib/frag/frag-0.1.0.tar.gz" ;
"http://pw374.github.io/distrib/glical/glical-0.0.3.tar.gz" ;
"http://pw374.github.io/distrib/glical/glical-0.0.4.tar.gz" ;
"http://pw374.github.io/distrib/glical/glical-0.0.1.tar.gz" ;
"http://pw374.github.io/distrib/glical/glical-0.0.2.tar.gz" ;
"http://pw374.github.io/distrib/glical/glical-0.0.5.tar.gz" ;
"http://pw374.github.io/distrib/glical/glical-0.0.7.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.1.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.0.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.2.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.7.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.3.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.8.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.4.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.1.5.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.2.0.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.2.1.tar.gz" ;
"http://pw374.github.io/distrib/mpp/mpp-0.3.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.3.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.4.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.5.4.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.5.5.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.5.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.6.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.6.2.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.6.3.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.6.4.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.6.5.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.7.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.7.1.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.7.2.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.7.4.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.7.3.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.7.5.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.8.2.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.8.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.8.1.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.9.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.9.1.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.9.7.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.0.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.0.1.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.1.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.1.1.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.1.2.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.2.0.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.2.1.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.2.2.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.2.4.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.2.5.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.2.6.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.2.3.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.3.0.tar.gz" ;
"http://zoggy.github.com/ocamldot/ocamldot-1.0.tar.gz" ;
"http://zoggy.github.io/stog/stog-0.4.tar.gz" ;
"http://zoggy.github.io/genet/genet-0.6.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.6.1.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.9.4.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.9.6.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.9.5.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-0.9.3.tar.gz" ;
"http://pw374.github.io/distrib/omd/omd-1.1.3.tar.gz" ;
"http://coccinelle.lip6.fr/distrib/coccinelle-1.0.0-rc22.tgz" ;
"http://coccinelle.lip6.fr/distrib/coccinelle-1.0.0-rc21.tgz" ;
"http://coccinelle.lip6.fr/distrib/coccinelle-1.0.0.tgz" ;
"http://proverif.inria.fr/proverif1.96pl1.tar.gz" ;
"http://proverif.inria.fr/proverif1.97.tar.gz" ;
"http://proverif.inria.fr/proverif1.98.tar.gz" ;
"http://proverif.inria.fr/proverif1.97pl3.tar.gz" ;
"http://proverif.inria.fr/proverif1.98pl1.tar.gz" ;
"http://proverif.inria.fr/proverif1.97pl1.tar.gz" ;
"https://github.com/jrochel/eliom/archive/6.4.0.tar.gz" ;
"https://github.com/drjdn/ocaml_lua_parser/archive/1.0.1.tar.gz" ;
"https://github.com/sagotch/To.ml/archive/v1.0.0.tar.gz" ;
"https://zoggy.github.io/ocaml-rdf/ocaml-rdf-0.9.0.tar.gz" ;
"https://github.com/sagotch/To.ml/archive/v2.1.0.tar.gz" ;
"https://github.com/sagotch/To.ml/archive/v2.0.0.tar.gz" ;
"https://zoggy.github.io/ocaml-taglog/taglog-0.1.0.tar.gz" ;
"https://zoggy.github.io/ocaml-taglog/taglog-0.2.0.tar.gz" ;
"https://zoggy.github.io/ocf/ocf-0.3.0.tar.gz" ;
"https://zoggy.github.io/ojs-base/ojs-base-0.1.0.tar.gz" ;
"https://zoggy.github.io/stog/plugins/stog-writing-0.8.0.tar.gz" ;
"https://zoggy.github.io/stog/stog-0.13.0.tar.gz" ;
"https://zoggy.github.io/ocaml-taglog/taglog-0.3.0.tar.gz" ;
"https://zoggy.github.io/ocf/ocf-0.1.0.tar.gz" ;
"https://opam.ocaml.org/cache/md5/24/24b163eb77e6832747dccd6cc8a5d57c" ;
]
and forbidden = [
"https://gforge.inria.fr/frs/download.php/33440/heptagon-1.00.06.tar.gz" ;
"https://gforge.inria.fr/frs/download.php/file/33677/dose3-3.2.2.tar.gz" ;
"https://gforge.inria.fr/frs/download.php/file/34920/javalib-2.3.1.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/36092/javalib-2.3.2.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/36093/sawja-1.5.2.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/37154/javalib-2.3.4.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/37403/sawja-1.5.3.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/36307/javalib-2.3.3.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/37655/javalib-2.3.5.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/37656/sawja-1.5.4.tar.bz2" ;
"https://gforge.inria.fr/frs/download.php/file/34921/sawja-1.5.1.tar.bz2" ;
]
and three_o_o = [
"https://github.com/Gbury/dolmen/archive/v0.4.tar.gz" ;
"https://github.com/Stevendeo/Pilat/archive/1.3.tar.gz" ;
"https://github.com/OCamlPro/ocp-indent/archive/1.5.tar.gz" ;
"https://github.com/backtracking/combine/archive/release-0.6.zip" ;
"https://github.com/cakeplus/pa_comprehension/archive/0.4.tar.gz" ;
"https://github.com/cakeplus/mparser/archive/1.0.tar.gz" ;
"https://github.com/chenyukang/rubytt/archive/v0.1.tar.gz" ;
"https://github.com/cakeplus/pa_where/archive/0.4.tar.gz" ;
"https://github.com/metaocaml/ber-metaocaml/archive/ber-n102.tar.gz" ;
"https://github.com/cakeplus/pa_solution/archive/0.5.tar.gz" ;
"https://github.com/cakeplus/mparser/archive/1.2.1.tar.gz" ;
"https://github.com/cakeplus/pa_solution/archive/0.7.tar.gz" ;
"https://github.com/cakeplus/pa_solution/archive/0.6.tar.gz" ;
"https://github.com/mirage/mirage-tcpip/archive/v2.8.1.tar.gz" ;
"https://github.com/modlfo/pla/archive/v1.4.tar.gz" ;
"https://github.com/murmour/pa_qualified/archive/0.5.tar.gz" ;
"https://github.com/ocaml-ppx/ocamlformat/archive/v0.2.tar.gz" ;
"https://github.com/murmour/pa_qualified/archive/0.6.tar.gz" ;
"https://github.com/ocaml-ppx/ocamlformat/archive/support.0.2.tar.gz" ;
"https://github.com/ocaml/oloop/archive/0.1.2.tar.gz" ;
"https://github.com/cakeplus/mparser/archive/1.0.1.tar.gz" ;
"https://github.com/cakeplus/mparser/archive/1.1.tar.gz" ;
"https://github.com/savonet/ocaml-ffmpeg/archive/v1.0.0-rc1.tar.gz" ;
"https://github.com/ocaml/opam2web/archive/2.0.tar.gz" ;
"https://github.com/savonet/ocaml-ffmpeg/archive/v1.0.0.tar.gz" ;
]
and five_o_three = [ "https://gitlab.com/gasche/build_path_prefix_map/repository/0.2/archive.tar.gz" ]
and is_ftp = [ "ftp://ftp.netbsd.org/pub/pkgsrc/distfiles/wyrd-1.4.6.tar.gz" ]
and connect_fails = [
"http://godi.0ok.org/godi-backup/shcaml-0.1.3.tar.gz" ;
"http://www.first.in-berlin.de/software/tools/apalogretrieve/apalogretrieve-0-9-6_4.tgz" ;
"https://cavale.enseeiht.fr/osdp/osdp-0.5.4.tgz" ;
"https://cavale.enseeiht.fr/osdp/osdp-0.6.0.tgz" ;
"https://cavale.enseeiht.fr/osdp/osdp-1.0.0.tgz" ;
]
in
too_big @ hash_mismatch @ bad_request @ not_found @ forbidden @ three_o_o @ five_o_three @ is_ftp @ connect_fails

View file

@ -1,40 +1,106 @@
(* mirage >= 4.8.0 & < 4.9.0 *)
open Mirage
type http_client = HTTP_client
let http_client = typ HTTP_client
let check =
let doc =
Key.Arg.info ~doc:"Only check the cache" ["check"]
in
Key.(create "check" Arg.(flag doc))
let verify =
let doc =
Key.Arg.info ~doc:"Verify the cache contents" ["verify"]
in
Key.(create "verify" Arg.(flag doc))
let remote =
let doc =
Key.Arg.info
~doc:"Remote repository url"
["remote"]
in
Key.(create "remote" Arg.(opt string "https://opam.ocaml.org" doc))
let parallel_downloads =
let doc =
Key.Arg.info
~doc:"Amount of parallel HTTP downloads"
["parallel-downloads"]
in
Key.(create "parallel-downloads" Arg.(opt int 20 doc))
let hook_url =
let doc =
Key.Arg.info
~doc:"URL to conduct an update of the opam repository" ["hook-url"]
in
Key.(create "hook-url" Arg.(opt string "update" doc))
let port =
let doc = Key.Arg.info ~doc:"HTTP listen port." ["port"] in
Key.(create "port" Arg.(opt int 80 doc))
let tls_authenticator =
(* this will not look the same in the help printout *)
let doc = "TLS host authenticator. See git_http in lib/mirage/mirage.mli for a description of the format."
in
let doc = Key.Arg.info ~doc ["tls-authenticator"] in
Key.(create "tls-authenticator" Arg.(opt (some string) None doc))
let sectors_cache =
let doc = "Number of sectors reserved for each checksum cache (md5, sha512)." in
let doc = Key.Arg.info ~doc ["sectors-cache"] in
Key.(create "sectors-cache" Arg.(opt int64 Int64.(mul 4L 2048L) doc))
let mirror =
main "Unikernel.Make"
foreign "Unikernel.Make"
~keys:[ Key.v check ; Key.v verify ; Key.v remote ;
Key.v parallel_downloads ; Key.v hook_url ; Key.v tls_authenticator ;
Key.v port ; Key.v sectors_cache ; ]
~packages:[
package ~min:"0.3.0" ~sublibs:[ "mirage" ] "paf" ;
package ~min:"0.2.0" ~sublibs:[ "mirage" ] "paf" ;
package "h2" ;
package "ohex" ;
package "httpaf" ;
package ~min:"0.0.5" "git-kv" ;
package ~min:"3.10.0" "git-paf" ;
package "opam-file-format" ;
package ~min:"3.0.0" ~sublibs:[ "gz" ] "tar" ;
package ~min:"3.0.0" "tar-mirage" ;
package ~max:"0.2.0" "mirage-block-partition" ;
package ~min:"0.0.8" "http-mirage-client" ;
package "gpt" ;
package "gptar" ;
package ~min:"2.1.0" ~sublibs:[ "gz" ] "tar" ~pin:"git+https://github.com/hannesm/ocaml-tar.git#kv-rw-kv-5" ;
package ~pin:"git+https://github.com/hannesm/ocaml-tar.git#kv-rw-kv-5" "tar-mirage" ;
package "mirage-block-partition" ;
package "oneffs" ;
package "digestif" ;
package "swapfs" ;
package "hex" ;
]
(block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job)
(block @-> time @-> pclock @-> stackv4v6 @-> http_client @-> job)
let stack = generic_stackv4v6 default_network
let he = generic_happy_eyeballs stack
let dns = generic_dns_client stack he
let dns = generic_dns_client stack
let tcp = tcpv4v6_of_stackv4v6 stack
let http_client =
let connect _ modname = function
| [ _time; _pclock; _tcpv4v6; ctx ] ->
Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx
| _ -> assert false in
impl ~connect "Http_mirage_client.Make"
(time @-> pclock @-> tcpv4v6 @-> git_client @-> http_client)
(* XXX(dinosaure): [git_client] seems bad but it becames from a long discussion
when a "mimic" device seems not accepted by everyone. We can copy [git_happy_eyeballs]
and provide an [http_client] instead of a [git_client] but that mostly means that
2 instances of happy-eyeballs will exists together which is not really good
(it puts a pressure on the scheduler). *)
let http_client =
let happy_eyeballs = generic_happy_eyeballs stack dns in
let happy_eyeballs = git_happy_eyeballs stack dns happy_eyeballs in
http_client $ default_time $ default_posix_clock $ tcp $ happy_eyeballs
let program_block_size =
let doc = Key.Arg.info [ "program-block-size" ] in
Key.(create "program_block_size" Arg.(opt int 16 doc))
let block = block_of_file "tar"
let git_client, alpn_client =
let git = mimic_happy_eyeballs stack he dns in
merge_git_clients (git_ssh tcp git)
(merge_git_clients (git_tcp tcp git)
(git_http tcp git)),
paf_client tcp (mimic_happy_eyeballs stack he dns)
let () = register "mirror"
[ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ alpn_client ]
[ mirror $ block $ default_time $ default_posix_clock $ stack $ http_client ]

View file

@ -0,0 +1,340 @@
let http_scheme = Mimic.make ~name:"http-scheme"
let http_port = Mimic.make ~name:"http-port"
let http_hostname = Mimic.make ~name:"http-hostname"
let tls_config = Mimic.make ~name:"tls-config"
open Lwt.Infix
module type S = sig
val connect : Mimic.ctx -> Mimic.ctx Lwt.t
val alpn_protocol : Mimic.flow -> string option
val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
end
module Make
(Time : Mirage_time.S)
(Pclock : Mirage_clock.PCLOCK)
(TCP : Tcpip.Tcp.S)
(Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct
module TCP = struct
include TCP
type endpoint = Happy_eyeballs.t * string * int
type nonrec write_error =
[ `Write of write_error | `Connect of string | `Closed ]
let pp_write_error ppf = function
| `Connect err -> Fmt.string ppf err
| `Write err -> pp_write_error ppf err
| `Closed as err -> pp_write_error ppf err
let write flow cs =
let open Lwt.Infix in
write flow cs >>= function
| Ok _ as v -> Lwt.return v
| Error err -> Lwt.return_error (`Write err)
let writev flow css =
writev flow css >>= function
| Ok _ as v -> Lwt.return v
| Error err -> Lwt.return_error (`Write err)
let connect (happy_eyeballs, hostname, port) =
Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
| Error (`Msg err) -> Lwt.return_error (`Connect err)
| Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
end
let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP)
module TLS = struct
type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int
include Tls_mirage.Make (TCP)
let connect (happy_eyeballs, cfg, hostname, port) =
let peer_name =
Result.(to_option (bind (Domain_name.of_string hostname) Domain_name.host)) in
Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
| Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
| Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
end
let tls_edn, tls_protocol =
Mimic.register ~name:"tls" (module TLS)
let connect ctx =
let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with
| "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port)
| _ -> Lwt.return_none in
let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = match http_scheme with
| "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port)
| _ -> Lwt.return_none in
let ctx = Mimic.fold tcp_edn
Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
; req http_scheme; req http_hostname; dft http_port 80 ]
~k:k0 ctx in
Lwt.return (Mimic.fold tls_edn
Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
; req http_scheme; req http_hostname; dft http_port 443
; req tls_config ]
~k:k1 ctx)
let alpn_protocol flow =
let module M = (val (Mimic.repr tls_protocol)) in
match flow with
| M.T flow ->
( match TLS.epoch flow with
| Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol
| Error _ -> None )
| _ -> None
let authenticator =
let module V = Ca_certs_nss.Make (Pclock) in
V.authenticator ()
end
module Version = Httpaf.Version
module Status = H2.Status
module Headers = H2.Headers
type response =
{ version : Version.t
; status : Status.t
; reason : string
; headers : Headers.t }
module HTTP_1_1 = struct
include Httpaf.Client_connection
let yield_reader _ = assert false
let next_read_operation t =
(next_read_operation t :> [ `Close | `Read | `Yield ])
end
let add_authentication ~add headers = function
| None -> headers
| Some (user, pass) ->
let data = Base64.encode_string (user ^ ":" ^ pass) in
add headers "authorization" ("Basic " ^ data)
let prepare_http_1_1_headers headers host user_pass body_length =
let headers = Httpaf.Headers.of_list headers in
let add = Httpaf.Headers.add_unless_exists in
let headers = add headers "user-agent" ("http-mirage-client/%%VERSION%%") in
let headers = add headers "host" host in
let headers = add headers "connection" "close" in
let headers = match body_length with
| None -> headers
| Some v -> add headers "content-length" (string_of_int v) in
add_authentication ~add headers user_pass
let single_http_1_1_request ?config flow user_pass host meth path headers body =
let body_length = Option.map String.length body in
let headers = prepare_http_1_1_headers headers host user_pass body_length in
let req = Httpaf.Request.create ~headers meth path in
let finished, notify_finished = Lwt.wait () in
let wakeup = let w = ref false in
fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
let response_handler response body =
let buf = Buffer.create 0x100 in
let rec on_eof () =
let response =
{ version= response.Httpaf.Response.version
; status = (response.Httpaf.Response.status :> H2.Status.t)
; reason = response.Httpaf.Response.reason
; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
wakeup (Ok (response, Some (Buffer.contents buf)))
and on_read ba ~off ~len =
Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
Httpaf.Body.schedule_read body ~on_read ~on_eof in
let on_eof () =
let response =
{ version= response.Httpaf.Response.version
; status = (response.Httpaf.Response.status :> H2.Status.t)
; reason = response.Httpaf.Response.reason
; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
wakeup (Ok (response, None)) in
Httpaf.Body.schedule_read body ~on_read ~on_eof in
let error_handler e =
let err = match e with
| `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
| `Invalid_response_body_length _ -> Error (`Msg ("Invalid response body length"))
| `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
wakeup err in
let request_body, conn = Httpaf.Client_connection.request ?config req ~error_handler
~response_handler in
Lwt.async (fun () -> Paf.run (module HTTP_1_1) conn flow) ;
Option.iter (Httpaf.Body.write_string request_body) body ;
Httpaf.Body.close_writer request_body ;
finished
let prepare_h2_headers headers host user_pass body_length =
let headers = H2.Headers.of_list headers in
let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in
let headers = add headers ":authority" host in
let headers = add headers "content-length" (string_of_int (Option.value ~default:0 body_length)) in
add_authentication ~add headers user_pass
let single_h2_request ?config ~scheme flow user_pass host meth path headers body =
let body_length = Option.map String.length body in
let headers = prepare_h2_headers headers host user_pass body_length in
let req = H2.Request.create ~scheme ~headers meth path in
let finished, notify_finished = Lwt.wait () in
let wakeup = let w = ref false in
fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
let response_handler response response_body =
let buf = Buffer.create 0x100 in
let rec on_eof () =
let response =
{ version= { major= 2; minor= 0; }
; status = response.H2.Response.status
; reason = ""
; headers= response.H2.Response.headers } in
wakeup (Ok (response, Some (Buffer.contents buf)))
and on_read ba ~off ~len =
Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
H2.Body.Reader.schedule_read response_body
~on_read ~on_eof in
let on_eof () =
let response =
{ version= { major= 2; minor= 0; }
; status = response.H2.Response.status
; reason = ""
; headers= response.H2.Response.headers } in
wakeup (Ok (response, None)) in
H2.Body.Reader.schedule_read response_body
~on_read ~on_eof in
let error_handler e =
let err = match e with
| `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
| `Invalid_response_body_length _ -> Error (`Msg "Invalid response body length")
| `Protocol_error (err, msg) ->
let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in
Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum err msg
| `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
wakeup err in
let conn = H2.Client_connection.create ?config ?push_handler:None
~error_handler in
let request_body = H2.Client_connection.request conn req ~error_handler ~response_handler in
Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow) ;
Option.iter (H2.Body.Writer.write_string request_body) body ;
H2.Body.Writer.close request_body ;
finished >|= fun v ->
H2.Client_connection.shutdown conn ;
v
let decode_uri ~ctx uri =
let ( >>= ) = Result.bind in
match String.split_on_char '/' uri with
| proto :: "" :: user_pass_host_port :: path ->
( if String.equal proto "http:"
then Ok ("http", Mimic.add http_scheme "http" ctx)
else if String.equal proto "https:"
then Ok ("https", Mimic.add http_scheme "https" ctx)
else Error (`Msg "Couldn't decode user and password") ) >>= fun (scheme, ctx) ->
let decode_user_pass up = match String.split_on_char ':' up with
| [ user; pass; ] -> Ok (user, pass)
| _ -> Error (`Msg "Couldn't decode user and password") in
( match String.split_on_char '@' user_pass_host_port with
| [ host_port ] -> Ok (None, host_port)
| [ user_pass; host_port ] ->
decode_user_pass user_pass >>= fun up ->
Ok (Some up, host_port)
| _ -> Error (`Msg "Couldn't decode URI") ) >>= fun (user_pass, host_port) ->
( match String.split_on_char ':' host_port with
| [] -> Error (`Msg "Empty host & port")
| [ hostname ] -> Ok (hostname, Mimic.add http_hostname hostname ctx)
| hd :: tl ->
let port, hostname = match List.rev (hd :: tl) with
| hd :: tl -> hd, String.concat ":" (List.rev tl)
| _ -> assert false in
( try Ok (hostname, Mimic.add http_hostname hostname (Mimic.add http_port (int_of_string port) ctx))
with Failure _ -> Error (`Msg "Couldn't decode port") ) ) >>= fun (hostname, ctx) ->
Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path)
| _ -> Error (`Msg "Couldn't decode URI on top")
let ( >>? ) = Lwt_result.bind
let alpn_protocol_of_string = function
| "http/1.1" -> Some `HTTP_1_1
| "h2" -> Some `H2
| _ -> None
let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri =
Lwt.return (decode_uri ~ctx uri) >>? fun (ctx, scheme, host, user_pass, path) ->
let ctx = match Lazy.force cfg with
| Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx
| Ok (`Default cfg) ->
( match Result.bind (Domain_name.of_string host) Domain_name.host with
| Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx
| Error _ -> Mimic.add tls_config cfg ctx )
| Error _ -> ctx in
Mimic.resolve ctx >>? fun flow ->
(match Option.bind (alpn_protocol flow) alpn_protocol_of_string, config with
| (Some `HTTP_1_1 | None), Some (`HTTP_1_1 config) ->
single_http_1_1_request ~config flow user_pass host meth path headers body
| (Some `HTTP_1_1 | None), None ->
single_http_1_1_request flow user_pass host meth path headers body
| (Some `H2 | None), Some (`H2 config) ->
single_h2_request ~config ~scheme flow user_pass host meth path headers body
| Some `H2, None ->
single_h2_request ~scheme flow user_pass host meth path headers body
| Some `H2, (Some (`HTTP_1_1 _)) ->
single_h2_request ~scheme flow user_pass host meth path headers body
| Some `HTTP_1_1, Some (`H2 _) ->
single_http_1_1_request flow user_pass host meth path headers body) >>= fun r ->
Mimic.close flow >|= fun () ->
r
let tls_config ?tls_config ?config authenticator =
lazy ( match tls_config with
| Some cfg -> Ok (`Custom cfg)
| None ->
let alpn_protocols = match config with
| None -> [ "h2"; "http/1.1" ]
| Some (`H2 _) -> [ "h2" ]
| Some (`HTTP_1_1 _) -> [ "http/1.1" ] in
Result.map (fun authenticator -> `Default (Tls.Config.client ~alpn_protocols ~authenticator ())) authenticator )
let resolve_location ~uri ~location =
match String.split_on_char '/' location with
| "http:" :: "" :: _ -> Ok location
| "https:" :: "" :: _ -> Ok location
| "" :: "" :: _ ->
let schema = String.sub uri 0 (String.index uri '/') in
Ok (schema ^ location)
| "" :: _ ->
(match String.split_on_char '/' uri with
| schema :: "" :: user_pass_host_port :: _ ->
Ok (String.concat "/" [schema ; "" ; user_pass_host_port ^ location])
| _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri)))
| _ -> Error (`Msg ("unknown location (relative path): " ^ location))
let one_request
?config
?tls_config:cfg
~ctx
~alpn_protocol
~authenticator
?(meth= `GET)
?(headers= [])
?body
?(max_redirect= 5)
?(follow_redirect= true) uri =
let tls_config = tls_config ?tls_config:cfg ?config authenticator in
if not follow_redirect
then single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
else
let rec follow_redirect count uri =
if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded")
else
single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
>>? fun (resp, body) ->
if Status.is_redirection resp.status then
( match Headers.get resp.headers "location" with
| Some location ->
Lwt.return (resolve_location ~uri ~location) >>? fun uri ->
follow_redirect (pred count) uri
| None ->
Lwt.return_ok (resp, body) )
else
Lwt.return_ok (resp, body) in
follow_redirect max_redirect uri

View file

@ -0,0 +1,35 @@
module type S = sig
val connect : Mimic.ctx -> Mimic.ctx Lwt.t
val alpn_protocol : Mimic.flow -> string option
val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
end
module Make
(Time : Mirage_time.S)
(Pclock : Mirage_clock.PCLOCK)
(TCP : Tcpip.Tcp.S)
(Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S
module Version = Httpaf.Version
module Status = H2.Status
module Headers = H2.Headers
type response =
{ version : Version.t
; status : Status.t
; reason : string
; headers : Headers.t }
val one_request :
?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] ->
?tls_config:Tls.Config.client ->
ctx:Mimic.ctx ->
alpn_protocol:(Mimic.flow -> string option) ->
authenticator:(X509.Authenticator.t, [> `Msg of string ]) result ->
?meth:Httpaf.Method.t ->
?headers:(string * string) list ->
?body:string ->
?max_redirect:int ->
?follow_redirect:bool ->
string ->
(response * string option, [> Mimic.error ]) result Lwt.t

View file

@ -1,144 +0,0 @@
module HM = Archive_checksum.HM
let hash_to_string = Archive_checksum.Hash.to_string
let hex_of_string s =
match Ohex.decode s with
| d -> Ok d
| exception Invalid_argument err -> Error (`Msg err)
let decode_digest filename str =
let hex h s =
match hex_of_string s with
| Ok d -> Ok (h, d)
| Error _ as e -> e
in
match String.split_on_char '=' str with
| [ data ] -> hex `MD5 data
| [ "md5" ; data ] -> hex `MD5 data
| [ "sha256" ; data ] -> hex `SHA256 data
| [ "sha512" ; data ] -> hex `SHA512 data
| [ hash ; _ ] -> Error (`Msg ("unknown hash " ^ hash))
| _ -> Error (`Msg ("unexpected hash format " ^ str))
let extract_url_checksum filename items =
let open OpamParserTypes.FullPos in
let url =
List.find_opt
(function { pelem = Variable ({ pelem = "src" ; _ }, _); _ } -> true | _ -> false)
items
and archive =
List.find_opt
(function { pelem = Variable ({ pelem = "archive" ; _ }, _); _ } -> true | _ -> false)
items
and checksum =
List.find_opt
(function { pelem = Variable ({ pelem = "checksum" ; _ }, _); _ } -> true | _ -> false)
items
and mirrors =
List.find_opt
(function { pelem = Variable ({ pelem = "mirrors" ; _ }, _); _ } -> true | _ -> false)
items
in
let url =
match url, archive with
| Some { pelem = Variable (_, { pelem = String url ; _ }) ; _ }, None -> Ok url
| None, Some { pelem = Variable (_, { pelem = String url ; _ }); _ } -> Ok url
| _ -> Error (`Msg "neither 'src' nor 'archive' present")
and mirrors = match mirrors with
| None -> []
| Some { pelem = Variable (_, { pelem = String url ; _ }) ; _ } -> [ url ]
| Some { pelem = Variable (_, { pelem = List { pelem = urls ; _ } ; _ }) } ->
List.fold_left (fun acc -> function
| { pelem = String url ; _ } -> url :: acc
| v ->
Logs.err (fun m -> m "bad mirror data (expected a string in the list): %s"
(OpamPrinter.FullPos.value v));
acc)
[] urls
| Some v ->
Logs.err (fun m -> m "bad mirror data (expected string or string list): %s"
(OpamPrinter.FullPos.items [ v ]));
[]
in
let csum, csum_errs =
match checksum with
| Some { pelem = Variable (_, { pelem = List { pelem = csums ; _ } ; _ }); _ } ->
let csums, errs =
List.fold_left (fun (csums, errs) ->
function
| { pelem = String csum ; _ } ->
begin match decode_digest filename csum with
| Error e -> csums, e :: errs
| Ok (h, v) ->
HM.update h (function
| None -> Some v
| Some v' when String.equal v v' -> None
| Some v' ->
Logs.warn (fun m -> m "for %s, hash %s, multiple keys are present: %s %s"
(Result.value ~default:"NONE" url) (hash_to_string h) (Ohex.encode v) (Ohex.encode v'));
None)
csums, errs
end
| v ->
csums, `Msg (Fmt.str "bad checksum data: %s" (OpamPrinter.FullPos.value v)) :: errs)
(HM.empty, []) csums
in
if HM.is_empty csums then
match errs with
| hd :: tl -> Error hd, tl
| [] -> Error (`Msg "empty checksums"), []
else
Ok csums, errs
| Some { pelem = Variable (_, { pelem = String csum ; _ }) ; _ } ->
begin match decode_digest filename csum with
| Error _ as e -> e, []
| Ok (h, v) -> Ok (HM.singleton h v), []
end
| _ -> Error (`Msg "couldn't find or decode 'checksum'"), []
in
(match url, csum with
| Ok url, Ok csum -> Ok (url, csum, mirrors)
| Error _ as e, _
| _, (Error _ as e) -> e), csum_errs
let extract_checksums_and_urls filename opam =
let open OpamParserTypes.FullPos in
List.fold_left (fun (csum_urls, errs) ->
function
| { pelem = Section ({ section_kind = { pelem = "url" ; _ } ; section_items = { pelem = items ; _ } ; _ }) ; _} ->
begin match extract_url_checksum filename items with
| Error `Msg msg, errs' -> csum_urls, `Msg ("url: " ^ msg) :: errs' @ errs
| Ok url, errs' -> url :: csum_urls, errs' @ errs
end
| { pelem = Section ({ section_kind = { pelem = "extra-source" ; _ } ; section_name = Some { pelem ; _ } ; section_items = { pelem = items ; _ }; _ }) ; _} ->
begin
match extract_url_checksum filename items with
| Error `Msg msg, errs' -> csum_urls, `Msg ("extra-source " ^ pelem ^ " " ^ msg) :: errs' @ errs
| Ok url, errs' -> url :: csum_urls, errs' @ errs
end
| _ -> csum_urls, errs)
([], []) opam.file_contents
let extract_urls filename str =
(* in an opam file, there may be:
url { src: <string> checksum: [ STRING ] } <- list of hash
url { src: <string> checksum: STRING } <- single hash
url { archive: <string> checksum: STRING } <- MD5
extra-source NAME { src: URL checksum: [ STRING ] } (OR checksum: STRING) <- multiple occurences possible
*)
let open OpamParserTypes.FullPos in
let opamfile = OpamParser.FullPos.string str filename in
let unavailable =
List.exists
(function
| { pelem = Variable ({ pelem = "available" ; _ },
{ pelem = (Bool false | List { pelem = [{ pelem = Bool false; _ }] ; _ }); _ })
; _ } -> true
| _ -> false)
opamfile.file_contents
in
if unavailable then
[], []
else
extract_checksums_and_urls filename opamfile

View file

@ -1,222 +0,0 @@
open Lwt.Syntax
module Make(BLOCK : Mirage_block.S) = struct
module Part = Mirage_block_partition.Make(BLOCK)
include Part
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
(* 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] *)
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* info = BLOCK.get_info block in
let* gpt = read_partition_table info block in
let tar, swap, git_dump, md5s, sha512s =
match
List.fold_left
(fun (tar, swap, git_dump, md5s, sha512s) p ->
if String.equal p.Gpt.Partition.name
(utf16be_of_ascii "tar")
then
(Some p, swap, git_dump, md5s, sha512s)
else if String.equal p.name
(utf16be_of_ascii "git_dump")
then
(tar, swap, Some p, md5s, sha512s)
else if String.equal p.name
(utf16be_of_ascii "md5s")
then
(tar, swap, git_dump, Some p, sha512s)
else if String.equal p.name
(utf16be_of_ascii "sha512s")
then
(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)
gpt.partitions
with
| (Some tar, Some swap, Some git_dump, Some md5s, Some sha512s) ->
(tar, swap, 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 swap = get_part swap and git_dump = get_part git_dump
and md5s = get_part md5s and sha512s = get_part sha512s in
{ tar ; swap; git_dump ; md5s ; sha512s }
let format block ~cache_size ~git_size ~swap_size =
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 mb_in_sectors mb =
(* 1 megabyte is 2^20 bytes (1024 * 1024) *)
let mb_in_bytes = Int64.(shift_left (of_int mb) 20) in
let ss = Int64.of_int sector_size in
Int64.(div (add mb_in_bytes (sub ss 1L)) ss)
in
let sectors_cache = mb_in_sectors cache_size
and sectors_git = mb_in_sectors git_size
and sectors_swap = mb_in_sectors swap_size
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
(* 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 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 swap.starting_lba)
|> Result.get_ok
in
let gpt =
let partitions =
[ tar; swap; 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;
let write block sector_start buffers =
BLOCK.write block sector_start buffers
|> Lwt_result.map_error (fun e -> `Block e)
in
let*? () =
write block 0L [ buf ]
in
(* Format the file systems by writing zeroes *)
(* For tar we need to zero (at least) the first 2*512 bytes so we round up
to the nearest sector alignment *)
let zeroes =
let sectors =
(2 * Tar.Header.length + sector_size - 1) / sector_size * sector_size
in
Cstruct.create sectors in
let*? () =
write block tar.starting_lba [ zeroes ]
in
(* For the OneFFS filesystems we just need to zero out the first sector *)
let zero_sector = Cstruct.create sector_size in
let*? () =
write block git_dump.starting_lba [ zero_sector ]
in
let*? () =
write block md5s.starting_lba [ zero_sector ]
in
write block sha512s.starting_lba [ zero_sector ]
end

File diff suppressed because it is too large Load diff