--  Copyright (C) 2002-2005 David Roundy
--
--  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 2, 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; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

module Darcs.UI.Commands.Clone
    ( get
    , put
    , clone
    , makeRepoName
    , cloneToSSH
    , otherHelpInheritDefault
    ) where

import Darcs.Prelude

import System.Directory ( doesDirectoryExist, doesFileExist
                        , setCurrentDirectory )
import System.Exit ( ExitCode(..) )
import System.FilePath.Posix ( joinPath, splitDirectories )
import Control.Monad ( when, unless )

import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts
                      , nodefaults
                      , commandStub
                      , commandAlias
                      , putInfo
                      , putFinished
                      )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( DarcsFlag
    , cloneKind
    , fixUrl
    , patchIndexNo
    , quiet
    , setDefault
    , setScriptsExecutable
    , umask
    , useCache
    , usePacks
    , verbosity
    , withNewRepo
    , withWorkingDir
    )
import Darcs.UI.Options ( (?), (^) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands.Util
    ( commonHelpWithPrefsTemplates
    , getUniqueRepositoryName
    )
import Darcs.Patch.Match ( MatchFlag(..) )
import Darcs.Repository ( cloneRepository )
import Darcs.Repository.Format ( identifyRepoFormat
                               , RepoProperty ( HashedInventory
                                              , RebaseInProgress
                                              )
                               , formatHas
                               )
import Darcs.Util.Lock ( withTempDir )
import Darcs.Util.Ssh ( getSSH, SSHCmd(SCP,SSH) )
import Darcs.Repository.Flags
    ( CloneKind(CompleteClone), SetDefault(NoSetDefault), ForgetParent(..) )
import Darcs.Repository.Prefs ( showMotd )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Printer ( Doc, formatWords, formatText, text, vsep, ($$), ($+$) )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Workaround ( getCurrentDirectory )
import Darcs.Util.URL ( SshFilePath(..), isSshUrl, splitSshUrl, sshCanonRepo )
import Darcs.Util.Exec ( exec, Redirect(..), )

cloneDescription :: String
cloneDescription = "Make a copy of an existing repository."

cloneHelp :: Doc
cloneHelp = vsep $
  map formatWords
  [ [ "Clone creates a copy of a repository.  The optional second"
    , "argument specifies a destination directory for the new copy;"
    , "if omitted, it is inferred from the source location."
    ]
  , [ "By default Darcs will copy every patch from the original repository."
    , "If you expect the original repository to remain accessible, you can"
    , "use `--lazy` to avoid copying patches until they are needed ('copy on"
    , "demand').  This is particularly useful when copying a remote"
    , "repository with a long history that you don't care about."
    ]
  , [ "When cloning locally, Darcs automatically uses hard linking where"
    , "possible.  As well as saving time and space, this enables to move or"
    , "delete the original repository without affecting the copy."
    , "Hard linking requires that the copy be on the same filesystem as the"
    , "original repository, and that the filesystem support hard linking."
    , "This includes NTFS, HFS+ and all general-purpose Unix filesystems"
    , "(such as ext, UFS and ZFS). FAT does not support hard links."
    ]
  , [ "When cloning from a remote location, Darcs will look for and attempt"
    , "to use packs created by `darcs optimize http` in the remote repository."
    , "Packs are single big files that can be downloaded faster than many"
    , "little files."
    ]
  , [ "Darcs clone will not copy unrecorded changes to the source repository's"
    , "working tree."
    ]
  , [ "You can copy a repository to a ssh url, in which case the new repository"
    , "will always be complete."
    ]
  ]
  ++
  [ cloneHelpTag
  , cloneHelpSSE
  , cloneHelpInheritDefault
  , commonHelpWithPrefsTemplates
  ]

clone :: DarcsCommand
clone = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "clone"
    , commandHelp = cloneHelp
    , commandDescription = cloneDescription
    , commandExtraArgs = -1
    , commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"]
    , commandCommand = cloneCmd
    , commandPrereq = \_ -> return $ Right ()
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandOptions = cloneOpts
    }
  where
    cloneBasicOpts
      = O.newRepo
      ^ O.cloneKind
      ^ O.matchOneContext
      ^ O.setDefault
      ^ O.inheritDefault
      ^ O.setScriptsExecutable
      ^ O.withWorkingDir
    cloneAdvancedOpts
      = O.usePacks
      ^ O.patchIndexNo
      ^ O.umask
      ^ O.remoteDarcs
      ^ O.withPrefsTemplates
    cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts

get :: DarcsCommand
get = commandAlias "get" Nothing clone

putDescription :: String
putDescription = "Deprecated command, replaced by clone."

putHelp :: Doc
putHelp = formatText 80
 [ "This command is deprecated."
 , "To clone the current repository to a ssh destination, " ++
   "use the syntax `darcs clone . user@server:path` ."
 ]

put :: DarcsCommand
put = commandStub "put" putHelp putDescription clone

cloneCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
cloneCmd fps opts [inrepodir, outname] = cloneCmd fps (withNewRepo outname opts) [inrepodir]
cloneCmd (_,o) opts [inrepodir] = do
  debugMessage "Starting work on clone..."
  repodir <- fixUrl o inrepodir
  unless (quiet opts) $ showMotd repodir
  rfsource <- identifyRepoFormat repodir
  debugMessage $ "Found the format of "++repodir++"..."

  -- This merely forbids clone from an old-style rebase in progress, which is
  -- exactly what we want. Transferring patches from repos with new-style
  -- rebase in progress is unproblematic and fully supported.
  when (formatHas RebaseInProgress rfsource) $
      fail "Cannot clone a repository with an old-style rebase in progress"

  unless (formatHas HashedInventory rfsource) $ putInfo opts $
       text "***********************************************************************"
    $$ text "  _______   Sorry for the wait! The repository you are cloning is"
    $$ text " |       |  using the DEPRECATED 'old-fashioned' format. I'm doing a"
    $$ text " | O   O |  hashed copy instead, but this may take a while."
    $$ text " |  ___  |"
    $$ text " | /   \\ |  We recommend that the maintainer upgrade the remote copy"
    $$ text " |_______|  as well. See http://wiki.darcs.net/OF for more information."
    $$ text ""
    $$ text "***********************************************************************"

  case cloneToSSH opts of
    Just repo -> do
      withTempDir "clone" $ \_ -> do
         prepareRemoteDir repo
         putInfo opts $ text "Creating local clone..."
         currentDir <- getCurrentDirectory
         mysimplename <- makeRepoName True [] repodir -- give correct name to local clone
         cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts)
                         CompleteClone (umask ? opts) (O.remoteDarcs ? opts)
                         (setScriptsExecutable ? opts)
                         (NoSetDefault True)
                         O.NoInheritDefault -- never inherit defaultrepo when cloning to ssh
                         (map convertUpToToOne (O.matchOneContext ? opts))
                         rfsource
                         (withWorkingDir ? opts)
                         (patchIndexNo ? opts)
                         (usePacks ? opts)
                         YesForgetParent
                         (O.withPrefsTemplates ? opts)
         setCurrentDirectory currentDir
         (scp, args) <- getSSH SCP
         putInfo opts $ text $ "Transferring clone using " ++ scp ++ "..."
         -- This has the precondition that the last part of 'repo' does not
         -- exist on the remote host, but all its parent directories do,
         -- which is ensured by 'prepareRemoteDir'.
         -- Note that adding the trailing slash to the source is essential
         -- in order to allow DARCS_SCP=rsync to work the same way as scp.
         r <- exec scp (args ++ ["-r", mysimplename ++ "/", repo]) (AsIs,AsIs,AsIs)
         when (r /= ExitSuccess) $ fail $ "Problem during " ++ scp ++ " transfer."
         putInfo opts $ text "Cloning and transferring successful."
    Nothing -> do
      mysimplename <- makeRepoName True opts repodir
      cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts)
                  (cloneKind ? opts) (umask ? opts) (O.remoteDarcs ? opts)
                  (setScriptsExecutable ? opts)
                  (setDefault True opts)
                  (O.inheritDefault ? opts)
                  (map convertUpToToOne (O.matchOneContext ? opts))
                  rfsource
                  (withWorkingDir ? opts)
                  (patchIndexNo ? opts)
                  (usePacks ? opts)
                  NoForgetParent
                  (O.withPrefsTemplates ? opts)
      putFinished opts "cloning"

cloneCmd _ _ _ = fail "You must provide 'clone' with either one or two arguments."

cloneToSSH :: [DarcsFlag] -> Maybe String
cloneToSSH fs = case O.newRepo ? fs of
  Nothing -> Nothing
  Just r -> if isSshUrl r then Just (sshCanonRepo $ splitSshUrl r) else Nothing

mkRemoteDirectory :: Bool -> String -> FilePath -> IO ()
mkRemoteDirectory recursive sshUhost path = do
  (ssh, ssh_args) <- getSSH SSH
  let ssh_cmd = "mkdir " ++ (if recursive then "-p " else "") ++  "'" ++ path ++ "'"
  r <- exec ssh (ssh_args ++ [sshUhost, ssh_cmd]) (AsIs,AsIs,AsIs)
  when (r /= ExitSuccess) $
    fail $ "Cannot create remote directory '"  ++ path ++ "'."

rmRemoteDirectory :: String -> FilePath -> IO ()
rmRemoteDirectory sshUhost path = do
  (ssh, ssh_args) <- getSSH SSH
  let ssh_cmd = "rmdir '" ++ path ++ "'"
  r <- exec ssh (ssh_args ++ [sshUhost, ssh_cmd]) (AsIs,AsIs,AsIs)
  when (r /= ExitSuccess) $
    fail $ "Cannot remove remote directory '"  ++ path ++ "'."

-- | Make sure that the remote directory does not exist, but all its
-- parent directories do.
prepareRemoteDir :: String -> IO ()
prepareRemoteDir rpath = do
  let sshfp = splitSshUrl rpath
  let sshRepoParent = if length sshPathParts > 1 then joinPath (init sshPathParts) else []
        where
          sshPathParts = splitDirectories (sshRepo sshfp)

  unless (null sshRepoParent) $ mkRemoteDirectory True (sshUhost sshfp) sshRepoParent
  mkRemoteDirectory False (sshUhost sshfp) (sshRepo sshfp)
  rmRemoteDirectory (sshUhost sshfp) (sshRepo sshfp)

makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String
makeRepoName talkative fs d =
  case O.newRepo ? fs of
    Just n -> do
      exists <- doesDirectoryExist n
      file_exists <- doesFileExist n
      if exists || file_exists
        then fail $ "Directory or file named '" ++ n ++ "' already exists."
        else return n
    Nothing ->
      case mkName d of
        "" -> getUniqueRepositoryName talkative "anonymous_repo"
        base@('/':_) -> getUniqueRepositoryName talkative base -- Absolute
        base -- Relative
         -> do
          cwd <- getCurrentDirectory
          getUniqueRepositoryName talkative (cwd ++ "/" ++ base)
      where mkName = dropWhile (== '.') . reverse .
              takeWhile (not . (`elem` "/:")) . dropWhile (== '/') . reverse

cloneHelpTag :: Doc
cloneHelpTag = formatWords
  [ ""
  , "It is often desirable to make a copy of a repository that excludes"
  , "some patches.  For example, if releases are tagged then `darcs clone"
  , "--tag .` would make a copy of the repository as at the latest release."
  , ""
  , "An untagged repository state can still be identified unambiguously by"
  , "a context file, as generated by `darcs log --context`.  Given the"
  , "name of such a file, the `--context` option will create a repository"
  , "that includes only the patches from that context.  When a user reports"
  , "a bug in an unreleased version of your project, the recommended way to"
  , "find out exactly what version they were running is to have them" 
  , "include a context file in the bug report."
  , ""
  , "You can also make a copy of an untagged state using the `--to-patch` or"
  , "`--to-match` options, which exclude patches *after* the first matching"
  , "patch.  Because these options treat the set of patches as an ordered"
  , "sequence, you may get different results after reordering with `darcs"
  , "optimize reorder`."
  ]

cloneHelpSSE :: Doc
cloneHelpSSE = formatWords
  [ "The `--set-scripts-executable` option causes scripts to be made"
  , "executable in the working tree. A script is any file that starts"
  , "with a shebang (\"#!\")."
  ]

cloneHelpInheritDefault :: Doc
cloneHelpInheritDefault = commonHelpInheritDefault $+$ formatWords
  [ "For the clone command it means the following:"
  , "If the source repository already has a defaultrepo set (either because"
  , "you cloned it or because you explicitly used the --set-default option),"
  , "and both source and target are locally valid paths on the same host,"
  , "then the target repo will get the same defaultrepo as the source repo."
  , "Otherwise the target repo gets the source repo itself as defaultrepo,"
  , "i.e. we fall back to the defalt behavior (--no-inherit-default)."
  ]

otherHelpInheritDefault :: Doc
otherHelpInheritDefault = commonHelpInheritDefault $+$ formatWords
  [ "For the commands push, pull, and send it means the following:"
  , "Changes the meaning of the --set-default option so that it sets the"
  , "(local) defaultrepo to the defaultrepo of the remote repo, instead of"
  , "the remote repo itself. This happens only if the remote repo does have"
  , "a defaultrepo set and both local and remote repositories are locally"
  , "valid paths on the same host, otherwise fall back to the default behavior"
  , "(--no-inherit-default)."
  ]

commonHelpInheritDefault :: Doc
commonHelpInheritDefault = formatWords
  [ "The --inherit-default option is meant to support a work flow where"
  , "you have different branches of the same upstream repository and want"
  , "all your branches to have the same upstream repo as the defaultrepo."
  , "It is most useful when enabled globally by adding 'ALL --inherit-default'"
  , "to your ~/darcs/defaults file."
  ]

-- | The 'clone' command takes --to-patch and --to-match as arguments,
-- but internally wants to handle them as if they were --patch and --match.
-- This function does the conversion.
convertUpToToOne :: MatchFlag -> MatchFlag
convertUpToToOne (UpToPattern p) = OnePattern p
convertUpToToOne (UpToPatch p) = OnePatch p
convertUpToToOne (UpToHash p) = OneHash p
convertUpToToOne f = f
