src/Darcs/Commands/Get.lhs

   1 %  Copyright (C) 2002-2005 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18 \subsection{darcs get}
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 module Darcs.Commands.Get ( get ) where
  24
  25 import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,
  26                           createDirectory )
  27 import Workaround ( getCurrentDirectory )
  28 import Data.Maybe ( isJust )
  29 import Control.Monad ( when )
  30
  31 import Darcs.Commands ( DarcsCommand(..), nodefaults )
  32 import Darcs.Arguments ( DarcsFlag( WorkDir, Partial, Lazy,
  33                                     UseFormat2, UseOldFashionedInventory, UseHashedInventory,
  34                                     SetScriptsExecutable, Quiet, OnePattern ),
  35                         get_context, pristine_tree, get_inventory_choices, working_repo_dir,
  36                         partial, reponame,
  37                         match_one_context, set_default, set_scripts_executable, nolinks,
  38                         network_options )
  39 import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo,
  40                           createPristineDirectoryTree,
  41                           tentativelyRemovePatches, patchSetToPatches, patchSetToRepository,
  42                           copyRepository, tentativelyAddToPending,
  43                           finalizeRepositoryChanges, sync_repo, setScriptsExecutable )
  44 import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,
  45                                  RepoProperty ( Darcs2, HashedInventory ), format_has )
  46 import Darcs.Repository.DarcsRepo ( write_inventory )
  47 import qualified Darcs.Repository.DarcsRepo as DR ( read_repo )
  48 import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches )
  49 import Darcs.Repository.ApplyPatches ( apply_patches )
  50 import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint )
  51 import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert,
  52                      effect, description )
  53 import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, mapRL, concatRL, reverseRL, lengthFL )
  54 import Darcs.External ( copyFileOrUrl, Cachable(..) )
  55 import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag )
  56 import Darcs.Repository.Prefs ( set_defaultrepo )
  57 import Darcs.Repository.Motd ( show_motd )
  58 import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, )
  59 import Darcs.SignalHandler ( catchInterrupt )
  60 import Darcs.Commands.Init ( initialize )
  61 import Darcs.Match ( have_patchset_match, get_one_patchset )
  62 import Darcs.Utils ( catchall, formatPath, withCurrentDirectory )
  63 import Darcs.Progress ( debugMessage )
  64 import Darcs.FilePathUtils ( absolute_dir )
  65 import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, )
  66 import Darcs.Lock ( writeBinFile )
  67 import Darcs.RepoPath ( toFilePath )
  68 import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )
  69 import Darcs.Global ( darcsdir )
  70 #include "impossible.h"
  71 \end{code}
  72 \begin{code}
  73 get_description :: String
  74 get_description =
  75  "Create a local copy of another repository."
  76 \end{code}
  77
  78 \options{get}
  79
  80 If the remote repository and the current directory are in the same filesystem and
  81 that filesystem supports hard links, get will create hard links for the
  82 patch files, which means that the additional storage space needed will be
  83 minimal.  This is \emph{very} good for your disk usage (and for the speed
  84 of running get), so if you want multiple copies of a repository, I strongly
  85 recommend first running \verb!darcs get! to get yourself one copy, and then
  86 running \verb!darcs get! on that copy to make any more you like.  The only
  87 catch is that the first time you run \verb!darcs push! or \verb!darcs pull!
  88 from any of these second copies, by default they will access your first
  89 copy---which may not be what you want.
  90
  91 You may specify the name of the repository created by providing a second
  92 argument to get, which is a directory name.
  93
  94 \begin{code}
  95 get_help :: String
  96 get_help =
  97  "Get is used to get a local copy of a repository.\n"
  98 \end{code}
  99 \begin{code}
 100 get :: DarcsCommand
 101 get = DarcsCommand {command_name = "get",
 102                     command_help = get_help,
 103                     command_description = get_description,
 104                     command_extra_args = -1,
 105                     command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],
 106                     command_command = get_cmd,
 107                     command_prereq = contextExists,
 108                     command_get_arg_possibilities = return [],
 109                     command_argdefaults = nodefaults,
 110                     command_advanced_options = network_options ++
 111                                                command_advanced_options initialize,
 112                     command_basic_options = [reponame,
 113                                             partial,
 114                                             match_one_context,
 115                                             set_default,
 116                                             set_scripts_executable,
 117                                             nolinks, pristine_tree,
 118                                              get_inventory_choices,
 119                                              working_repo_dir]}
 120 \end{code}
 121 \begin{code}
 122 get_cmd :: [DarcsFlag] -> [String] -> IO ()
 123 get_cmd opts [inrepodir, outname] = get_cmd (WorkDir outname:opts) [inrepodir]
 124 get_cmd opts [inrepodir] = do
 125   debugMessage "Starting work on get..."
 126   repodir <- absolute_dir inrepodir
 127   show_motd opts repodir
 128   when (Partial `elem` opts) $ debugMessage "Reading checkpoint..."
 129   mysimplename <- make_repo_name opts repodir
 130   rfsource_or_e <- identifyRepoFormat repodir
 131   rfsource <- case rfsource_or_e of Left e -> fail e
 132                                     Right x -> return x
 133   debugMessage $ "Found the format of "++repodir++"..."
 134   createDirectory mysimplename
 135   setCurrentDirectory mysimplename
 136   when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $
 137     putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n"
 138   let opts' = if format_has Darcs2 rfsource
 139               then UseFormat2:opts
 140               else if format_has HashedInventory rfsource &&
 141                       not (UseOldFashionedInventory `elem` opts)
 142                    then UseHashedInventory:filter (/= UseFormat2) opts
 143                    else UseOldFashionedInventory:filter (/= UseFormat2) opts
 144   (command_command initialize) opts' []
 145   debugMessage "Finished initializing new directory."
 146   set_defaultrepo repodir opts
 147
 148   rf_or_e <- identifyRepoFormat "."
 149   rf <- case rf_or_e of Left e -> fail e
 150                         Right x -> return x
 151   if format_has HashedInventory rf -- refactor this into repository
 152     then writeBinFile (darcsdir++"/hashed_inventory") ""
 153     else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch)
 154
 155   if not (null [p | OnePattern p <- opts]) -- --to-match given
 156      && not (Partial `elem` opts) && not (Lazy `elem` opts)
 157     then withRepository opts $- \repository -> do
 158       debugMessage "Using economical get --to-match handling"
 159       fromrepo <- identifyRepositoryFor  repository repodir
 160       Sealed patches_to_get <- get_one_patchset fromrepo opts
 161       patchSetToRepository fromrepo patches_to_get opts
 162       debugMessage "Finished converting selected patch set to new repository"
 163     else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo
 164         where am_informative = not $ Quiet `elem` opts
 165               putInfo s = when am_informative $ putDocLn s
 166
 167 get_cmd _ _ = fail "You must provide 'get' with either one or two arguments."
 168
 169 -- called by get_cmd
 170 -- assumes that the target repo of the get is the current directory, and that an inventory in the
 171 -- right format has already been created.
 172 copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO ()
 173 copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do
 174   copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.")
 175   withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts
 176   putInfo $ text "Finished getting."
 177       where copy_repo =
 178                 withRepository opts $- \repository -> do
 179                   if format_has HashedInventory rf || format_has HashedInventory rfsource
 180                      then do debugMessage "Identifying and copying repository..."
 181                              identifyRepositoryFor repository repodir >>= copyRepository
 182                              when (SetScriptsExecutable `elem` opts) setScriptsExecutable
 183                      else copy_repo_old_fashioned repository opts repodir
 184
 185 \end{code}
 186
 187 \begin{code}
 188 make_repo_name :: [DarcsFlag] -> FilePath -> IO String
 189 make_repo_name (WorkDir n:_) _ =
 190     do exists <- doesDirectoryExist n
 191        file_exists <- doesFileExist n
 192        if exists || file_exists
 193           then fail $ "Directory or file named '" ++ n ++ "' already exists."
 194           else return n
 195 make_repo_name (_:as) d = make_repo_name as d
 196 make_repo_name [] d =
 197   case dropWhile (=='.') $ reverse $
 198        takeWhile (\c -> c /= '/' && c /= ':') $
 199        dropWhile (=='/') $ reverse d of
 200   "" -> modify_repo_name "anonymous_repo"
 201   base -> modify_repo_name base
 202
 203 modify_repo_name :: String -> IO String
 204 modify_repo_name name =
 205     if head name == '/'
 206     then mrn name (-1)
 207     else do cwd <- getCurrentDirectory
 208             mrn (cwd ++ "/" ++ name) (-1)
 209  where
 210   mrn :: String -> Int -> IO String
 211   mrn n i = do
 212     exists <- doesDirectoryExist thename
 213     file_exists <- doesFileExist thename
 214     if not exists && not file_exists
 215        then do when (i /= -1) $
 216                     putStrLn $ "Directory '"++ n ++
 217                                "' already exists, creating repository as '"++
 218                                thename ++"'"
 219                return thename
 220        else mrn n $ i+1
 221     where thename = if i == -1 then n else n++"_"++show i
 222 \end{code}
 223
 224 \begin{options}
 225 --context, --tag, --to-patch, --to-match
 226 \end{options}
 227 If you want to get a specific version of a repository, you have a few
 228 options.  You can either use the \verb!--tag!, \verb!--to-patch! or
 229 \verb!--to-match! options, or you can use the \verb!--context=FILENAME!
 230 option, which specifies a file containing a context generated with
 231 \verb!darcs changes --context!.  This allows you (for example) to include in
 232 your compiled program an option to output the precise version of the
 233 repository from which it was generated, and then perhaps ask users to
 234 include this information in bug reports.
 235
 236 Note that when specifying \verb!--to-patch! or \verb!--to-match!, you may
 237 get a version of your code that has never before been seen, if the patches
 238 have gotten themselves reordered.  If you ever want to be able to precisely
 239 reproduce a given version, you need either to tag it or create a context
 240 file.
 241
 242 \begin{code}
 243 contextExists :: [DarcsFlag] -> IO (Either String ())
 244 contextExists opts =
 245    case get_context opts of
 246      Nothing -> return $ Right ()
 247      Just f  -> do exists <- doesFileExist $ toFilePath f
 248                    if exists
 249                       then return $ Right ()
 250                       else return . Left $ "Context file "++toFilePath f++" does not exist"
 251
 252 go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ())
 253                      -> [DarcsFlag] -> IO ()
 254 go_to_chosen_version repository putInfo opts =
 255     when (have_patchset_match opts) $ do
 256        debugMessage "Going to specified version..."
 257        patches <- read_repo repository
 258        Sealed context <- get_one_patchset repository opts
 259        let (_,us':\/:them') = get_common_and_uncommon (patches, context)
 260        case them' of
 261            NilRL:<:NilRL -> return ()
 262            _ -> errorDoc $ text "Missing these patches from context:"
 263                         $$ (vcat $ mapRL description $ head $ unsafeUnRL them')
 264        let ps = patchSetToPatches us'
 265        putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " ++
 266                    (patch_or_patches $ lengthFL ps)
 267        withRepoLock opts $- \_ ->
 268            do tentativelyRemovePatches repository opts ps
 269               tentativelyAddToPending repository opts $ invert $ effect ps
 270               finalizeRepositoryChanges repository
 271               apply opts (invert $ effect ps) `catch` \e ->
 272                   fail ("Couldn't undo patch in working dir.\n" ++ show e)
 273               sync_repo repository
 274
 275 patch_or_patches :: Int -> String
 276 patch_or_patches 1 = "patch."
 277 patch_or_patches _ = "patches."
 278
 279 \end{code}
 280
 281 \begin{options}
 282 --partial
 283 \end{options}
 284 Only get the patches since the last checkpoint. This will save time,
 285 bandwidth and disk space, at the expense of losing the history before
 286 the checkpoint.
 287
 288 \begin{options}
 289 --no-pristine-tree
 290 \end{options}
 291 In order to save disk space, you can use {\tt get} with the
 292 \verb|--no-pristine-tree| flag to create a repository with no pristine
 293 tree.  Please see Section~\ref{disk-usage} for more information.
 294
 295
 296 \begin{code}
 297
 298 copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO ()
 299 copy_repo_old_fashioned repository opts repodir = do
 300   myname <- getCurrentDirectory
 301   fromrepo <- identifyRepositoryFor repository repodir
 302   mch <- get_checkpoint fromrepo
 303   patches <- read_repo fromrepo
 304   debugMessage "Getting the inventory..."
 305   write_inventory "." patches
 306   debugMessage "Copying patches..."
 307   copy_oldrepo_patches opts fromrepo "."
 308   debugMessage "Patches copied"
 309   Sealed local_patches <- DR.read_repo opts "." :: IO (SealedPatchSet Patch)
 310   debugMessage "Repo read"
 311   repo_is_local <- doesDirectoryExist repodir
 312   debugMessage $ "Repo local: " ++ formatPath (show repo_is_local)
 313   if repo_is_local && not (Partial `elem` opts)
 314      then do
 315        debugMessage "Copying prefs"
 316        copyFileOrUrl opts
 317           (repodir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600)
 318           `catchall` return ()
 319        debugMessage "Writing working directory"
 320        createPristineDirectoryTree fromrepo myname
 321        withCurrentDirectory myname $ do
 322            -- note: SetScriptsExecutable is normally checked in PatchApply
 323            -- but darcs get on local repositories does not apply patches
 324            if SetScriptsExecutable `elem` opts
 325               then setScriptsExecutable
 326               else return ()
 327      else do
 328        setCurrentDirectory myname
 329        if Partial `elem` opts && isJust mch
 330           then let Sealed p_ch = fromJust mch
 331                    pi_ch = patch2patchinfo p_ch
 332                    needed_patches = reverseRL $ concatRL $ unsafeUnflippedseal $
 333                                     get_patches_beyond_tag pi_ch local_patches
 334                    in do write_checkpoint_patch p_ch
 335                          apply opts p_ch `catch`
 336                              \e -> fail ("Bad checkpoint!\n" ++ show e)
 337                          apply_patches opts needed_patches
 338           else apply_patches opts $ reverseRL $ concatRL local_patches
 339   debugMessage "Writing the pristine"
 340   pristine <- identifyPristine
 341   createPristineFromWorking pristine
 342   setCurrentDirectory myname
 343   debugMessage "Syncing the repository..."
 344   sync_repo repository
 345   debugMessage "Repository synced."
 346
 347 \end{code}