Compare commits
2 commits
| Author | SHA1 | Date | |
|---|---|---|---|
| 378104c642 | |||
| 0c6482eb70 |
9 changed files with 1193 additions and 1211 deletions
|
|
@ -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))
|
|
||||||
195
mirage/bad.ml
Normal file
195
mirage/bad.ml
Normal file
|
|
@ -0,0 +1,195 @@
|
||||||
|
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";
|
||||||
|
"https://github.com/sanette/oplot/archive/0.7.tar.gz";
|
||||||
|
"https://github.com/ulrikstrid/ocaml-cookie/releases/download/0.1.8/session-cookie-lwt-0.1.8.tbz";
|
||||||
|
]
|
||||||
|
|
||||||
|
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
|
||||||
107
mirage/config.ml
107
mirage/config.ml
|
|
@ -1,40 +1,111 @@
|
||||||
(* mirage >= 4.8.0 & < 4.9.0 *)
|
|
||||||
open Mirage
|
open Mirage
|
||||||
|
|
||||||
|
let check =
|
||||||
|
let doc =
|
||||||
|
Key.Arg.info ~doc:"Only check the cache" ["check"]
|
||||||
|
in
|
||||||
|
Key.(create "check" Arg.(flag doc))
|
||||||
|
|
||||||
|
let verify_sha256 =
|
||||||
|
let doc =
|
||||||
|
Key.Arg.info ~doc:"Verify the SHA256 checksums of the cache contents, and \
|
||||||
|
re-build the other checksum caches."
|
||||||
|
["verify-sha256"]
|
||||||
|
in
|
||||||
|
Key.(create "verify-sha256" Arg.(flag doc))
|
||||||
|
|
||||||
|
let remote =
|
||||||
|
let doc =
|
||||||
|
Key.Arg.info
|
||||||
|
~doc:"Remote repository url, use suffix #foo to specify a branch 'foo': \
|
||||||
|
https://github.com/ocaml/opam-repository.git"
|
||||||
|
["remote"]
|
||||||
|
in
|
||||||
|
Key.(create "remote" Arg.(opt string "https://github.com/ocaml/opam-repository.git#master" 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 git 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 sectors_git =
|
||||||
|
let doc = "Number of sectors reserved for git dump." in
|
||||||
|
let doc = Key.Arg.info ~doc ["sectors-git"] in
|
||||||
|
Key.(create "sectors-git" Arg.(opt int64 Int64.(mul 40L (mul 2L 1024L)) doc))
|
||||||
|
|
||||||
|
let ignore_local_git =
|
||||||
|
let doc = "Ignore restoring locally saved git repository." in
|
||||||
|
let doc = Key.Arg.info ~doc ["ignore-local-git"] in
|
||||||
|
Key.(create "ignore-local-git" Arg.(flag doc))
|
||||||
|
|
||||||
let mirror =
|
let mirror =
|
||||||
main "Unikernel.Make"
|
foreign "Unikernel.Make"
|
||||||
|
~keys:[ Key.v check ; Key.v verify_sha256 ; Key.v remote ;
|
||||||
|
Key.v parallel_downloads ; Key.v hook_url ; Key.v tls_authenticator ;
|
||||||
|
Key.v port ; Key.v sectors_cache ; Key.v sectors_git ;
|
||||||
|
Key.v ignore_local_git ;
|
||||||
|
]
|
||||||
~packages:[
|
~packages:[
|
||||||
package ~min:"0.3.0" ~sublibs:[ "mirage" ] "paf" ;
|
package ~min:"0.3.0" ~sublibs:[ "mirage" ] "paf" ;
|
||||||
package "h2" ;
|
package "h2" ;
|
||||||
package "ohex" ;
|
package "hex" ;
|
||||||
package "httpaf" ;
|
package "httpaf" ;
|
||||||
package ~min:"0.1.1" "git-kv" ;
|
package "git-kv" ;
|
||||||
package ~min:"3.10.0" "git-paf" ;
|
package ~min:"3.10.0" "git-paf" ;
|
||||||
package "opam-file-format" ;
|
package "opam-file-format" ;
|
||||||
package ~min:"3.0.0" ~sublibs:[ "gz" ] "tar" ;
|
package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ;
|
||||||
package ~min:"3.0.0" "tar-mirage" ;
|
package ~min:"2.2.0" "tar-mirage" ;
|
||||||
package ~max:"0.2.0" "mirage-block-partition" ;
|
package ~max:"0.2.0" "mirage-block-partition" ;
|
||||||
package ~min:"0.0.8" "http-mirage-client" ;
|
|
||||||
package "gpt" ;
|
package "gpt" ;
|
||||||
package "gptar" ;
|
package "gptar" ~pin:"git+https://github.com/reynir/gptar.git" ;
|
||||||
package "oneffs" ;
|
package "oneffs" ;
|
||||||
package "digestif" ;
|
|
||||||
package "swapfs" ;
|
|
||||||
]
|
]
|
||||||
(block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job)
|
(block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job)
|
||||||
|
|
||||||
let stack = generic_stackv4v6 default_network
|
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 tcp = tcpv4v6_of_stackv4v6 stack
|
||||||
let block = block_of_file "tar"
|
|
||||||
|
|
||||||
let git_client, alpn_client =
|
let git_client, alpn_client =
|
||||||
let git = mimic_happy_eyeballs stack he dns in
|
let happy_eyeballs = generic_happy_eyeballs stack dns in
|
||||||
merge_git_clients (git_ssh tcp git)
|
let git = mimic_happy_eyeballs stack dns happy_eyeballs in
|
||||||
(merge_git_clients (git_tcp tcp git)
|
merge_git_clients (git_tcp tcp git)
|
||||||
(git_http tcp git)),
|
(git_http ~authenticator:tls_authenticator tcp git),
|
||||||
paf_client tcp (mimic_happy_eyeballs stack he dns)
|
paf_client ~pclock:default_posix_clock tcp (mimic_happy_eyeballs stack dns 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 () = register "mirror"
|
let () = register "mirror"
|
||||||
[ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ alpn_client ]
|
[ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ alpn_client ]
|
||||||
|
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
1386
mirage/unikernel.ml
1386
mirage/unikernel.ml
File diff suppressed because it is too large
Load diff
3
mkimg/bin/dune
Normal file
3
mkimg/bin/dune
Normal file
|
|
@ -0,0 +1,3 @@
|
||||||
|
(executable
|
||||||
|
(name mkimg)
|
||||||
|
(libraries unix cstruct gptar gpt uuidm cmdliner))
|
||||||
148
mkimg/bin/mkimg.ml
Normal file
148
mkimg/bin/mkimg.ml
Normal file
|
|
@ -0,0 +1,148 @@
|
||||||
|
(* 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 gptutf16be_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 jump dest sector_size size_sectors sectors_cache sectors_git =
|
||||||
|
let ( let* ) = Result.bind in
|
||||||
|
let* () =
|
||||||
|
if sector_size < 0 then Error "negative sector size"
|
||||||
|
else if size_sectors < 0L then Error "negative size"
|
||||||
|
else if sectors_cache < 0L then Error "negative cache size"
|
||||||
|
else if sectors_git < 0L then Error "negative git dump size"
|
||||||
|
else Ok ()
|
||||||
|
in
|
||||||
|
let* () =
|
||||||
|
if sector_size >= 512 && sector_size land (pred sector_size) == 0 then
|
||||||
|
Ok ()
|
||||||
|
else Error "sector size must be a power of two greater than or equal 512"
|
||||||
|
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* () =
|
||||||
|
let ( + ) = Int64.add in
|
||||||
|
if size_sectors <
|
||||||
|
(* protective MBR + GPT header + GPT table *)
|
||||||
|
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
|
||||||
|
Error "too small size"
|
||||||
|
else Ok ()
|
||||||
|
in
|
||||||
|
(* TODO: handle exceptions *)
|
||||||
|
let fd = Unix.openfile dest Unix.[ O_WRONLY; O_CREAT ] 0o664 in
|
||||||
|
Unix.ftruncate fd (sector_size * Int64.to_int size_sectors);
|
||||||
|
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:(gptutf16be_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:(gptutf16be_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:(gptutf16be_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:(gptutf16be_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;
|
||||||
|
let s = Cstruct.to_string buf in
|
||||||
|
ignore (Unix.write_substring fd s 0 (String.length s));
|
||||||
|
ignore (Unix.lseek fd (Int64.to_int gpt.backup_lba * sector_size) Unix.SEEK_SET);
|
||||||
|
(* Let's reuse the buffer *)
|
||||||
|
let buf = Cstruct.sub buf 0 sector_size in
|
||||||
|
Cstruct.memset buf 0;
|
||||||
|
Gpt.marshal_header ~sector_size ~primary:false buf gpt;
|
||||||
|
let s = Cstruct.to_string buf in
|
||||||
|
ignore (Unix.write_substring fd s 0 (String.length s));
|
||||||
|
Unix.close fd;
|
||||||
|
Ok ()
|
||||||
|
|
||||||
|
open Cmdliner
|
||||||
|
|
||||||
|
let dest =
|
||||||
|
Arg.(required & pos 0 (some string) None &
|
||||||
|
info ~docv:"DEST" [])
|
||||||
|
|
||||||
|
let sector_size =
|
||||||
|
let doc = "Sector size or block size to use" in
|
||||||
|
(* TODO: should be a power of two >= 512 *)
|
||||||
|
Arg.(value & opt int 512 &
|
||||||
|
info ~doc ~docv:"SECTOR-SIZE" ["sector-size"])
|
||||||
|
|
||||||
|
let size_sectors =
|
||||||
|
let doc = "Size of disk image in terms of sectors" in
|
||||||
|
Arg.(value & opt int64 (Int64.mul 1024L 2048L) &
|
||||||
|
info ~doc ~docv:"SIZE-SECTORS" ["size-sectors"])
|
||||||
|
|
||||||
|
let sectors_cache =
|
||||||
|
let doc = "Number of sectors reserved for each checksum cache (md5, sha512)." in
|
||||||
|
Arg.(value & opt int64 (Int64.mul 4L 2048L) &
|
||||||
|
info ~doc ~docv:"SECTORS-CACHE" ["sectors-cache"])
|
||||||
|
|
||||||
|
let sectors_git =
|
||||||
|
let doc = "Number of sectors reserved for git dump." in
|
||||||
|
Arg.(value & opt int64 (Int64.mul 40L 2048L) &
|
||||||
|
info ~doc ~docv:"SECTORS-GIT" ["sectors-git"])
|
||||||
|
|
||||||
|
let command =
|
||||||
|
let info =
|
||||||
|
Cmd.info "mkimg"
|
||||||
|
in
|
||||||
|
Cmd.v info
|
||||||
|
Term.(const jump $ dest $ sector_size $ size_sectors $ sectors_cache $ sectors_git)
|
||||||
|
|
||||||
|
let () =
|
||||||
|
exit (Cmdliner.Cmd.eval_result command)
|
||||||
2
mkimg/dune-project
Normal file
2
mkimg/dune-project
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
(lang dune 3.14)
|
||||||
|
(name mkimg)
|
||||||
Loading…
Reference in a new issue