(* Unison file synchronizer: src/common.ml *)
(* Copyright 1999-2020, 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/>.
*)


type hostname = string

(* Canonized roots                                                           *)
type host =
    Local
  | Remote of hostname

type root = host * Fspath.t

type 'a oneperpath = ONEPERPATH of 'a list

(* ------------------------------------------------------------------------- *)
(*                       Printing                                            *)
(* ------------------------------------------------------------------------- *)

let root2hostname root =
  match root with
    (Local, _) -> "local"
  | (Remote host, _) -> host

let root2string root =
  match root with
    (Local, fspath) -> Fspath.toPrintString fspath
  | (Remote host, fspath) -> "//"^host^"/"^(Fspath.toPrintString fspath)

(* ------------------------------------------------------------------------- *)
(*                      Root comparison                                      *)
(* ------------------------------------------------------------------------- *)

let compareRoots x y =
  match x,y with
    (Local,fspath1), (Local,fspath2) ->
      (* FIX: This is a path comparison, should it take case
         sensitivity into account ? *)
      Fspath.compare fspath1 fspath2
  | (Local,_), (Remote _,_) -> -1
  | (Remote _,_), (Local,_) -> 1
  | (Remote host1, fspath1), (Remote host2, fspath2) ->
      let result =
        (* FIX: Should this ALWAYS be a case insensitive compare? *)
        compare host1 host2 in
      if result = 0 then
        (* FIX: This is a path comparison, should it take case
           sensitivity into account ? *)
        Fspath.compare fspath1 fspath2
      else
        result

let sortRoots rootList = Safelist.sort compareRoots rootList

(* ---------------------------------------------------------------------- *)

type prevState1 =
    Previous of Fileinfo.typ * Props.t * Os.fullfingerprint * Osx.ressStamp
  | New

let mprevState1 = Umarshal.(sum2
                             (prod4 Fileinfo.mtyp Props.m Os.mfullfingerprint Osx.mressStamp id id)
                             unit
                             (function
                              | Previous (a, b, c, d) -> I21 (a, b, c, d)
                              | New -> I22 ())
                             (function
                              | I21 (a, b, c, d) -> Previous (a, b, c, d)
                              | I22 () -> New))

type prevState =
  | PrevDir of Props.t
  | PrevFile of Props.t * Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp
  | PrevSymlink
  | New

let mprevState2 = Umarshal.(sum4
                             Props.m
                             (prod4 Props.m Os.mfullfingerprint Fileinfo.mstamp Osx.mressStamp id id)
                             unit
                             unit
                             (function
                              | PrevDir a -> I41 a
                              | PrevFile (a, b, c, d) -> I42 (a, b, c, d)
                              | PrevSymlink -> I43 ()
                              | New -> I44 ())
                             (function
                              | I41 a -> PrevDir a
                              | I42 (a, b, c, d) -> PrevFile (a, b, c, d)
                              | I43 () -> PrevSymlink
                              | I44 () -> New))

let prev_to_old = function
  | PrevDir desc ->
      Previous (`DIRECTORY, desc, Os.fullfingerprint_dummy, Osx.ressDummy)
  | PrevFile (desc, fp, _, ress) ->
      Previous (`FILE, desc, fp, ress)
  | PrevSymlink ->
      Previous (`SYMLINK, Props.dummy, Os.fullfingerprint_dummy, Osx.ressDummy)
  | New ->
      New

let prev_of_old = function
  | Previous (`DIRECTORY, desc, _, _) -> PrevDir desc
  | Previous (`FILE, desc, fp, ress) -> PrevFile (desc, fp, NoStamp, ress)
  | Previous (`SYMLINK, _, _, _) -> PrevSymlink
  | Previous (`ABSENT, _, _, _)
  | New -> New

let featPrevState2 = Features.register "prevState2" None

let newPrevStateType () = Features.enabled featPrevState2

let mprevState = Umarshal.(switch newPrevStateType
  mprevState2 id id
  mprevState1 prev_to_old prev_of_old)

type contentschange =
    ContentsSame
  | ContentsUpdated of Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp

let mcontentschange = Umarshal.(sum2 unit (prod3 Os.mfullfingerprint Fileinfo.mstamp Osx.mressStamp id id)
                                  (function
                                   | ContentsSame -> I21 ()
                                   | ContentsUpdated (a, b, c) -> I22 (a, b, c))
                                  (function
                                   | I21 () -> ContentsSame
                                   | I22 (a, b, c) -> ContentsUpdated (a, b, c)))

type permchange     = PropsSame    | PropsUpdated

let mpermchange = Umarshal.(sum2 unit unit
                              (function
                               | PropsSame -> I21 ()
                               | PropsUpdated -> I22 ())
                              (function
                               | I21 () -> PropsSame
                               | I22 () -> PropsUpdated))

type updateItem =
    NoUpdates                         (* Path not changed *)
  | Updates                           (* Path changed in this replica *)
      of updateContent                (*   - new state *)
       * prevState                    (*   - summary of old state *)
  | Error                             (* Error while detecting updates *)
      of string                       (*   - description of error *)

and updateContent =
    Absent                            (* Path refers to nothing *)
  | File                              (* Path refers to an ordinary file *)
      of Props.t                      (*   - summary of current state *)
       * contentschange               (*   - hint to transport agent *)
  | Dir                               (* Path refers to a directory *)
      of Props.t                      (*   - summary of current state *)
       * (Name.t * updateItem) list   (*   - children;
                                             MUST KEEP SORTED for recon *)
       * permchange                   (*   - did permissions change? *)
       * bool                         (*   - is the directory now empty? *)
  | Symlink                           (* Path refers to a symbolic link *)
      of string                       (*   - link text *)

let mupdateItem_rec mupdateContent =
  Umarshal.(sum3 unit (prod2 mupdateContent mprevState id id) string
              (function
               | NoUpdates -> I31 ()
               | Updates (a, b) -> I32 (a, b)
               | Error a -> I33 a)
              (function
               | I31 () -> NoUpdates
               | I32 (a, b) -> Updates (a, b)
               | I33 a -> Error a))

let mupdateContent_rec mupdateItem =
  Umarshal.(sum4
              unit
              (prod2 Props.m mcontentschange id id)
              (prod4 Props.m (list (prod2 Name.m mupdateItem id id)) mpermchange bool id id)
              string
              (function
               | Absent -> I41 ()
               | File (a, b) -> I42 (a, b)
               | Dir (a, b, c, d) -> I43 (a, b, c, d)
               | Symlink a -> I44 a)
              (function
               | I41 () -> Absent
               | I42 (a, b) -> File (a, b)
               | I43 (a, b, c, d) -> Dir (a, b, c, d)
               | I44 a -> Symlink a))

let mupdateContent, mupdateItem =
  Umarshal.rec2 mupdateItem_rec mupdateContent_rec

(* ------------------------------------------------------------------------- *)

type status =
  [ `Deleted
  | `Modified
  | `PropsChanged
  | `Created
  | `MovedOut of Path.t * replicaContent * replicaContent
  | `MovedIn of Path.t * replicaContent * replicaContent
  | `Unchanged ]

and replicaContent =
  { typ : Fileinfo.typ;
    status : status;
    desc : Props.t;                (* Properties (for the UI) *)
    ui : updateItem;
    size : int * Uutil.Filesize.t; (* Number of items and size *)
    props : Props.t list }         (* Parent properties *)

type direction =
    Conflict of string (* The string is the reason of the conflict *)
  | Merge
  | Replica1ToReplica2
  | Replica2ToReplica1

let direction2string = function
    Conflict _ -> "conflict"
  | Merge -> "merge"
  | Replica1ToReplica2 -> "replica1 to replica2"
  | Replica2ToReplica1 -> "replica2 to replica1"

let isConflict = function
    Conflict _ -> true
  | _ -> false

type difference =
  { rc1 : replicaContent;
    rc2 : replicaContent;
    errors1 : string list;
    errors2 : string list;
    mutable direction : direction;
    default_direction : direction }

type replicas =
    Problem of string       (* There was a problem during update detection *)
  | Different of difference (* Replicas differ *)

type reconItem = {path1 : Path.t; path2 : Path.t; replicas : replicas}

let ucLength = function
    File(desc,_)    -> Props.length desc
  | Dir(desc,_,_,_) -> Props.length desc
  | _               -> Uutil.Filesize.zero

let uiLength = function
    Updates(uc,_) -> ucLength uc
  | _             -> Uutil.Filesize.zero

let riAction rc rc' =
  match rc.status, rc'.status with
    `Deleted, _ ->
      `Delete
  | (`Unchanged | `PropsChanged), (`Unchanged | `PropsChanged) ->
      `SetProps
  | _ ->
      `Copy

let rcLength rc rc' =
  if riAction rc rc' = `SetProps then
    Uutil.Filesize.zero
  else
    match rc'.status with
    | `MovedIn _ ->
        (* A move/rename will be reverted, count its size too *)
        Uutil.Filesize.add (snd rc.size) (snd rc'.size)
    | _ ->
        snd rc.size

let riLength ri =
  match ri.replicas with
    Different {rc1 = {status= `Unchanged | `PropsChanged};
               rc2 = {status= `Unchanged | `PropsChanged}} ->
      Uutil.Filesize.zero (* No contents propagated *)
  | Different {rc1 = rc1; rc2 = rc2; direction = dir} ->
      begin match dir with
        Replica1ToReplica2 -> rcLength rc1 rc2
      | Replica2ToReplica1 -> rcLength rc2 rc1
      | Conflict _         -> Uutil.Filesize.zero
      | Merge              -> Uutil.Filesize.zero (* underestimate :-*)
      end
  | _ ->
      Uutil.Filesize.zero

let fileInfos ui1 ui2 =
  match ui1, ui2 with
    (Updates (File (desc1, ContentsUpdated (fp1, _, ress1)),
              PrevFile (desc2, fp2, _, ress2)),
     NoUpdates)
  | (Updates (File (desc1, ContentsUpdated (fp1, _, ress1)),
              PrevFile (desc2, fp2, _, ress2)),
     Updates (File (_, ContentsSame), _))
  | (NoUpdates,
     Updates (File (desc2, ContentsUpdated (fp2, _, ress2)),
              PrevFile (desc1, fp1, _, ress1)))
  | (Updates (File (_, ContentsSame), _),
     Updates (File (desc2, ContentsUpdated (fp2, _, ress2)),
              PrevFile (desc1, fp1, _, ress1)))
  | (Updates (File (desc1, ContentsUpdated (fp1, _, ress1)), _),
     Updates (File (desc2, ContentsUpdated (fp2, _, ress2)), _)) ->
       (desc1, fp1, ress1, desc2, fp2, ress2)
  | _ ->
      raise (Util.Transient "Can't diff")

let problematic ri =
  match ri.replicas with
    Problem _      -> true
  | Different diff -> isConflict diff.direction

let partiallyProblematic ri =
  match ri.replicas with
    Problem _      ->
      true
  | Different diff ->
     isConflict diff.direction || diff.errors1 <> [] || diff.errors2 <> []

let isDeletion ri =
  match ri.replicas with
    Different {rc1 = rc1; rc2 = rc2; direction = rDir} ->
      (match rDir, rc1.typ, rc2.typ with
        Replica1ToReplica2, `ABSENT, _ -> true
      | Replica2ToReplica1, _, `ABSENT -> true
      | _ -> false)
  | _ -> false

let rcType rc = Fileinfo.type2string rc.typ

let riFileType ri =
  match ri.replicas with
    Different {rc1 = rc1; rc2 = rc2; default_direction = dir} ->
      begin match dir with
        Replica2ToReplica1 -> rcType rc2
      | _		   -> rcType rc1
      end
  | _ -> "nonexistent"
