Get.lhs

%  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, command_alias )
import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy,
                                    UseFormat2, UseOldFashionedInventory, UseHashedInventory,
                                    SetScriptsExecutable, Quiet, OnePattern ),
                        get_context, get_inventory_choices,
                        partial, reponame,
                        match_one_context, set_default, set_scripts_executable, nolinks,
                        network_options )
import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo,
                          createPristineDirectoryTree,
                          tentativelyRemovePatches, patchSetToPatches, patchSetToRepository,
                          copyRepository, tentativelyAddToPending,
                          finalizeRepositoryChanges, sync_repo, setScriptsExecutable )
import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,
                                 RepoProperty ( Darcs2, HashedInventory ), format_has )
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.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, 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 ( set_defaultrepo )
import Darcs.Repository.Motd ( show_motd )
import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, )
import Darcs.SignalHandler ( catchInterrupt )
import Darcs.Commands.Init ( initialize )
import Darcs.Match ( have_patchset_match, get_one_patchset )
import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError )
import Progress ( debugMessage )
import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, )
import Darcs.Lock ( writeBinFile )
import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote)
import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )
import Darcs.Global ( darcsdir )
import English ( englishNum, Noun(..) )
import Darcs.Gorsvet( invalidateIndex )
#include "impossible.h"

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

get_help :: String
get_help =
 "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" ++
 get_help_tag ++
 "\n" ++
 -- The remaining help text covers backwards-compatibility options.
 get_help_partial ++
 "\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 {command_name = "get",
                    command_help = get_help,
                    command_description = get_description,
                    command_extra_args = -1,
                    command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],
                    command_command = get_cmd,
                    command_prereq = contextExists,
                    command_get_arg_possibilities = return [],
                    command_argdefaults = nodefaults,
                    command_advanced_options = network_options ++
                                               command_advanced_options initialize,
                    command_basic_options = [reponame,
                                            partial,
                                            match_one_context,
                                            set_default,
                                            set_scripts_executable,
                                             nolinks,
                                             get_inventory_choices]}

clone :: DarcsCommand
clone = command_alias "clone" get

get_cmd :: [DarcsFlag] -> [String] -> IO ()
get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir]
get_cmd 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 <- make_repo_name opts repodir
  createDirectory mysimplename
  setCurrentDirectory mysimplename
  when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $
    putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n"
  let opts' = if format_has 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."
  set_defaultrepo repodir opts

  rf_or_e <- identifyRepoFormat "."
  rf <- case rf_or_e of Left e -> fail e
                        Right x -> return x
  if format_has 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 <- get_one_patchset fromrepo opts
      patchSetToRepository fromrepo patches_to_get opts
      debugMessage "Finished converting selected patch set to new repository"
    else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo
        where am_informative = not $ Quiet `elem` opts
              putInfo s = when am_informative $ putDocLn s

get_cmd _ _ = fail "You must provide 'get' with either one or two arguments."

-- | called by get_cmd
-- assumes that the target repo of the get is the current directory, and that an inventory in the
-- right format has already been created.
copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO ()
copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do
  copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.")
  withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts
  putInfo $ text "Finished getting."
      where copy_repo =
                withRepository opts $- \repository -> do
                  if format_has HashedInventory rf || format_has HashedInventory rfsource
                     then do debugMessage "Identifying and copying repository..."
                             identifyRepositoryFor repository repodir >>= copyRepository
                             when (SetScriptsExecutable `elem` opts) setScriptsExecutable
                     else copy_repo_old_fashioned repository opts repodir

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

modify_repo_name :: String -> IO String
modify_repo_name 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

get_help_tag :: String
get_help_tag =
 "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 get_context 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"

go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ())
                     -> [DarcsFlag] -> IO ()
go_to_chosen_version repository putInfo opts =
    when (have_patchset_match opts) $ do
       debugMessage "Going to specified version..."
       patches <- read_repo repository
       Sealed context <- get_one_patchset repository opts
       let (_,us':\/:them') = get_common_and_uncommon (patches, context)
       case them' of
           NilRL:<:NilRL -> return ()
           _ -> errorDoc $ text "Missing these patches from context:"
                        $$ (vcat $ mapRL description $ head $ unsafeUnRL them')
       let ps = patchSetToPatches us'
       putInfo $ 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)
              sync_repo repository


get_help_partial :: String
get_help_partial =
 "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"

copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO ()
copy_repo_old_fashioned 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 $ concatRL $ 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
  debugMessage "Syncing the repository..."
  sync_repo repository
  debugMessage "Repository synced."

\end{code}