rust.ml
open Derivation
open Lwt.Syntax
open Yojson.Basic.Util
(* Create a derivation whose build function fetches a crate from a
registry, using the checksum to stay referentially
transparent. Currently only crates.io is supported. *)
let fetch_crate source checksum crate version =
let registry_dl =
if source = "registry+https://github.com/rust-lang/crates.io-index" then
"https://crates.io/api/v1/crates"
else failwith "Not implemented"
in
http ~name:crate
~url:(registry_dl ^ "/" ^ crate ^ "/" ^ version ^ "/download")
~hash_algorithm:Elpegrpc.Elpe.Hash.Sha256
~hash:(Hex.to_bytes (`Hex checksum))
(* Extract a string value from a toml table and a key..*)
let str_from_toml_table k toml =
match Toml.Types.Table.find (Toml.Types.Table.Key.of_string k) toml with
| Toml.Types.TString s -> s
| _ -> raise Not_found
(* Unzip a crate, creating a `.cargo-checksum.json` file at the root,
which is required by Cargo registry replacement. *)
let unzip_checksum pkg hash =
object (self)
inherit std_derivation
method name = "rust-unzip-" ^ pkg#name
method! unpack_phase = Lwt.return ""
method! build_inputs =
Lwt.return (List.map ubuntu [ "coreutils"; "tar"; "gzip"; "findutils" ])
method! build_phase =
let* zipped = self#derivation pkg in
Lwt.return
[%string
{|mkdir -p $DESTDIR
tar -xf %{List.hd zipped.destdir} -C $DESTDIR
cd $DESTDIR/*
echo -n \{\"files\":\{ >.cargo-checksum.json
n=0
for f in $(find . -type f -printf '%P\n'); do
if [[ $n -gt 0 ]]; then
echo -n , >>.cargo-checksum.json
fi
echo -n \"$f\":\"$(sha256sum $f | cut -d" " -f 1)\" >> .cargo-checksum.json
n=$((n+1))
done
echo -n \},\"package\":\"%{hash}\"\} >> .cargo-checksum.json
|}]
method! install_phase = Lwt.return ""
end
let extra_crate_dependencies name version =
match (name, version) with
| "openssl", _ | "openssl-sys", _ ->
[ ubuntu "libssl-dev"; ubuntu "pkg-config" ]
| _ -> []
(* Parse the Cargo.lock file, returning a hash table of all packages
that have a `source` field, i.e. packages that come from a
registry. *)
let parse_cargo_lock destdir =
let lock = Stdlib.open_in (Filename.concat destdir "Cargo.lock") in
let toml =
match Toml.Parser.from_channel lock with
| `Ok toml -> toml
| `Error (err, _) -> failwith ("Error: " ^ err)
in
let packages =
match
Toml.Types.Table.find (Toml.Types.Table.Key.of_string "package") toml
with
| Toml.Types.TArray (Toml.Types.NodeTable arr) -> arr
| _ -> failwith "Unexpected type"
in
let n_packages = ref 0 in
let* packages =
Lwt_list.map_s
(fun pkg ->
try
let source = str_from_toml_table "source" pkg in
let checksum = str_from_toml_table "checksum" pkg in
let name = str_from_toml_table "name" pkg in
let version = str_from_toml_table "version" pkg in
let h = fetch_crate source checksum name version in
let drv = (unzip_checksum h checksum :> derivation) in
let* built = drv#build in
n_packages := !n_packages + 1;
Lwt.return (Some (name, version, source, drv, built))
with Not_found -> Lwt.return None)
packages
in
(* Create a hash table of package id -> derivation of the unzipped
source. *)
let h = Hashtbl.create !n_packages in
List.iter
(fun x ->
match x with
| Some (crate_name, version, source, drv, built) ->
Hashtbl.add h (crate_name, version, source) (drv, built)
| None -> ())
packages;
Lwt.return (h, packages)
(* Run `cargo metadata` in a derivation. This derivation doesn't
produce anything and only forwards the stdandard output of `cargo
metadata`. *)
class metadata rust_version cargo rustc platform src n_packages packages =
object (self)
inherit std_derivation
method name = "metadata"
method! src = Lwt.return src
method! build_phase =
List.iter self#add_path cargo;
List.iter self#add_path rustc;
let platform = " --filter-platform " ^ platform in
let packages =
let h = Hashtbl.create n_packages in
let package_list =
List.fold_left
(fun acc x ->
match x with
| Some (crate_name, version, _, _, built) ->
let target =
if Hashtbl.find_opt h crate_name = None then (
Hashtbl.add h crate_name ();
crate_name)
else crate_name ^ "-" ^ version
in
List.iter self#add_path built.destdir;
[
"ln -s ";
List.hd built.destdir;
"/";
crate_name;
"-";
version;
" vendor/";
target;
"\n";
]
@ acc
| None -> acc)
[] packages
in
String.concat "" package_list
in
let setup =
[%string
{|export HOME=/home/me
mkdir -p $HOME
export PATH=%{List.hd rustc}/usr/lib/rust-%{rust_version}/bin:%{List.hd cargo}/usr/lib/rust-%{rust_version}/bin:$PATH
mkdir -p vendor .cargo
%{packages}
cat <<EOF >> .cargo/config.toml
[source.crates-io]
replace-with = "vendored-sources"
[source.vendored-sources]
directory = "vendor"
EOF
cargo metadata --offline --format-version 1 %{platform}
|}]
in
Lwt.return setup
method! build_inputs = Lwt.return [ ubuntu "coreutils" ]
end
let underscorize = String.map (fun c -> if c = '-' then '_' else c)
type deps = {
build_dependencies : (string * string * string * bool * build_result) list;
dependencies : (string * string * string * bool * build_result) list;
transitive_build_dependencies : (string, build_result) Hashtbl.t;
transitive_dependencies : (string, build_result) Hashtbl.t;
}
(* A derivation building a crate, created from the crate's resolved
parameters. *)
class compiled_crate ~rust_version ~rustc ~cc ~host ~target ~package ~path
~dependencies ~features ~opt_level ~is_top_level ~extra_crate_dependencies =
let package_deps =
let d = package |> member "dependencies" |> to_list in
let h = Hashtbl.create (List.length d) in
List.iter (fun d -> Hashtbl.add h (d |> member "name" |> to_string) d) d;
h
in
object (self)
inherit std_derivation as super
method name = package |> member "name" |> to_string
method version = package |> member "version" |> to_string
method description =
try package |> member "description" |> to_string with _ -> ""
method semantic_version = Semantic_versions.of_string self#version
method! src = Lwt.return path
method targets = package |> member "targets" |> to_list
method lib_name =
try
Some
(List.find
(fun x ->
let kind = x |> member "kind" |> to_list |> filter_string in
kind = [ "lib" ] || kind = [ "proc-macro" ])
self#targets
|> member "name" |> to_string)
with Not_found -> None
(* Ubuntu installs Rust in a convoluted path with wrapper
scripts. *)
method! setup =
List.iter self#add_path rustc;
let* s = super#setup in
let* deps = self#dependencies in
let dependencies =
String.concat " "
(List.map
(fun (_, _, _, _, r) -> List.hd r.destdir)
deps.dependencies)
in
let build_dependencies =
String.concat " "
(List.map
(fun (_, _, _, _, r) -> List.hd r.destdir)
deps.build_dependencies)
in
Lwt.return
[%string
{|%{s}
export CC_ENABLE_DEBUG_OUTPUT=1
export CC=$(command -v clang)
for i in %{dependencies} %{build_dependencies}; do
if [[ -s $i/lib/env ]]; then
echo "sourcing env"
source $i/lib/env
fi
done
export HOME=/home/me
mkdir -p $HOME
export PATH=%{List.hd rustc}/usr/lib/rust-%{rust_version}/bin:$PATH
|}]
(* Rustc has the option of generating extra filenames to
disambiguate things. We keep track of these in the `hash`
parameter of built derivations. *)
val hash =
let id = package |> member "id" |> to_string in
let f =
List.fold_left
(fun acc x -> [%string {|%{acc} --cfg 'feature="%{x}"'|}])
"" features
in
String.sub
(Digest.BLAKE128.to_hex
(Digest.BLAKE128.string (rust_version ^ "\000" ^ id ^ "\000" ^ f)))
0 16
method hash = hash
(* If this src_path comes from a vendored directory (i.e. if it's
a dependency), remove the "vendor" prefix. *)
method private strip_src_path src_path =
let prefix = "/src/vendor/" ^ self#name ^ "-" ^ self#version ^ "/" in
if String.starts_with ~prefix src_path then
String.sub src_path (String.length prefix)
(String.length src_path - String.length prefix)
else
let prefix_ = "/src/vendor/" ^ self#name ^ "/" in
if String.starts_with ~prefix:prefix_ src_path then
String.sub src_path (String.length prefix_)
(String.length src_path - String.length prefix_)
else src_path
(* Concatenation of `--cfg feature=…`. *)
val features_args =
List.fold_left
(fun acc x -> acc ^ " --cfg 'feature=\"" ^ x ^ "\"'")
"" features
method private compile_target setup target build_target kind
transitive_dependencies dependencies out =
let initial_src_path = build_target |> member "src_path" |> to_string in
let src_path = self#strip_src_path initial_src_path in
let name = build_target |> member "name" |> to_string in
let under = underscorize name in
let edition =
try
" --edition=" ^ (build_target |> member "edition" |> to_string) ^ " "
with Not_found -> (
try " --edition=" ^ (package |> member "edition" |> to_string) ^ " "
with Not_found -> " ")
in
(* rustc wants a single (or few) `-L dependency=` flag, else it
seems to ignore some of them. That's why we copy deps and
transitive deps to target/deps. *)
let dependencies_str, target_deps =
List.fold_left
(fun (acc_extern, acc_ln) (rename, lib_name, h, is_proc_macro, b) ->
let acc_extern =
acc_extern ^ " --extern " ^ underscorize rename
^ "=target/deps/lib" ^ underscorize lib_name ^ "-" ^ h
^ if is_proc_macro then ".so" else ".rlib"
in
let acc_ln =
acc_ln ^ "ln -sf " ^ List.hd b.destdir ^ "/lib/* target/deps\n"
in
(acc_extern, acc_ln))
("", "mkdir -p target/deps\n")
dependencies
in
let target_deps =
Hashtbl.fold
(fun _ v acc ->
acc ^ "ln -sf " ^ List.hd v.destdir ^ "/lib/* target/deps\n")
transitive_dependencies target_deps
in
let target = " --target " ^ Platform.triple target in
if kind = "bin" then
let local =
match self#lib_name with
| Some l ->
"--extern " ^ underscorize l ^ "=$DESTDIR/lib/lib"
^ underscorize l ^ "-" ^ self#hash ^ ".rlib"
| None -> ""
in
setup :=
[%string
{|
set -xe
%{!setup}
mkdir -p target %{out} $DESTDIR
touch target/rustc.opt
RUSTC_FLAGS=$(cat target/rustc.opt)
find $DESTDIR
%{target_deps}
rustc --crate-name %{under} %{edition} %{src_path} %{target} --crate-type bin --emit=link -C linker=gcc $RUSTC_FLAGS %{features_args} -C metadata=%{hash}-bin --out-dir %{out} %{dependencies_str} %{local} -L dependency=target/deps --cap-lints allow
|}]
else
setup :=
[%string
{|
set -xe
%{!setup}
mkdir -p target %{out}
touch target/rustc.opt
RUSTC_FLAGS=$(cat target/rustc.opt)
%{target_deps}
rustc --crate-name %{under} %{edition} %{src_path} --crate-type %{kind} %{target} --emit=link -C linker=gcc -C embed-bitcode=no -C debuginfo=2 $RUSTC_FLAGS %{if kind = "proc-macro" then " -C prefer-dynamic" else ""} %{features_args} -C metadata=%{hash} --out-dir %{out} -C extra-filename=-%{hash} %{dependencies_str} %{if kind = "proc-macro" then " --extern proc_macro" else ""} -L dependency=target/deps --cap-lints allow
|}];
under
val accumulated_deps : (string, compiled_crate) Hashtbl.t option ref =
ref None
method accumulated_deps =
match !accumulated_deps with
| Some acc -> Lwt.return acc
| None ->
let h = Hashtbl.create 256 in
let* _ =
Lwt_list.iter_s
(fun d ->
let dd = Hashtbl.find package_deps d#name in
let is_build =
dd |> member "kind" |> to_option to_string = Some "build"
in
Hashtbl.add h d#hash d;
let* acc = d#accumulated_deps in
Lwt.return
(if not is_build then
Hashtbl.iter (fun k v -> Hashtbl.add h k v) acc
else ()))
dependencies
in
accumulated_deps := Some h;
Lwt.return h
(* The `dependencies` method below computes the build and regular
dependencies in one go, caching them in the
`computed_dependencies` value. *)
val computed_dependencies = ref None
method private dependencies =
match !computed_dependencies with
| Some d -> Lwt.return d
| None ->
let de = ref [] in
let h = Hashtbl.create 256 in
let build_h = Hashtbl.create 256 in
let build_de = ref [] in
let* deps =
Lwt_list.map_s
(fun x ->
let* b = x#build in
Lwt.return (x, x#name, x#hash, b))
dependencies
in
let* _ =
Lwt_list.iter_s
(fun (x, x_name, x_hash, b) ->
let x_lib_name = Option.get x#lib_name in
let d = Hashtbl.find package_deps x_name in
let is_build =
d |> member "kind" |> to_option to_string = Some "build"
in
List.iter self#add_path b.destdir;
let name =
match d |> member "rename" |> to_option to_string with
| Some rename -> rename
| None -> x_name
in
let r, h = if is_build then (build_de, build_h) else (de, h) in
let* acc = x#accumulated_deps in
let* _ =
Hashtbl.fold
(fun name v acc ->
if Hashtbl.find_opt h name = None then (
let* _ = acc in
let* b = v#build in
List.iter self#add_path b.destdir;
Hashtbl.add h name b;
Lwt.return ())
else Lwt.return ())
acc (Lwt.return ())
in
let is_proc_macro =
List.exists
(fun t ->
List.exists
(fun k -> k = "proc-macro")
(t |> member "kind" |> to_list |> filter_string))
x#targets
in
r := (name, x_lib_name, x_hash, is_proc_macro, b) :: !r;
Lwt.return ())
deps
in
let result =
{
build_dependencies = !build_de;
transitive_build_dependencies = build_h;
dependencies = !de;
transitive_dependencies = h;
}
in
computed_dependencies := Some result;
Lwt.return result
method extra_deps =
List.fold_left
(fun acc dep ->
let* acc = acc in
let* extra = dep#extra_deps in
Lwt.return (extra @ acc))
(Lwt.return (extra_crate_dependencies self#name self#version))
dependencies
method! build_inputs =
let* extra = self#extra_deps in
Lwt.return
([
ubuntu "coreutils";
ubuntu "sed";
ubuntu "gcc";
ubuntu "clang";
ubuntu "libc6-dev";
ubuntu "grep";
ubuntu "gawk";
ubuntu "findutils";
cc;
]
@ extra)
(* Run the build script, if any. Also `cd` to the correct
directory. *)
method! configure_phase =
let setup =
ref
("mkdir -p target/build-" ^ hash
^ "\nexport RUSTC=rustc\ntouch target/rustc.opt\n")
in
let has_source =
try
let _ = package |> member "source" |> to_string in
true
with Not_found | Yojson.Basic.Util.Type_error _ -> false
in
let links =
try Some (package |> member "links" |> to_string)
with Not_found | Yojson.Basic.Util.Type_error _ -> None
in
let* d = self#dependencies in
let v0, v1, v2, v4 = self#semantic_version in
let name = self#name in
let version = self#version in
let description =
Str.global_replace
(Str.regexp "\"\\|`\\|\\$\\|\\")
"\\\\\\0" self#description
in
(* The following fold does two things in one pass: *)
setup :=
!setup
^ [%string
{|
export OUT_DIR=$DESTDIR/lib
export CC_ENABLE_DEBUG_OUTPUT=1
export CARGO_PKG_VERSION="%{version}"
export CARGO_PKG_NAME="%{name}"
export CARGO_PKG_DESCRIPTION="%{description}"
export CARGO_PKG_VERSION_MAJOR=%{v0#Int}
export CARGO_PKG_VERSION_MINOR=%{v1#Int}
export CARGO_PKG_VERSION_PATCH=%{v2#Int}
export CARGO_PKG_VERSION_PRE=%{Option.value v4 ~default:""}
export CARGO_MANIFEST_DIR=$(pwd)/%{name}-%{version}
export CARGO_MANIFEST_LINKS=%{Option.value links ~default: ""}
export TARGET="%{Platform.triple target}"
export HOST="%{Platform.triple host}"
export OPT_LEVEL=%{opt_level}
export CARGO_CFG_UNIX=1
export CARGO_CFG_TARGET_ABI=""
export CARGO_CFG_TARGET_OS=linux
export CARGO_CFG_TARGET_ENDIAN="%{Platform.string_of_endianness (Platform.endianness target)}"
export CARGO_CFG_TARGET_POINTER_WIDTH=%{(Platform.pointer_width target)#Int}
export CARGO_CFG_TARGET_ENV="%{Platform.env target}"
export CARGO_CFG_TARGET_ARCH="%{Platform.string_of_arch target.arch}"
|}];
let _, build_script =
List.fold_left
(fun (is_first_target, build_script) target ->
if is_first_target && has_source then
setup := !setup ^ "cd " ^ self#name ^ "-" ^ self#version ^ "\n"
else ();
(* The other task is to add the build script if there is
one, and return its name. *)
( false,
List.fold_left
(fun has_it kind ->
match kind with
| "custom-build" ->
Some
(self#compile_target setup host target "bin"
d.transitive_build_dependencies d.build_dependencies
("target/build-" ^ hash))
| _ -> has_it)
build_script
(target |> member "kind" |> to_list |> filter_string) ))
(true, None) self#targets
in
setup := !setup ^ "mkdir -p $OUT_DIR || true\n";
let _ =
match build_script with
| Some bs_name ->
setup :=
!setup
^ [%string
{|CRATENAME=$(echo %{name} | sed -e "s/\(.*\)-sys$/\U\1/" -e "s/-/_/g")
CRATEVERSION=$(echo %{version} | sed -e "s/[\.\+-]/_/g")
echo Running build script for %{name}-%{version}
|}]
^ String.trim [%blob "run_build_script.sh"]
^ [%string "<<< $(target/build-%{hash}/%{bs_name})\n"]
| None -> ()
in
Lwt.return !setup
(* Run the main build command and install the results at the same
time. *)
method! build_phase =
let* d = self#dependencies in
let setup = ref "" in
let has_bin = ref false in
let has_lib = ref false in
List.iter
(fun build_target ->
List.iter
(fun kind ->
if kind = "bin" then if !has_bin then () else has_bin := true
else if !has_lib then ()
else has_lib := true;
match kind with
| "lib" | "rlib" | "dylib" | "cdylib" | "staticlib" | "proc-macro"
->
let _ =
self#compile_target setup target build_target kind
d.transitive_dependencies d.dependencies "$DESTDIR/lib"
in
()
| "bin" ->
if is_top_level then
let _ =
self#compile_target setup target build_target kind
d.transitive_dependencies d.dependencies "$DESTDIR/bin"
in
()
else ()
| _ -> ())
(build_target |> member "kind" |> to_list |> filter_string))
self#targets;
Lwt.return !setup
method! install_phase =
Lwt.return
{|
if [[ -s target/env ]]; then
mkdir -p $DESTDIR/lib
cp target/env $DESTDIR/lib
fi
|}
end
let rec dfs nodes seen result n =
match Hashtbl.find_opt seen n with
| Some () -> result
| None ->
let _ = Hashtbl.add seen n () in
let node = Hashtbl.find nodes n in
let deps = node |> member "dependencies" |> to_list |> filter_string in
let result = List.fold_left (dfs nodes seen) result deps in
node :: result
let topo_sort n_nodes nodes =
let h = Hashtbl.create n_nodes in
let nodes_list =
List.fold_left
(fun list node ->
let id = node |> member "id" |> to_string in
Hashtbl.add h id node;
id :: list)
[] nodes
in
let seen = Hashtbl.create n_nodes in
List.fold_left (dfs h seen) [] nodes_list
let rust ?(rust_version = "1.84") ?(target = !Platform.target)
?(host = !Platform.host)
?(extra_crate_dependencies = extra_crate_dependencies) src =
let* src_built = src#build in
let* packages_drv, packages = parse_cargo_lock (List.hd src_built.destdir) in
let n_packages = Hashtbl.length packages_drv in
let* rustc = (ubuntu ("rustc-" ^ rust_version))#build in
let rustc = rustc.destdir in
let* cargo = (ubuntu ("cargo-" ^ rust_version))#build in
let cargo = cargo.destdir in
let metadata =
new metadata
rust_version cargo rustc (Platform.triple target) src n_packages packages
in
let buf = metadata#set_stdout in
let* _ = metadata#build in
let meta_json = Yojson.Basic.from_string (Buffer.contents buf) in
let resolved = Hashtbl.create n_packages in
let nodes = meta_json |> member "resolve" |> member "nodes" |> to_list in
let packages_meta = Hashtbl.create n_packages in
List.iter
(fun pkg -> Hashtbl.add packages_meta (pkg |> member "id" |> to_string) pkg)
(meta_json |> member "packages" |> to_list);
let workspace_members =
meta_json |> member "workspace_members" |> to_list |> filter_string
in
List.iter
(fun node ->
let id = node |> member "id" |> to_string in
let meta = Hashtbl.find packages_meta id in
let name = meta |> member "name" |> to_string in
let version = meta |> member "version" |> to_string in
let drv =
try
let drv, _ =
Hashtbl.find packages_drv
(name, version, meta |> member "source" |> to_string)
in
drv
with Not_found | Yojson.Basic.Util.Type_error _ -> src
in
let dependencies =
List.map
(fun dep -> Hashtbl.find resolved dep)
(node |> member "dependencies" |> to_list |> filter_string)
in
let features = node |> member "features" |> to_list |> filter_string in
let is_top_level = List.exists (fun w -> w = id) workspace_members in
let cc = (cc Clang :> derivation) in
let compiled =
new compiled_crate
~rust_version ~rustc ~cc ~target ~host ~package:meta ~path:drv
~extra_crate_dependencies ~dependencies ~features ~opt_level:"3"
~is_top_level
in
Hashtbl.add resolved id compiled)
(List.rev (topo_sort n_packages nodes));
Lwt.return (List.map (Hashtbl.find resolved) workspace_members)