(* Unison file synchronizer: src/os.ml *)
(* Copyright 1999-2010, Benjamin C. Pierce 

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program 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.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)


(* This file attempts to isolate operating system specific details from the  *)
(* rest of the program.                                                      *)

let debug = Util.debug "os"

let myCanonicalHostName =
  try System.getenv "UNISONLOCALHOSTNAME"
  with Not_found -> Unix.gethostname()

let tempFilePrefix = ".unison."
let tempFileSuffixFixed = ".unison.tmp"
let tempFileSuffix = ref tempFileSuffixFixed
let includeInTempNames s =
  (* BCP: Added this in Jan 08.  If (as I believe) it never fails, then this tricky
     stuff can be deleted. *)
  assert (s<>"");  
  tempFileSuffix :=
    if s = "" then tempFileSuffixFixed
    else "." ^ s ^ tempFileSuffixFixed

(*****************************************************************************)
(*                      QUERYING THE FILESYSTEM                              *)
(*****************************************************************************)

let exists fspath path =
  (Fileinfo.get false fspath path).Fileinfo.typ <> `ABSENT

let readLink fspath path =
  Util.convertUnixErrorsToTransient
  "reading symbolic link"
    (fun () ->
       let abspath = Fspath.concat fspath path in
       Fs.readlink abspath)

let rec isAppleDoubleFile file =
  Prefs.read Osx.rsrc &&
  String.length file > 2 && file.[0] = '.' && file.[1] = '_'

(* Assumes that (fspath, path) is a directory, and returns the list of       *)
(* children, except for '.' and '..'.                                        *)
let allChildrenOf fspath path =
  Util.convertUnixErrorsToTransient
  "scanning directory"
    (fun () ->
      let rec loop children directory =
        let newFile = try directory.Fs.readdir () with End_of_file -> "" in
        if newFile = "" then children else
        let newChildren =
          if newFile = "." || newFile = ".." then
            children
          else
            Name.fromString newFile :: children in
        loop newChildren directory
      in
      let absolutePath = Fspath.concat fspath path in
      let directory =
        try
          Some (Fs.opendir absolutePath)
        with Unix.Unix_error (Unix.ENOENT, _, _) ->
          (* FIX (in Ocaml): under Windows, when a directory is empty
             (not even "." and ".."), FindFirstFile fails with
             ERROR_FILE_NOT_FOUND while ocaml expects the error
             ERROR_NO_MORE_FILES *)
          None
      in
      match directory with
        Some directory ->
          begin try
            let result = loop [] directory in
            directory.Fs.closedir ();
            result
          with Unix.Unix_error _ as e ->
            begin try
              directory.Fs.closedir ()
            with Unix.Unix_error _ -> () end;
            raise e
          end
      | None ->
          [])

(* Assumes that (fspath, path) is a directory, and returns the list of       *)
(* children, except for temporary files and AppleDouble files.               *)
let rec childrenOf fspath path =
  List.filter
    (fun filename ->
       let file = Name.toString filename in
       if isAppleDoubleFile file then
         false
(* does it belong to here ? *)
(*          else if Util.endswith file backupFileSuffix then begin *)
(*             let newPath = Path.child path filename in *)
(*             removeBackupIfUnwanted fspath newPath; *)
(*             false *)
(*           end  *)
       else if
         Util.endswith file tempFileSuffixFixed &&
         Util.startswith file tempFilePrefix
       then begin
         if Util.endswith file !tempFileSuffix then begin
           let p = Path.child path filename in
           let i = Fileinfo.get false fspath p in
           let secondsinthirtydays = 2592000.0 in
           if Props.time i.Fileinfo.desc +. secondsinthirtydays < Util.time()
           then begin
             debug (fun()-> Util.msg "deleting old temp file %s\n"
                      (Fspath.toDebugString (Fspath.concat fspath p)));
             delete fspath p
           end else
             debug (fun()-> Util.msg
                      "keeping temp file %s since it is less than 30 days old\n"
                      (Fspath.toDebugString (Fspath.concat fspath p)));
         end;
         false
       end else
         true)
    (allChildrenOf fspath path)

(*****************************************************************************)
(*                        ACTIONS ON FILESYSTEM                              *)
(*****************************************************************************)

(* Deletes a file or a directory, but checks before if there is something    *)
and delete fspath path =
  Util.convertUnixErrorsToTransient
    "deleting"
    (fun () ->
      let absolutePath = Fspath.concat fspath path in
      match (Fileinfo.get false fspath path).Fileinfo.typ with
        `DIRECTORY ->
          begin try
            Fs.chmod absolutePath 0o700
          with Unix.Unix_error _ -> () end;
          Safelist.iter
            (fun child -> delete fspath (Path.child path child))
            (allChildrenOf fspath path);
          Fs.rmdir absolutePath
      | `FILE ->
          if Util.osType <> `Unix then begin
            try
              Fs.chmod absolutePath 0o600;
            with Unix.Unix_error _ -> ()
          end;
          Fs.unlink absolutePath;
          if Prefs.read Osx.rsrc then begin
            let pathDouble = Fspath.appleDouble absolutePath in
            if Fs.file_exists pathDouble then
              Fs.unlink pathDouble
          end
      | `SYMLINK ->
           (* Note that chmod would not do the right thing on links *)
          Fs.unlink absolutePath
      | `ABSENT ->
          ())
    
let rename fname sourcefspath sourcepath targetfspath targetpath =
  let source = Fspath.concat sourcefspath sourcepath in
  let source' = Fspath.toPrintString source in
  let target = Fspath.concat targetfspath targetpath in
  let target' = Fspath.toPrintString target in
  if source = target then
    raise (Util.Transient ("Rename ("^fname^"): identical source and target " ^ source'));
  Util.convertUnixErrorsToTransient ("renaming " ^ source' ^ " to " ^ target')
    (fun () ->
      debug (fun() -> Util.msg "rename %s to %s\n" source' target');
      Fs.rename source target;
      if Prefs.read Osx.rsrc then begin
        let sourceDouble = Fspath.appleDouble source in
        let targetDouble = Fspath.appleDouble target in
        if Fs.file_exists sourceDouble then
          Fs.rename sourceDouble targetDouble
        else if Fs.file_exists targetDouble then
          Fs.unlink targetDouble
      end)
    
let symlink =
  if Util.isCygwin || (Util.osType != `Win32) then
    fun fspath path l ->
      Util.convertUnixErrorsToTransient
      "writing symbolic link"
      (fun () ->
         let abspath = Fspath.concat fspath path in
         Fs.symlink l abspath)
  else
    fun fspath path l ->
      raise (Util.Transient
               (Format.sprintf
                  "Cannot create symlink \"%s\": \
                   symlinks are not supported under Windows"
                  (Fspath.toPrintString (Fspath.concat fspath path))))

(* Create a new directory, using the permissions from the given props        *)
let createDir fspath path props =
  Util.convertUnixErrorsToTransient
  "creating directory"
    (fun () ->
       let absolutePath = Fspath.concat fspath path in
       Fs.mkdir absolutePath (Props.perms props))

(*****************************************************************************)
(*                              FINGERPRINTS                                 *)
(*****************************************************************************)

type fullfingerprint = Fingerprint.t * Fingerprint.t

let fingerprint fspath path info =
  (Fingerprint.file fspath path,
   Osx.ressFingerprint fspath path info.Fileinfo.osX)

let fastercheckUNSAFE =
  Prefs.createBool "fastercheckUNSAFE"
    false "!skip computing fingerprints for new files (experts only!)"
    (  "THIS FEATURE IS STILL EXPERIMENTAL AND SHOULD BE USED WITH EXTREME CAUTION.  "
       ^ "\n\n"
       ^ "When this flag is set to {\\tt true}, Unison will compute a 'pseudo-" 
       ^ "fingerprint' the first time it sees a file (either because the file is "
       ^ "new or because Unison is running for the first time).  This enormously "
       ^ "speeds update detection, but it must be used with care, as it can cause "
       ^ "Unison to miss conflicts: If "
       ^ "a given path in the filesystem contains files on {\\em both} sides that "
       ^ "Unison has not yet seen, and if those files have the same length but different "
       ^ "contents, then Unison will not notice the presence of a conflict.  If, later, one "
       ^ "of the files is changed, the changed file will be propagated, overwriting  "
       ^ "the other.  "
       ^ "\n\n"
       ^ "Moreover, even when the files are initially identical, setting this flag can lead "
       ^ "to potentially confusing behavior: "
       ^ "if a newly created file is later touched without being modified, Unison will "
       ^ "treat this "
       ^ "conservatively as a potential change (since it has no record of the earlier "
       ^ "contents) and show it as needing to be propagated to the other replica. "
       ^ "\n\n"
       ^ "Most users should leave this flag off -- the small time savings of not "
       ^ "fingerprinting new files is not worth the cost in terms of safety.  However, "
       ^ "it can be very useful for power users with huge replicas that are known to "
       ^ "be already synchronized (e.g., because one replica is a newly created duplicate "
       ^ "of the other, or because they have previously been synchronized with Unison but "
       ^ "Unison's archives need to be rebuilt).  In such situations, it is recommended "
       ^ "that this flag be set only for the initial run of Unison, so that new archives "
       ^ "can be created quickly, and then turned off for normal use.")

let pseudoFingerprint path size =
  (Fingerprint.pseudo path size, Fingerprint.dummy)

let isPseudoFingerprint (fp,rfp) =
  Fingerprint.ispseudo fp

(* FIX: not completely safe under Unix                                       *)
(* (with networked file system such as NFS)                                  *)
let safeFingerprint ?(newfile=false) fspath path info optDig =
  if Prefs.read fastercheckUNSAFE && newfile then begin
    debug (fun()-> Util.msg "skipping initial fingerprint of %s\n"
                      (Fspath.toDebugString (Fspath.concat fspath path)));
    let info = Fileinfo.get false fspath path in
    (info, pseudoFingerprint path (Props.length info.Fileinfo.desc))
  end else 
    let rec retryLoop count info optDig optRessDig =
      if count = 0 then
        raise (Util.Transient
                 (Printf.sprintf
                    "Failed to fingerprint file \"%s\": \
                     the file keeps on changing"
                    (Fspath.toPrintString (Fspath.concat fspath path))))
      else
        let dig =
          match optDig with
            None     -> Fingerprint.file fspath path
          | Some dig -> dig
        in
        let ressDig =
          match optRessDig with
            None      -> Osx.ressFingerprint fspath path info.Fileinfo.osX
          | Some ress -> ress
        in
        let (info', dataUnchanged, ressUnchanged) =
          Fileinfo.unchanged fspath path info in
        if dataUnchanged && ressUnchanged then
          (info', (dig, ressDig))
        else
          retryLoop (count - 1) info'
            (if dataUnchanged then Some dig else None)
            (if ressUnchanged then Some ressDig else None)
    in
    retryLoop 10 info (* Maximum retries: 10 times *)
      (match optDig with None -> None | Some (d, _) -> Some d)
      None

let fullfingerprint_to_string (fp,rfp) =
  Printf.sprintf "(%s,%s)" (Fingerprint.toString fp) (Fingerprint.toString rfp)

let reasonForFingerprintMismatch (digdata,digress) (digdata',digress') =
  if digdata = digdata' then "resource fork"
  else if digress = digress' then "file contents"
  else "both file contents and resource fork"

let fullfingerprint_dummy = (Fingerprint.dummy,Fingerprint.dummy)

let fullfingerprintHash (fp, rfp) =
  Fingerprint.hash fp + 31 * Fingerprint.hash rfp

let fullfingerprintEqual (fp, rfp) (fp', rfp') =
  Fingerprint.equal fp fp' && Fingerprint.equal rfp rfp'


(*****************************************************************************)
(*                           UNISON DIRECTORY                                *)
(*****************************************************************************)

(* Gives the fspath of the archive directory on the machine, depending on    *)
(* which OS we use                                                           *)
let unisonDir =
  try
    System.fspathFromString (System.getenv "UNISON")
  with Not_found ->
    let genericName =
      Util.fileInHomeDir (Printf.sprintf ".%s" Uutil.myName) in
    if Osx.isMacOSX && not (System.file_exists genericName) then
      Util.fileInHomeDir "Library/Application Support/Unison"
    else
      genericName

(* build a fspath representing an archive child path whose name is given     *)
let fileInUnisonDir str = System.fspathConcat unisonDir str

(* Make sure archive directory exists                                        *)
let createUnisonDir() =
  try ignore (System.stat unisonDir)
  with Unix.Unix_error(_) ->
    Util.convertUnixErrorsToFatal
      (Printf.sprintf "creating unison directory %s"
         (System.fspathToPrintString unisonDir))
      (fun () ->
         ignore (System.mkdir unisonDir 0o700))

(*****************************************************************************)
(*                           TEMPORARY FILES                                 *)
(*****************************************************************************)

(* Truncate a filename to at most [l] bytes, making sure of not
   truncating an UTF-8 character.  Assumption: [String.length s > l] *)
let rec truncate_filename s l =
  if l > 0 && Char.code s.[l] land 0xC0 = 0x80 then
    truncate_filename s (l - 1)
  else
    String.sub s 0 l

(* Generates an unused fspath for a temporary file.                          *)
let genTempPath fresh fspath path prefix suffix =
  let rec f i =
    let s =
      if i=0 then suffix
      else Printf.sprintf "..%03d.%s" i suffix in
    let tempPath =
      match Path.deconstructRev path with
        None ->
          assert false
      | Some (name, parentPath) ->
          let name = Name.toString name in
          let len = String.length name in
          let maxlen = 64 in
          let name =
            if len <= maxlen then name else
            (truncate_filename name maxlen ^
             Digest.to_hex (Digest.string name))
          in
          Path.child parentPath (Name.fromString (prefix ^ name ^ s))
    in
    if fresh && exists fspath tempPath then f (i + 1) else tempPath
  in f 0

let tempPath ?(fresh=true) fspath path =
  genTempPath fresh fspath path tempFilePrefix !tempFileSuffix
