(* 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. *)

(* Extract a string value from a toml table and a key..*)

let unzip pkg =

(* Unzip a crate, creating a `.cargo-checksum.json` file at the root,
   which is required by Cargo registry replacement. *)
let unzip_checksum pkg hash =

      Lwt.return
        [
          (ubuntu "libc6-dev" :> derivation);
          (ubuntu "coreutils" :> derivation);
          (ubuntu "tar" :> derivation);
          (ubuntu "gzip" :> derivation);
        ]

      Lwt.return (List.map ubuntu [ "coreutils"; "tar"; "gzip"; "findutils" ])

        ("mkdir -p $DESTDIR; tar -xf " ^ List.hd zipped.destdir ^ " -C $DESTDIR")

        ("mkdir -p $DESTDIR; tar -xf " ^ List.hd zipped.destdir
       ^ " -C $DESTDIR; cd $DESTDIR/*; echo -n \\{\\\"files\\\":\\{ \
          >.cargo-checksum.json\n\
          n=0\n\
          for f in $(find . -type f -printf '%P\\n'); do\n\
          if [[ $n -gt 0 ]]; then\n\
          echo -n , >>.cargo-checksum.json\n\
          fi\n\
          echo -n \\\"$f\\\":\\\"$(sha256sum $f | cut -d\" \" -f 1)\\\" >> \
          .cargo-checksum.json;\n\
          n=$((n+1))\n\
          done\n\
          echo -n \\},\\\"package\\\":\\\"" ^ hash
       ^ "\\\"\\} >> .cargo-checksum.json")

let packages toml =

(* 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 drv = (unzip h :> derivation) in

             let drv = (unzip_checksum h checksum :> derivation) in

let metadata rust_version cargo rustc platform src n_packages 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 =

    method name = "test"

    method name = "metadata"

                  if Hashtbl.find_opt h crate_name = None then
                    crate_name ^ "-" ^ version
                  else crate_name

                  if Hashtbl.find_opt h crate_name = None then (
                    Hashtbl.add h crate_name ();
                    crate_name)
                  else crate_name ^ "-" ^ version

                List.iter self#add_path built.destdir;

    method! build_inputs = Lwt.return [ (ubuntu "coreutils" :> derivation) ]

    method! build_inputs = Lwt.return [ ubuntu "coreutils" ]

let compile_crate rust_version rustc platform package path deps features =
  let target_platform = "x86_64-unknown-linux-gnu" in

let underscorize = String.map (fun c -> if c = '-' then '_' else c)
type deps = { build_dependencies : string; dependencies : string }
(* A derivation building a crate, created from the crate's resolved
   parameters.  *)
class compiled_crate rust_version rustc cc platform package path deps features =

    inherit std_derivation

    inherit std_derivation as super

    method version = package |> member "version" |> to_string

    val target_platform = platform

    method! post_setup =

    (* Ubuntu installs Rust in a convoluted path with wrapper
       scripts. *)
    method! setup =

      let* s = super#setup in

        ("export HOME=/home/me\nmkdir -p $HOME\nexport PATH=" ^ List.hd rustc
       ^ "/usr/lib/rust-" ^ rust_version ^ "/bin:$PATH\n")

        (s ^ "export HOME=/home/me\nmkdir -p $HOME\nexport PATH="
       ^ List.hd rustc ^ "/usr/lib/rust-" ^ rust_version ^ "/bin:$PATH\n")

    method! build_phase =
      let platform =
        match platform with Some s -> " --filter-platform " ^ s | None -> ""
      in
      let features =
        String.concat ", " (List.map (fun x -> "\"" ^ x ^ "\"") features)

    (* 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 -> acc ^ " --cfg 'feature=\"" ^ x ^ "\"'")
          "" features

      String.sub
        (Digest.BLAKE128.to_hex
           (Digest.BLAKE128.string (rust_version ^ "\000" ^ id ^ "\000" ^ f)))
        0 16

      let setup = ref "set -x\nrustc --print sysroot\n" in
      let dependencies = "" in
      let compile_target target kind =
        let src_path = target |> member "src_path" |> to_string in
        let name = target |> member "name" |> to_string in
        let edition =
          try " --edition=" ^ (target |> member "edition" |> to_string) ^ " "
          with Not_found -> (
            try " --edition=" ^ (package |> member "edition" |> to_string) ^ " "
            with Not_found -> " ")
        in

    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 platform target kind dependencies out =
      let initial_src_path = target |> member "src_path" |> to_string in
      let src_path = self#strip_src_path initial_src_path in
      let name = target |> member "name" |> to_string in
      let under = underscorize name in
      let edition =
        try " --edition=" ^ (target |> member "edition" |> to_string) ^ " "
        with Not_found -> (
          try " --edition=" ^ (package |> member "edition" |> to_string) ^ " "
          with Not_found -> " ")
      in
      let platform =
        match platform with Some p -> " --target " ^ p | None -> ""
      in
      if kind = "bin" then

          !setup ^ "rustc --crate-name " ^ name ^ edition ^ src_path
          ^ " --crate-type " ^ kind
          ^ " --emit=dep-info,metadata,link -C embed-bitcode=no -C debuginfo=2 \
             --cfg 'feature=\"cargo-build \"' --cfg 'feature=\"default\"' \
             --check-cfg 'cfg(docsrs,test)' --check-cfg 'cfg(feature, values("
          ^ features
          ^ "))' -C metadata=db5f6b051938318f -C \
             extra-filename=-99d0a40c2aab0586 --out-dir $DESTDIR/lib "
          ^ dependencies ^ " --cap-lints allow\n"

          !setup ^ "rustc --crate-name " ^ under ^ edition ^ src_path ^ platform
          ^ " --crate-type bin -C linker=gcc" ^ features_args ^ " -C metadata="
          ^ hash ^ " --out-dir " ^ out ^ dependencies ^ " --cap-lints allow\n"
      else
        setup :=
          !setup ^ "rustc --crate-name " ^ under ^ edition ^ src_path
          ^ " --crate-type " ^ kind ^ platform
          ^ " --emit=dep-info,metadata,link -C embed-bitcode=no -C debuginfo=2"
          ^ features_args ^ " -C metadata=" ^ hash ^ " --out-dir " ^ out
          ^ " -C extra-filename=-" ^ hash ^ dependencies
          ^ " --cap-lints allow\n";
      under
    (* 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 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
          let de = ref "" in
          let build_de = ref "" in
          let* deps =
            Lwt_list.map_p
              (fun x ->
                let* b = x#build in
                Lwt.return (x#name, x#hash, b))
              deps
          in
          List.iter
            (fun (x_name, x_hash, b) ->
              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 = if is_build then build_de else de in
              r :=
                !r ^ " -L dependency=target/deps --extern " ^ name ^ "="
                ^ List.hd b.destdir ^ "/lib/lib" ^ x_name ^ "-" ^ x_hash
                ^ ".rlib")
            deps;
          let result = { build_dependencies = !build_de; dependencies = !de } in
          computed_dependencies := Some result;
          Lwt.return result
    method! build_inputs = Lwt.return [ ubuntu "coreutils"; cc ]
    (* Run the build script, if any. Also `cd` to the correct
       directory. *)
    method! configure_phase =
      let setup =
        ref ("set -x\nmkdir -p target/build-" ^ hash ^ "\nexport RUSTC=rustc\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* d = self#dependencies in
      (* The following fold does two things in one pass: *)
      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 None target "bin"
                           d.build_dependencies ("target/build-" ^ hash))
                  | _ -> has_it)
                build_script
                (target |> member "kind" |> to_list |> filter_string) ))
          (true, None)
          (package |> member "targets" |> to_list)
      in
      (* If there is a build script, call it. *)
      let _ =
        match build_script with
        | Some bs_name ->
            setup := !setup ^ "target/build-" ^ hash ^ "/" ^ bs_name ^ "\n"
        | None -> ()

      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

              if kind = "bin" then
                if !has_bin then ()
                else (
                  has_bin := true;
                  setup := !setup ^ "mkdir -p $DESTDIR/bin\n")
              else if !has_lib then ()
              else (
                has_lib := true;
                setup := !setup ^ "mkdir -p $DESTDIR/lib\n");

                ->
                  let _ =
                    self#compile_target setup target_platform target kind
                      d.dependencies "$DESTDIR/lib"
                  in
                  ()

                  compile_target target kind

                  let _ =
                    self#compile_target setup target_platform target kind
                      d.dependencies "$DESTDIR/bin"
                  in
                  ()

    method! build_inputs = Lwt.return [ (ubuntu "coreutils" :> derivation) ]

let rust ?(rust_version = "1.84") ?(platform = None) ?(crate = None) src =

let rust ?(rust_version = "1.84") ?(platform = None) src =

  let lock =
    Stdlib.open_in (Filename.concat (List.hd src_built.destdir) "Cargo.lock")
  in
  let parsed =
    match Toml.Parser.from_channel lock with
    | `Ok toml -> toml
    | `Error (err, _) -> failwith ("Error: " ^ err)
  in
  let* packages_drv, packages = packages parsed in

  let* packages_drv, packages = parse_cargo_lock (List.hd src_built.destdir) in

  let cc = ubuntu "build-essential" in

    metadata rust_version cargo rustc platform src n_packages packages

    new metadata rust_version cargo rustc platform src n_packages packages

      let deps = node |> member "deps" |> to_list in

        compile_crate rust_version rustc platform meta drv deps features

        new compiled_crate
          rust_version rustc cc platform meta drv dependencies features

    val cached_build = ref None
    val build_lock = Lwt_mutex.create ()

      let c =
        match !backend_conn with None -> failwith "no conn" | Some c -> c
      in
      let* index =
        Lwt_list.map_p
          (fun repository ->
            let* res = ubuntu_release c ~release ~arch:Amd64 ~repository in
            let res, _ = Result.get_ok res in
            match res with
            | `Ok r -> Lwt.return r.destdir
            | `Error e -> failwith e
            | _ -> assert false)
          [ "main"; "universe" ]
      in
      let index = List.concat index in
      let* res = ubuntu_package c ~index ~name in
      let res, _ = Result.get_ok res in
      match res with
      | `Ok r -> Lwt.return { destdir = r.destdir; paths = r.paths }
      | `Error e -> failwith e
      | _ -> assert false

      match !cached_build with
      | Some x -> Lwt.return x
      | None ->
          Lwt_mutex.with_lock build_lock (fun () ->
              let c =
                match !backend_conn with
                | None -> failwith "no conn"
                | Some c -> c
              in
              let* index =
                Lwt_list.map_p
                  (fun repository ->
                    let arch =
                      match arch with
                      | Amd64 -> Elpegrpc.Elpe.Arch.Amd64
                      | Aarch64 -> Elpegrpc.Elpe.Arch.Aarch64
                    in
                    let* res = ubuntu_release c ~release ~arch ~repository in
                    let res, _ = Result.get_ok res in
                    match res with
                    | `Ok r -> Lwt.return r.destdir
                    | `Error e -> raise (DerivationError e)
                    | _ -> assert false)
                  [ "main"; "universe" ]
              in
              let index = List.concat index in
              let* res = ubuntu_package c ~index ~name in
              let r = Result.get_ok res in
              let x = { destdir = r.destdir; paths = r.paths } in
              cached_build := Some x;
              Lwt.return x)

      List.fold_right (fun r () -> self#add_path r) path.destdir ();

      List.iter self#add_path path.destdir;

    val post_setup = ""

            extra_paths := p.destdir @ !extra_paths;

      List.iter (List.iter self#add_path) paths;

      let* post_setup = self#post_setup in

    method post_setup = Lwt.return ""
    method pre_unpack = Lwt.return ""
    method post_unpack = Lwt.return ""

    val pre_unpack = ""
    val post_unpack = ""

      extra_paths := src_built.destdir @ !extra_paths;

      List.iter self#add_path src_built.destdir;

      let* all = Lwt.all [ self#pre_unpack; self#post_unpack ] in
      match all with
      | pre :: post :: _ ->
          Lwt.return
            (pre ^ "\ncp -R " ^ List.hd src_built.destdir ^ "/. .\n" ^ post)
      | _ -> assert false

      Lwt.return
        (pre_unpack ^ "\ncp -R " ^ List.hd src_built.destdir ^ "/. .\n"
       ^ post_unpack)

    method pre_configure = Lwt.return ""
    method post_configure = Lwt.return ""

    val pre_configure = ""
    val post_configure = ""

      let* all = Lwt.all [ self#pre_configure; self#post_configure ] in
      match all with
      | pre :: post :: _ ->
          Lwt.return
            (pre ^ "\nif [[ -e configure ]]; then ./configure; fi\n" ^ post)
      | _ -> assert false

      Lwt.return
        (pre_configure ^ "\nif [[ -e configure ]]; then ./configure; fi\n"
       ^ post_configure)

    method pre_build = Lwt.return ""
    method post_build = Lwt.return ""

    val pre_build = ""
    val post_build = ""

      let* all = Lwt.all [ self#pre_build; self#post_build ] in
      match all with
      | pre :: post :: _ ->
          Lwt.return (pre ^ "\nif [[ -e Makefile ]]; then make; fi\n" ^ post)
      | _ -> assert false

      Lwt.return
        (pre_build ^ "\nif [[ -e Makefile ]]; then make; fi\n" ^ post_build)

    method pre_install = Lwt.return ""
    method post_install = Lwt.return ""

    val pre_install = ""
    val post_install = ""

      let* all = Lwt.all [ self#pre_install; self#post_install ] in
      match all with
      | pre :: post :: _ ->
          Lwt.return
            (pre ^ "\nif [[ -e Makefile ]]; then make install; fi\n" ^ post)
      | _ -> assert false

      Lwt.return
        (pre_install ^ "\nif [[ -e Makefile ]]; then make install; fi\n"
       ^ post_install)

    val build_lock = Lwt_mutex.create ()

      match !cached_build with
      | Some cached -> Lwt.return cached
      | None -> (
          let* phases =
            Lwt.all
              [
                self#setup;
                self#unpack_phase;
                self#configure_phase;
                self#build_phase;
                self#install_phase;
              ]
          in
          let builder = String.concat "\n" phases in
          let c =
            match !backend_conn with None -> failwith "no conn" | Some c -> c
          in
          let* output_hash = self#output_hash in
          let* r =
            derivation c ~name:self#name ~builder ~paths:!extra_paths
              ~stdout:!(self#stdout) ~stderr:!(self#stderr) ~target:self#target
              ~output_hash
          in
          match r with
          | `Ok r ->
              let c = { destdir = r.destdir; paths = r.paths } in
              cached_build := Some c;
              Lwt.return c
          | `Error e -> failwith e
          | _ -> assert false)

      Lwt_mutex.with_lock build_lock (fun () ->
          match !cached_build with
          | Some cached -> Lwt.return cached
          | None -> (
              let* setup = self#setup in
              let* unpack_phase = self#unpack_phase in
              let* configure_phase = self#configure_phase in
              let* build_phase = self#build_phase in
              let* install_phase = self#install_phase in
              let phases =
                [
                  setup;
                  unpack_phase;
                  configure_phase;
                  build_phase;
                  install_phase;
                ]
              in
              let builder = String.concat "\n" phases in
              let c =
                match !backend_conn with
                | None -> failwith "no conn"
                | Some c -> c
              in
              let* output_hash = self#output_hash in
              let* r =
                derivation c ~name:self#name ~builder ~paths:!extra_paths
                  ~stdout:!(self#stdout) ~stderr:!(self#stderr)
                  ~target:self#target ~output_hash
              in
              match r with
              | `Ok r ->
                  let c = { destdir = r.destdir; paths = r.paths } in
                  cached_build := Some c;
                  Lwt.return c
              | `Error e -> failwith e
              | _ -> assert false))

let unzip pkg =
  object (self)
    inherit std_derivation
    method name = "rust"
    method! unpack_phase = Lwt.return ""
    method! build_inputs =
      Lwt.return
        [
          (ubuntu "libc6-dev" :> derivation);
          (ubuntu "coreutils" :> derivation);
          (ubuntu "tar" :> derivation);
          (ubuntu "gzip" :> derivation);
        ]
    method! build_phase =
      let* zipped = self#derivation pkg in
      Lwt.return
        ("mkdir -p $DESTDIR; tar -xf " ^ List.hd zipped.destdir ^ " -C $DESTDIR")
  end