<commit_before>(* Copyright (C) 2013, <NAME>
 * See the README file for details, or visit http://0install.net.
 *)

open General
open Support.Common
module U = Support.Utils

type mime_type = string

let type_from_url url =
  let re_extension = Str.regexp "\\(\\.tar\\)?\\.[^./]+$" in
  let ext =
    try U.string_tail url @@ Str.search_forward re_extension url 0
    with Not_found -> "" in
  match String.lowercase ext with
  | ".tar.bz2"  -> "application/x-bzip-compressed-tar"
  | ".tar.gz"   -> "application/x-compressed-tar"
  | ".tar.lzma" -> "application/x-lzma-compressed-tar"
  | ".tar.xz"   -> "application/x-xz-compressed-tar"
  | ".rpm" -> "application/x-rpm"
  | ".deb" -> "application/x-deb"
  | ".tbz" -> "application/x-bzip-compressed-tar"
  | ".tgz" -> "application/x-compressed-tar"
  | ".tlz" -> "application/x-lzma-compressed-tar"
  | ".txz" -> "application/x-xz-compressed-tar"
  | ".tar" -> "application/x-tar"
  | ".zip" -> "application/zip"
  | ".cab" -> "application/vnd.ms-cab-compressed"
  | ".dmg" -> "application/x-apple-diskimage"
  | ".gem" -> "application/x-ruby-gem"
  | _ -> raise_safe "Can't guess MIME type from name (%s)" url

let check_type_ok system =
  let missing name = U.find_in_path system name = None in
  function
    | "application/x-rpm" -> if missing "rpm2cpio" then
        raise_safe "This package looks like an RPM, but you don't have the rpm2cpio command \
                    I need to extract it. Install the \"rpm\" package first (this works even if \
                    you're on a non-RPM-based distribution such as Debian)."
    | "application/x-deb" -> if missing "ar" then
        raise_safe "This package looks like a Debian package, but you don't have the \"ar\" command \
                     I need to extract it. Install the package containing it (sometimes called \"binutils\") \
                     first. This works even if you're on a non-Debian-based distribution such as Red Hat)."
    | "application/x-bzip-compressed-tar" -> ()	(* We"ll fall back to Python"s built-in tar.bz2 support *)
    | "application/zip" -> if missing "unzip" then
        raise_safe "This package looks like a zip-compressed archive, but you don't have the \"unzip\" command \
                    I need to extract it. Install the package containing it first."
    | "application/vnd.ms-cab-compressed" -> if missing "cabextract" then
        raise_safe "This package looks like a Microsoft Cabinet archive, but you don't have the \"cabextract\" command \
                    I need to extract it. Install the package containing it first."
    | "application/x-apple-diskimage" -> if missing "hdiutil" then
        raise_safe "This package looks like a Apple Disk Image, but you don't have the \"hdiutil\" command \
                    I need to extract it."
    | "application/x-lzma-compressed-tar" -> () (* We can get it through Zero Install *)
    | "application/x-xz-compressed-tar" -> if missing "unxz" then
        raise_safe "This package looks like a xz-compressed package, but you don't have the \"unxz\" command \
                    I need to extract it. Install the package containing it (it's probably called \"xz-utils\") first."
    | "application/x-compressed-tar" | "application/x-tar" | "application/x-ruby-gem" -> ()
    | mime_type ->
        raise_safe "Unsupported archive type \"%s\" (for 0install version %s)" mime_type About.version

type compression = Bzip2 | Gzip | Lzma | Xz | Uncompressed

let make_command = U.make_command

(** Run a command in a subprocess. If it returns an error code, generate an exception containing its stdout and stderr. *)
let run_command ?cwd system args =
  (* Some zip archives are missing timezone information; force consistent results *)
  let child_env = Array.append system#environment [|
    (* Some zip archives lack time-zone information. Make sure all systems see the same time. *)
    "TZ=GMT";

    (* Stop OS X extracting extended attributes: *)
    "COPYFILE_DISABLE=true";                    (* Leopard *)
    "COPY_EXTENDED_ATTRIBUTES_DISABLE=true";    (* Tiger *)
  |] in

  (* todo: use pola-run if available, once it supports fchmod *)
  let command = make_command system args in
  let child =
    match cwd with
    | None -> Lwt_process.open_process_full ~env:child_env command
    | Some cwd ->
        U.finally_do
          (fun old_cwd -> system#chdir old_cwd)
          system#getcwd
          (fun _ ->
            system#chdir cwd;
            Lwt_process.open_process_full ~env:child_env command) in
  try_lwt
    lwt stdout = Lwt_io.read child#stdout
    and stderr = Lwt_io.read child#stderr
    and () = Lwt_io.close child#stdin in

    lwt status = child#close in

    try
      match status with
      | Unix.WEXITED 0 -> Lwt.return ()
      | status ->
          let messages = trim @@ stdout ^ stderr in
          if messages = "" then Support.System.check_exit_status status;
          raise_safe "Command failed: %s" messages
    with Safe_exception _ as ex ->
      reraise_with_context ex "... extracting archive with: %s" (Support.Logging.format_argv_for_logging args)
  finally
    lwt _ = child#close in
    Lwt.return ()

let re_gnu_tar = Str.regexp ".*(GNU tar)"
let _tar_flavour = ref `unknown
let get_tar_flavour system =
  match !_tar_flavour with
  | `unknown ->
      lwt line = Lwt_process.pread_line (make_command system ["tar"; "--version"]) in
      let f =
        if Str.string_match re_gnu_tar line 0 then `gnu_tar
        else `plain_tar in
      _tar_flavour := f;
      Lwt.return f
  | (`gnu_tar | `plain_tar) as x -> Lwt.return x

let extract_tar config ~dstdir ?extract ~compression archive =
  let system = config.system in

  extract |> if_some (fun extract ->
    (* Limit the characters we accept, to avoid sending dodgy strings to tar *)
    if not (Str.string_match (Str.regexp "^[a-zA-Z0-9][- _a-zA-Z0-9.]*$") extract 0) then
      raise_safe "Illegal character in extract attribute ('%s')" extract
  );

  let share_dir = lazy (
    let bindir = Filename.dirname config.abspath_0install in
    let sys_share = bindir +/ ".." +/ "share" in
    if U.is_dir system sys_share then sys_share   (* 0install is installed as distro package *)
    else bindir +/ "share"                        (* Running via 0install *)
  ) in

  lwt tar_flavour = get_tar_flavour system in

  let ext_cmd = ["tar"; "-xf"; archive; "-C"; dstdir] @

    begin match tar_flavour with
    | `gnu_tar -> ["--no-same-owner"; "--no-same-permissions"]
    | `plain_tar -> [] end @

    begin match compression with
    | Bzip2 -> ["--bzip2"]
    | Gzip -> ["-z"]
    | Lzma ->
        let unlzma = U.find_in_path system "unlzma" |? lazy (
          Lazy.force share_dir +/ "0install.net" +/ "unlzma"
        ) in ["--use-compress-program=" ^ unlzma]
    | Xz ->
        let unxz = U.find_in_path system "unxz" |? lazy (
          Lazy.force share_dir +/ "0install.net" +/ "unxz"
        ) in ["--use-compress-program=" ^ unxz]
    | Uncompressed -> [] end @

    begin match extract with
    | Some extract -> [extract]
    | None -> [] end in

  run_command system ext_cmd

let extract_gem config ~dstdir ?extract archive =
  let payload = "data.tar.gz" in
  let tmpdir = U.make_tmp_dir config.system ~prefix:"extract-gem-" dstdir in
  try_lwt
    (archive |> extract_tar config ~dstdir:tmpdir ~extract:payload ~compression:Uncompressed) >>
    (tmpdir +/ payload |> extract_tar config ~dstdir ?extract ~compression:Gzip);
  finally
    U.rmtree ~even_if_locked:true config.system tmpdir;
    Lwt.return ()

let extract_cab config ~dstdir ?extract archive =
  extract |> if_some (fun _ -> raise_safe "Sorry, but the 'extract' attribute is not yet supported for Cabinet files");
  run_command config.system ["cabextract"; "-s"; "-q"; "-d"; dstdir; archive]

let extract_dmg config ~dstdir ?extract archive =
  extract |> if_some (fun _ -> raise_safe "Sorry, but the 'extract' attribute is not yet supported for DMGs");

  let system = config.system in

  let mountpoint = U.make_tmp_dir system ~prefix:"archive-" dstdir in

  lwt () = run_command system ["hdiutil"; "attach"; "-quiet"; "-mountpoint"; mountpoint; "-nobrowse"; archive] in
  lwt () =
    Lwt.finalize (fun () ->
      let files =
        match system#readdir mountpoint with
        | Problem ex -> raise ex
        | Success items -> Array.to_list items |> List.map ((^) (mountpoint ^ "/")) in
      run_command system @@ ["cp"; "-pR"] @ files @ [dstdir]
    ) (fun () ->
      run_command system @@ ["hdiutil"; "detach"; "-quiet"; mountpoint]
    ) in
  U.rmtree ~even_if_locked:true system mountpoint;<commit_msg>Ignore .Trashes when extracting from .dmg archives<commit_after>(* Copyright (C) 2013, <NAME>
 * See the README file for details, or visit http://0install.net.
 *)

open General
open Support.Common
module U = Support.Utils

type mime_type = string

let type_from_url url =
  let re_extension = Str.regexp "\\(\\.tar\\)?\\.[^./]+$" in
  let ext =
    try U.string_tail url @@ Str.search_forward re_extension url 0
    with Not_found -> "" in
  match String.lowercase ext with
  | ".tar.bz2"  -> "application/x-bzip-compressed-tar"
  | ".tar.gz"   -> "application/x-compressed-tar"
  | ".tar.lzma" -> "application/x-lzma-compressed-tar"
  | ".tar.xz"   -> "application/x-xz-compressed-tar"
  | ".rpm" -> "application/x-rpm"
  | ".deb" -> "application/x-deb"
  | ".tbz" -> "application/x-bzip-compressed-tar"
  | ".tgz" -> "application/x-compressed-tar"
  | ".tlz" -> "application/x-lzma-compressed-tar"
  | ".txz" -> "application/x-xz-compressed-tar"
  | ".tar" -> "application/x-tar"
  | ".zip" -> "application/zip"
  | ".cab" -> "application/vnd.ms-cab-compressed"
  | ".dmg" -> "application/x-apple-diskimage"
  | ".gem" -> "application/x-ruby-gem"
  | _ -> raise_safe "Can't guess MIME type from name (%s)" url

let check_type_ok system =
  let missing name = U.find_in_path system name = None in
  function
    | "application/x-rpm" -> if missing "rpm2cpio" then
        raise_safe "This package looks like an RPM, but you don't have the rpm2cpio command \
                    I need to extract it. Install the \"rpm\" package first (this works even if \
                    you're on a non-RPM-based distribution such as Debian)."
    | "application/x-deb" -> if missing "ar" then
        raise_safe "This package looks like a Debian package, but you don't have the \"ar\" command \
                     I need to extract it. Install the package containing it (sometimes called \"binutils\") \
                     first. This works even if you're on a non-Debian-based distribution such as Red Hat)."
    | "application/x-bzip-compressed-tar" -> ()	(* We"ll fall back to Python"s built-in tar.bz2 support *)
    | "application/zip" -> if missing "unzip" then
        raise_safe "This package looks like a zip-compressed archive, but you don't have the \"unzip\" command \
                    I need to extract it. Install the package containing it first."
    | "application/vnd.ms-cab-compressed" -> if missing "cabextract" then
        raise_safe "This package looks like a Microsoft Cabinet archive, but you don't have the \"cabextract\" command \
                    I need to extract it. Install the package containing it first."
    | "application/x-apple-diskimage" -> if missing "hdiutil" then
        raise_safe "This package looks like a Apple Disk Image, but you don't have the \"hdiutil\" command \
                    I need to extract it."
    | "application/x-lzma-compressed-tar" -> () (* We can get it through Zero Install *)
    | "application/x-xz-compressed-tar" -> if missing "unxz" then
        raise_safe "This package looks like a xz-compressed package, but you don't have the \"unxz\" command \
                    I need to extract it. Install the package containing it (it's probably called \"xz-utils\") first."
    | "application/x-compressed-tar" | "application/x-tar" | "application/x-ruby-gem" -> ()
    | mime_type ->
        raise_safe "Unsupported archive type \"%s\" (for 0install version %s)" mime_type About.version

type compression = Bzip2 | Gzip | Lzma | Xz | Uncompressed

let make_command = U.make_command

(** Run a command in a subprocess. If it returns an error code, generate an exception containing its stdout and stderr. *)
let run_command ?cwd system args =
  (* Some zip archives are missing timezone information; force consistent results *)
  let child_env = Array.append system#environment [|
    (* Some zip archives lack time-zone information. Make sure all systems see the same time. *)
    "TZ=GMT";

    (* Stop OS X extracting extended attributes: *)
    "COPYFILE_DISABLE=true";                    (* Leopard *)
    "COPY_EXTENDED_ATTRIBUTES_DISABLE=true";    (* Tiger *)
  |] in

  (* todo: use pola-run if available, once it supports fchmod *)
  let command = make_command system args in
  let child =
    match cwd with
    | None -> Lwt_process.open_process_full ~env:child_env command
    | Some cwd ->
        U.finally_do
          (fun old_cwd -> system#chdir old_cwd)
          system#getcwd
          (fun _ ->
            system#chdir cwd;
            Lwt_process.open_process_full ~env:child_env command) in
  try_lwt
    lwt stdout = Lwt_io.read child#stdout
    and stderr = Lwt_io.read child#stderr
    and () = Lwt_io.close child#stdin in

    lwt status = child#close in

    try
      match status with
      | Unix.WEXITED 0 -> Lwt.return ()
      | status ->
          let messages = trim @@ stdout ^ stderr in
          if messages = "" then Support.System.check_exit_status status;
          raise_safe "Command failed: %s" messages
    with Safe_exception _ as ex ->
      reraise_with_context ex "... extracting archive with: %s" (Support.Logging.format_argv_for_logging args)
  finally
    lwt _ = child#close in
    Lwt.return ()

let re_gnu_tar = Str.regexp ".*(GNU tar)"
let _tar_flavour = ref `unknown
let get_tar_flavour system =
  match !_tar_flavour with
  | `unknown ->
      lwt line = Lwt_process.pread_line (make_command system ["tar"; "--version"]) in
      let f =
        if Str.string_match re_gnu_tar line 0 then `gnu_tar
        else `plain_tar in
      _tar_flavour := f;
      Lwt.return f
  | (`gnu_tar | `plain_tar) as x -> Lwt.return x

let extract_tar config ~dstdir ?extract ~compression archive =
  let system = config.system in

  extract |> if_some (fun extract ->
    (* Limit the characters we accept, to avoid sending dodgy strings to tar *)
    if not (Str.string_match (Str.regexp "^[a-zA-Z0-9][- _a-zA-Z0-9.]*$") extract 0) then
      raise_safe "Illegal character in extract attribute ('%s')" extract
  );

  let share_dir = lazy (
    let bindir = Filename.dirname config.abspath_0install in
    let sys_share = bindir +/ ".." +/ "share" in
    if U.is_dir system sys_share then sys_share   (* 0install is installed as distro package *)
    else bindir +/ "share"                        (* Running via 0install *)
  ) in

  lwt tar_flavour = get_tar_flavour system in

  let ext_cmd = ["tar"; "-xf"; archive; "-C"; dstdir] @

    begin match tar_flavour with
    | `gnu_tar -> ["--no-same-owner"; "--no-same-permissions"]
    | `plain_tar -> [] end @

    begin match compression with
    | Bzip2 -> ["--bzip2"]
    | Gzip -> ["-z"]
    | Lzma ->
        let unlzma = U.find_in_path system "unlzma" |? lazy (
          Lazy.force share_dir +/ "0install.net" +/ "unlzma"
        ) in ["--use-compress-program=" ^ unlzma]
    | Xz ->
        let unxz = U.find_in_path system "unxz" |? lazy (
          Lazy.force share_dir +/ "0install.net" +/ "unxz"
        ) in ["--use-compress-program=" ^ unxz]
    | Uncompressed -> [] end @

    begin match extract with
    | Some extract -> [extract]
    | None -> [] end in

  run_command system ext_cmd

let extract_gem config ~dstdir ?extract archive =
  let payload = "data.tar.gz" in
  let tmpdir = U.make_tmp_dir config.system ~prefix:"extract-gem-" dstdir in
  try_lwt
    (archive |> extract_tar config ~dstdir:tmpdir ~extract:payload ~compression:Uncompressed) >>
    (tmpdir +/ payload |> extract_tar config ~dstdir ?extract ~compression:Gzip);
  finally
    U.rmtree ~even_if_locked:true config.system tmpdir;
    Lwt.return ()

let extract_cab config ~dstdir ?extract archive =
  extract |> if_some (fun _ -> raise_safe "Sorry, but the 'extract' attribute is not yet supported for Cabinet files");
  run_command config.system ["cabextract"; "-s"; "-q"; "-d"; dstdir; archive]

let extract_dmg config ~dstdir ?extract archive =
  extract |> if_some (fun _ -> raise_safe "Sorry, but the 'extract' attribute is not yet supported for DMGs");

  let system = config.system in

  let mountpoint = U.make_tmp_dir system ~prefix:"archive-" dstdir in

  lwt () = run_command system ["hdiutil"; "attach"; "-quiet"; "-readonly"; "-mountpoint"; mountpoint; "-nobrowse"; archive] in
  lwt () =
    Lwt.finalize (fun () ->
      let files =
        match system#readdir mountpoint with
        | Problem ex -> raise ex
        | Success items ->
            Array.to_list items
            |> List.filter ((<>) ".Trashes")
            |> List.map ((^) (mountpoint ^ "/")) in
      run_command system @@ ["cp"; "-pR"] @ files @ [dstdir]
    ) (fun () ->
      run_command system @@ ["hdiutil"; "detach"; "-quiet"; mountpoint]
    ) in
  U.rmtree ~even_if_locked:true system mountpoint;
{'fraction_non_alphanumeric': 0.12479134288839003, 'fraction_numerical': 0.0029931502906809415, 'mean_word_length': 2.7243301178992496, 'pattern_counts': {'":': 0, '<': 6, '<?xml version=': 0, '>': 127, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6859976', 'n_tokens_mistral': 5691, 'n_tokens_neox': 5446, 'n_words': 1722}