% 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. \darcsCommand{get} \begin{code}

    {-# OPTIONS_GHC -cpp #-}
    {-# LANGUAGE CPP #-}

    module Darcs.Commands.Get ( get, clone ) where

    import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,
                              createDirectory )
    import Workaround ( getCurrentDirectory )
    import Data.Maybe ( isJust )
    import Control.Monad ( when )

    import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putInfo )
    import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy,
                                        UseFormat2, UseOldFashionedInventory, UseHashedInventory,
                                        SetScriptsExecutable, OnePattern ),
                            getContext, getInventoryChoices,
                            partial, reponame,
                            matchOneContext, setDefault, setScriptsExecutableOption, nolinks,
                            networkOptions )
    import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo,
                              createPristineDirectoryTree,
                              tentativelyRemovePatches, patchSetToPatches, patchSetToRepository,
                              copyRepository, tentativelyAddToPending,
                              finalizeRepositoryChanges, setScriptsExecutable
                            , invalidateIndex )
    import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,
                                     RepoProperty ( Darcs2, HashedInventory ), formatHas )
    import Darcs.Repository.DarcsRepo ( write_inventory )
    import qualified Darcs.Repository.DarcsRepo as DR ( read_repo )
    import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches,
                            createRepository)
    import Darcs.Repository.ApplyPatches ( apply_patches )
    import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint )
    import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert,
                         effect, description )
    import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), mapRL, concatRL, reverseRL, lengthFL )
    import Darcs.External ( copyFileOrUrl, Cachable(..) )
    import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag )
    import Darcs.Repository.Prefs ( setDefaultrepo )
    import Darcs.Repository.Motd ( show_motd )
    import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, )
    import Darcs.SignalHandler ( catchInterrupt )
    import Darcs.Commands.Init ( initialize )
    import Darcs.Match ( havePatchsetMatch, getOnePatchset )
    import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError )
    import Progress ( debugMessage )
    import Printer ( text, vcat, errorDoc, ($$) )
    import Darcs.Lock ( writeBinFile )
    import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote)
    import Darcs.Witnesses.Sealed ( Sealed(..), unsafeUnflippedseal )
    import Darcs.Global ( darcsdir )
    import English ( englishNum, Noun(..) )
    #include "impossible.h"

    getDescription :: String
    getDescription = "Create a local copy of a repository."

    getHelp :: String
    getHelp =
     "Get creates a local copy of a repository.  The optional second\n" ++
     "argument specifies a destination directory for the new copy; if\n" ++
     "omitted, it is inferred from the source location.\n" ++
     "\n" ++
     "By default Darcs will copy every patch from the original repository.\n" ++
     "This means the copy is completely independent of the original; you can\n" ++
     "operate on the new repository even when the original is inaccessible.\n" ++
     "If you expect the original repository to remain accessible, you can\n" ++
     "use --lazy to avoid copying patches until they are needed (`copy on\n" ++
     "demand').  This is particularly useful when copying a remote\n" ++
     "repository with a long history that you don't care about.\n" ++
     "\n" ++
     "The --lazy option isn't as useful for local copies, because Darcs will\n" ++
     "automatically use `hard linking' where possible.  As well as saving\n" ++
     "time and space, you can move or delete the original repository without\n" ++
     "affecting a complete, hard-linked copy.  Hard linking requires that\n" ++
     "the copy be on the same filesystem and the original repository, and\n" ++
     "that the filesystem support hard linking.  This includes NTFS, HFS+\n" ++
     "and all general-purpose Unix filesystems (such as ext3, UFS and ZFS).\n" ++
     "FAT does not support hard links.\n" ++
     "\n" ++
     "Darcs get will not copy unrecorded changes to the source repository's\n" ++
     "working tree.\n" ++
     "\n" ++
     getHelpTag ++
     "\n" ++
     -- The remaining help text covers backwards-compatibility options.
     getHelpPartial ++
     "\n" ++
     "A repository created by `darcs get' will be in the best available\n" ++
     "format: it will be able to exchange patches with the source\n" ++
     "repository, but will not be directly readable by Darcs binaries older\n" ++
     "than 2.0.0.  Use the `--old-fashioned-inventory' option if the latter\n" ++
     "is required.\n"

    get :: DarcsCommand
    get = DarcsCommand {commandName = "get",
                        commandHelp = getHelp,
                        commandDescription = getDescription,
                        commandExtraArgs = -1,
                        commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"],
                        commandCommand = getCmd,
                        commandPrereq = contextExists,
                        commandGetArgPossibilities = return [],
                        commandArgdefaults = nodefaults,
                        commandAdvancedOptions = networkOptions ++
                                                   commandAdvancedOptions initialize,
                        commandBasicOptions = [reponame,
                                                partial,
                                                matchOneContext,
                                                setDefault,
                                                setScriptsExecutableOption,
                                                 nolinks,
                                                 getInventoryChoices]}

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

    getCmd :: [DarcsFlag] -> [String] -> IO ()
    getCmd opts [inrepodir, outname] = getCmd (NewRepo outname:opts) [inrepodir]
    getCmd opts [inrepodir] = do
      debugMessage "Starting work on get..."
      typed_repodir <- ioAbsoluteOrRemote inrepodir
      let repodir = toPath typed_repodir
      show_motd opts repodir
      when (Partial `elem` opts) $ debugMessage "Reading checkpoint..."
      rfsource_or_e <- identifyRepoFormat repodir
      rfsource <- case rfsource_or_e of Left e -> fail e
                                        Right x -> return x
      debugMessage $ "Found the format of "++repodir++"..."
      mysimplename <- makeRepoName opts repodir
      createDirectory mysimplename
      setCurrentDirectory mysimplename
      when (formatHas Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $
        putInfo opts $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n"
      let opts' = if formatHas Darcs2 rfsource
                  then UseFormat2:opts
                  else if not (UseOldFashionedInventory `elem` opts)
                       then UseHashedInventory:filter (/= UseFormat2) opts
                       else UseOldFashionedInventory:filter (/= UseFormat2) opts
      createRepository opts'
      debugMessage "Finished initializing new directory."
      setDefaultrepo repodir opts

      rf_or_e <- identifyRepoFormat "."
      rf <- case rf_or_e of Left e -> fail e
                            Right x -> return x
      if formatHas HashedInventory rf -- refactor this into repository
        then writeBinFile (darcsdir++"/hashed_inventory") ""
        else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch)

      if not (null [p | OnePattern p <- opts]) -- --to-match given
         && not (Partial `elem` opts) && not (Lazy `elem` opts)
        then withRepository opts $- \repository -> do
          debugMessage "Using economical get --to-match handling"
          fromrepo <- identifyRepositoryFor  repository repodir
          Sealed patches_to_get <- getOnePatchset fromrepo opts
          patchSetToRepository fromrepo patches_to_get opts
          debugMessage "Finished converting selected patch set to new repository"
        else copyRepoAndGoToChosenVersion opts repodir rfsource rf
    getCmd _ _ = fail "You must provide 'get' with either one or two arguments."

    -- | called by getCmd
    -- assumes that the target repo of the get is the current directory, and that an inventory in the
    -- right format has already been created.
    copyRepoAndGoToChosenVersion :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> IO ()
    copyRepoAndGoToChosenVersion opts repodir rfsource rf = do
      copy_repo `catchInterrupt` (when (formatHas HashedInventory rfsource)
                                       (putInfo opts $ text "Using lazy repository."))
      withRepository opts $- \repository -> goToChosenVersion repository opts
      putInfo opts $ text "Finished getting."
          where copy_repo =
                    withRepository opts $- \repository -> do
                      let hashUs   = formatHas HashedInventory rf
                          hashThem = formatHas HashedInventory rfsource
                      case () of _ | hashUs && hashThem -> do
                                       debugMessage "Identifying and copying repository..."
                                       copyRepoHashed repository
                                   | hashUs -> do
                                       putInfo opts $  text "Converting old-fashioned repository to hashed format..."
                                                   $$ text "*******************************************************************************"
                                                   $$ text "Fetching a hashed repository would be faster.  Perhaps you could persuade"
                                                   $$ text "the maintainer to run darcs optimize --upgrade with darcs 2.4.0 or higher?"
                                                   $$ text "*******************************************************************************"
                                       copyRepoHashed repository
                                   | hashThem -> do
                                       putInfo opts $ text "Fetching a hashed repository as an old-fashioned one..."
                                       copyRepoHashed repository
                                   | otherwise -> copyRepoOldFashioned repository opts repodir
                copyRepoHashed repository =
                  do identifyRepositoryFor repository repodir >>= copyRepository
                     when (SetScriptsExecutable `elem` opts) setScriptsExecutable

    makeRepoName :: [DarcsFlag] -> FilePath -> IO String
    makeRepoName (NewRepo 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
    makeRepoName (_:as) d = makeRepoName as d
    makeRepoName [] d =
      case dropWhile (=='.') $ reverse $
           takeWhile (\c -> c /= '/' && c /= ':') $
           dropWhile (=='/') $ reverse d of
      "" -> modifyRepoName "anonymous_repo"
      base -> modifyRepoName base

    modifyRepoName :: String -> IO String
    modifyRepoName name =
        if head name == '/'
        then mrn name (-1)
        else do cwd <- getCurrentDirectory
                mrn (cwd ++ "/" ++ name) (-1)
     where
      mrn :: String -> Int -> IO String
      mrn n i = do
        exists <- doesDirectoryExist thename
        file_exists <- doesFileExist thename
        if not exists && not file_exists
           then do when (i /= -1) $
                        putStrLn $ "Directory '"++ n ++
                                   "' already exists, creating repository as '"++
                                   thename ++"'"
                   return thename
           else mrn n $ i+1
        where thename = if i == -1 then n else n++"_"++show i

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

    contextExists :: [DarcsFlag] -> IO (Either String ())
    contextExists opts =
       case getContext opts of
         Nothing -> return $ Right ()
         Just f  -> do exists <- doesFileExist $ toFilePath f
                       if exists
                          then return $ Right ()
                          else return . Left $ "Context file "++toFilePath f++" does not exist"

    goToChosenVersion :: RepoPatch p => Repository p
                         -> [DarcsFlag] -> IO ()
    goToChosenVersion repository opts =
        when (havePatchsetMatch opts) $ do
           debugMessage "Going to specified version..."
           patches <- read_repo repository
           Sealed context <- getOnePatchset repository opts
           let (_,us':\/:them') = get_common_and_uncommon (patches, context)
           case them' of
               NilRL -> return ()
               _ -> errorDoc $ text "Missing these patches from context:"
                            $$ (vcat $ mapRL description them')
           let ps = patchSetToPatches (us':<:NilRL)
           putInfo opts $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++
                       (englishNum (lengthFL ps) (Noun "patch") "")
           invalidateIndex repository
           withRepoLock opts $- \_ ->
               do tentativelyRemovePatches repository opts ps
                  tentativelyAddToPending repository opts $ invert $ effect ps
                  finalizeRepositoryChanges repository
                  apply opts (invert $ effect ps) `catch` \e ->
                      fail ("Couldn't undo patch in working dir.\n" ++ show e)

    getHelpPartial :: String
    getHelpPartial =
     "If the source repository is in a legacy darcs-1 format and contains at\n" ++
     "least one checkpoint (see `darcs optimize'), the --partial option will\n" ++
     "create a partial repository.  A partial repository discards history\n" ++
     "from before the checkpoint in order to reduce resource requirements.\n" ++
     "For modern darcs-2 repositories, --partial is a deprecated alias for\n" ++
     "the --lazy option.\n"

    copyRepoOldFashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO ()
    copyRepoOldFashioned repository opts repodir = do
      myname <- getCurrentDirectory
      fromrepo <- identifyRepositoryFor repository repodir
      mch <- get_checkpoint fromrepo
      patches <- read_repo fromrepo
      debugMessage "Getting the inventory..."
      write_inventory "." patches
      debugMessage "Copying patches..."
      copy_oldrepo_patches opts fromrepo "."
      debugMessage "Patches copied"
      Sealed local_patches <- DR.read_repo opts "." :: IO (SealedPatchSet Patch)
      debugMessage "Repo read"
      repo_is_local <- doesDirectoryExist repodir
      debugMessage $ "Repo local: " ++ formatPath (show repo_is_local)
      if repo_is_local && not (Partial `elem` opts)
         then do
           debugMessage "Copying prefs"
           copyFileOrUrl opts
              (repodir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600)
              `catchall` return ()
           debugMessage "Writing working directory"
           createPristineDirectoryTree fromrepo myname
           withCurrentDirectory myname $ do
               -- note: SetScriptsExecutable is normally checked in PatchApply
               -- but darcs get on local repositories does not apply patches
               if SetScriptsExecutable `elem` opts
                  then setScriptsExecutable
                  else return ()
         else do
           setCurrentDirectory myname
           if Partial `elem` opts && isJust mch
              then let Sealed p_ch = fromJust mch
                       pi_ch = patch2patchinfo p_ch
                       needed_patches = reverseRL $ unsafeUnflippedseal $
                                        get_patches_beyond_tag pi_ch local_patches
                       in do write_checkpoint_patch p_ch
                             apply opts p_ch `catch`
                                 \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e)
                             apply_patches opts needed_patches
              else apply_patches opts $ reverseRL $ concatRL local_patches
      debugMessage "Writing the pristine"
      pristine <- identifyPristine
      createPristineFromWorking pristine
      setCurrentDirectory myname

\end{code}