Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 0b7a2c8d1f
Fetching contributors…

Cannot retrieve contributors at this time

file 403 lines (356 sloc) 11.319 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
(***********************************************************************)
(* *)
(* Copyright 2012 OCamlPro *)
(* Copyright 2012 INRIA *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Public License version 3.0. *)
(* *)
(* TypeRex is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU General Public License for more details. *)
(* *)
(***********************************************************************)

module Sys2 = struct
  open Unix

  (** behaves as [Sys.is_directory] except for symlinks, which returns always [false]. *)
  let is_directory file =
    (lstat file).st_kind = S_DIR
end

let log fmt = Globals.log "RUN" fmt

let (/) = Filename.concat

let rec mk_temp_dir str =
  let s =
    Filename.temp_dir_name /
    Printf.sprintf "opam-%s.%d-%d" str (Unix.getpid ()) (Random.int 4096) in
  if Sys.file_exists s then
    mk_temp_dir str
  else
    s

let lock_file () =
  !Globals.root_path / "opam.lock"

let log_file () =
  Random.self_init ();
  let f = "command" ^ string_of_int (Random.int 2048) in
  !Globals.root_path / "log" / f

let safe_mkdir dir =
  if not (Sys.file_exists dir) then
    Unix.mkdir dir 0o755

let mkdir dir =
  log "mkdir %s" dir;
  let rec aux dir =
    if not (Sys.file_exists dir) then begin
      aux (Filename.dirname dir);
      safe_mkdir dir;
    end in
  aux dir
  
let copy src dst =
  log "copying %s to %s" src dst;
  let n = 1024 in
  let b = String.create n in
  let read = ref min_int in
  let ic = open_in_bin src in
  let oc =
    if Sys.file_exists dst then
    open_out_bin dst
    else
    let perm = (Unix.stat src).Unix.st_perm in
    mkdir (Filename.dirname dst);
    open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] perm dst
  in
  while !read <>0 do
    read := input ic b 0 n;
    output oc b 0 !read;
  done;
  close_in ic;
  close_out oc;
  let st = Unix.lstat src in
  Unix.utimes dst (st.Unix.st_atime) (st.Unix.st_mtime)

let read file =
  log "read %s" file;
  let ic = open_in_bin file in
  let n = in_channel_length ic in
  let s = String.create n in
  really_input ic s 0 n;
  close_in ic;
  s

let write file contents =
  mkdir (Filename.dirname file);
  log "write %s" file;
  let oc = open_out_bin file in
  output_string oc contents;
  close_out oc

let cwd = Unix.getcwd

let chdir dir =
  if Sys.file_exists dir then
    Unix.chdir dir
  else
    Globals.error_and_exit "%s does not exists!" dir

let in_dir dir fn =
  let cwd = Unix.getcwd () in
  chdir dir;
  try
    let r = fn () in
    chdir cwd;
    r
  with e ->
    chdir cwd;
    raise e
    
let list kind dir =
  in_dir dir (fun () ->
    let d = Sys.readdir (Unix.getcwd ()) in
    let d = Array.to_list d in
    let l = List.filter kind d in
    List.sort compare (List.map (Filename.concat dir) l)
  )

let files_with_links =
  list (fun f -> try not (Sys.is_directory f) with _ -> true)

let files_all_not_dir =
  list (fun f -> try not (Sys2.is_directory f) with _ -> true)

let directories_strict =
  list (fun f -> try Sys2.is_directory f with _ -> false)

let directories_with_links =
  list (fun f -> try Sys.is_directory f with _ -> false)

let rec_files dir =
  let rec aux accu dir =
    let d = directories_with_links dir in
    let f = files_with_links dir in
    List.fold_left aux (f @ accu) d in
  aux [] dir

let remove_file file =
  log "remove_file %s" file;
  try Unix.unlink file
  with Unix.Unix_error _ -> ()
    
let rec remove_dir dir = (** WARNING it fails if [dir] is not a [S_DIR] or simlinks to a directory *)
  if Sys.file_exists dir then begin
    List.iter remove_file (files_all_not_dir dir);
    List.iter remove_dir (directories_strict dir);
    log "remove_dir %s" dir;
    Unix.rmdir dir;
  end

let remove file =
  if Sys.file_exists file && Sys2.is_directory file then
    remove_dir file
  else
    remove_file file

let create_tmp_dir f =
  let dir = mk_temp_dir "run" in
  List.iter (fun f -> f dir)
    [ mkdir
    ; f
    ; remove_dir ]

let getchdir s =
  let p = Unix.getcwd () in
  let () = chdir s in
  p

let rec root path =
  let d = Filename.dirname path in
  if d = path || d = "" || d = "." then
    path
  else
    root d

(** Expand '..' and '.' *)
let normalize s =
  if Sys.file_exists s then
    getchdir (getchdir s)
  else
    s

let real_path p =
  let dir = normalize (Filename.dirname p) in
  let dir =
    if Filename.is_relative dir then
      Sys.getcwd () / dir
    else
      dir in
  let base = Filename.basename p in
  if base = "." then
    dir
  else
    dir / base

let replace_path bins =
  let path = ref "<not set>" in
  let env = Unix.environment () in
  for i = 0 to Array.length env - 1 do
    let k,v = match Utils.cut_at env.(i) '=' with
      | Some (k,v) -> k,v
      | None -> assert false in
    if k = "PATH" then
    let v = Utils.split v ':' in
    let bins = List.filter Sys.file_exists bins in
    let new_path = String.concat ":" (bins @ v) in
    env.(i) <- "PATH=" ^ new_path;
    path := new_path;
  done;
  env, !path

type command = string list

let run_process ?(add_to_env=[]) ?(add_to_path=[]) = function
  | [] -> invalid_arg "run_process"
  | cmd :: args ->
      let env, path = replace_path add_to_path in
      let add_to_env = List.map (fun (k,v) -> k^"="^v) add_to_env in
      let env = Array.concat [ env; Array.of_list add_to_env ] in
      let name = log_file () in
      mkdir (Filename.dirname name);
      let str = String.concat " " (cmd :: args) in
      log "cwd=%s path=%s name=%s %s" (Unix.getcwd ()) path name str;
      let r = Process.run ~env ~name cmd args in
      if Process.is_failure r then (
        Globals.warning "Command %S failed (see %s.{info,err,out})" str name;
        List.iter (Globals.msg "%s\n") r.Process.r_stdout;
        List.iter (Globals.msg "%s\n") r.Process.r_stderr;
      ) else if not !Globals.debug then
        Process.clean_files r;
      r

let command ?(add_to_env=[]) ?(add_to_path=[]) cmd =
  let r = run_process ~add_to_env ~add_to_path cmd in
  r.Process.r_code

let fold f =
  List.fold_left (fun err cmd ->
    match err, cmd with
    | _ , [] -> err
    | 0 , _ -> f cmd
    | err, _ -> err
  ) 0

let commands ?(add_to_env=[]) ?(add_to_path = []) =
  fold (command ~add_to_env ~add_to_path)

let read_command_output ?(add_to_env=[]) ?(add_to_path=[]) cmd =
  let r = run_process ~add_to_env ~add_to_path cmd in
  if Process.is_failure r then Globals.exit r.Process.r_code;
  r.Process.r_stdout

let is_archive file =
  List.fold_left
    (function
      | Some s -> fun _ -> Some s
      | None -> fun (ext, c) ->
        if List.exists (Filename.check_suffix file) ext then
          Some (fun dir -> command [ "tar" ; "xf"^c ; file; "-C" ; dir ])
        else
          None)
    None
    [ [ "tar.gz" ; "tgz" ], "z"
    ; [ "tar.bz2" ; "tbz" ], "j" ]

let extract o_tmp_dir file dst =
  log "untar %s" file;
  let files = read_command_output [ "tar" ; "tf" ; file ] in
  log "%s contains %d files: %s" file (List.length files) (String.concat ", " files);
  let f_tmp tmp_dir =
  let err =
    match is_archive file with
    | Some f_cmd -> f_cmd tmp_dir
    | None -> Globals.error_and_exit "%s is not a valid archive" file in
  if err <> 0 then
    Globals.error_and_exit "Error while extracting %s" file
  else
    let aux name =
      let src = tmp_dir / name in
      let kind =
        try if Sys.is_directory src then Some (`dir src) else Some (`file src)
        with Sys_error s when s = Printf.sprintf "%s: No such file or directory" src
          (* for instance, when wrong symbolic link *) ->
          Globals.warning "the file %s is skipped" src;
          None in
      match kind with
      | None -> None
      | Some f ->
          let root = root name in
          let n = String.length root in
          let rest = String.sub name n (String.length name - n) in
          Some (f, dst ^ rest) in
    let moves = Utils.filter_map aux files in
    List.iter (fun (src, dst) ->
      match src with
      | `dir _ -> mkdir dst
      | `file f ->
          mkdir (Filename.dirname dst);
          copy f dst
    ) moves in
  match o_tmp_dir with
    | None -> create_tmp_dir f_tmp
    | Some tmp_dir -> f_tmp tmp_dir

let link src dst =
  log "linking %s to %s" src dst;
  mkdir (Filename.dirname dst);
  if Sys.file_exists dst then
    remove_file dst;
  Unix.link src dst

let flock () =
  let l = ref 0 in
  let file = lock_file () in
  let id = string_of_int (Unix.getpid ()) in
  let max_l = 5 in
  let rec loop () =
    if Sys.file_exists file && !l < max_l then begin
      let ic = open_in file in
      let pid = input_line ic in
      close_in ic;
      Globals.msg
        "An other process (%s) has already locked %S. Retrying in 1s (%d/%d)\n"
        pid file !l max_l;
      Unix.sleep 1;
      incr l;
      loop ()
    end else if Sys.file_exists file then begin
      Globals.msg "Too many attemps. Cancelling ...\n";
      exit 1
    end else begin
      let oc = open_out file in
      output_string oc id;
      flush oc;
      close_out oc;
      Globals.log id "locking %s" file;
    end in
  loop ()
    
let funlock () =
  let id = string_of_int (Unix.getpid ()) in
  let file = lock_file () in
  if Sys.file_exists file then begin
    let ic = open_in file in
    let s = input_line ic in
    close_in ic;
    if s = id then begin
      Globals.log id "unlocking %s" file;
      Unix.unlink file;
    end else
      Globals.error_and_exit "cannot unlock %s (%s)" file s
  end else
    Globals.error_and_exit "Cannot find %s" file

let with_flock f =
  try
    flock ();
    f ();
    funlock ();
  with e ->
    funlock ();
    raise e

let ocaml_version () =
  try
    let s = read_command_output [ "ocamlc" ; "-version" ] in
    Some (Utils.string_strip (List.hd s))
  with _ ->
    None

let ocamlc_where () =
  try
    let s = read_command_output [ "ocamlc"; "-where" ] in
    Some (Utils.string_strip (List.hd s))
  with _ ->
    None

(* Only used by the compiler switch stuff *)
let download src dst =
  let cmd = match Globals.os with
    | Globals.Darwin -> [ "curl"; "--insecure" ; "-OL"; src ]
    | _ -> [ "wget"; "--no-check-certificate" ; src ] in
  create_tmp_dir (fun tmp_dir ->
  let e = in_dir tmp_dir (fun () -> command cmd) in
  let tmp_file = tmp_dir / Filename.basename src in
  if e = 0 then
    if Filename.check_suffix src "tar.gz"
    || Filename.check_suffix src "tar.bz2" then
      extract (Some tmp_dir) tmp_file dst
    else
      copy tmp_file (dst / Filename.basename src))

let extract = extract None

let patch p =
  let err = command ["patch"; "-p0"; "-i"; p] in
  if err <> 0 then
    Globals.error_and_exit "Cannot apply patch %s" p
Something went wrong with that request. Please try again.