src/Darcs/Repository.lhs

   1 %  Copyright (C) 2002-2004 David Roundy
   2 %  Copyright (C) 2005 Juliusz Chroboczek
   3 %
   4 %  This program is free software; you can redistribute it and/or modify
   5 %  it under the terms of the GNU General Public License as published by
   6 %  the Free Software Foundation; either version 2, or (at your option)
   7 %  any later version.
   8 %
   9 %  This program is distributed in the hope that it will be useful,
  10 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 %  GNU General Public License for more details.
  13 %
  14 %  You should have received a copy of the GNU General Public License
  15 %  along with this program; see the file COPYING.  If not, write to
  16 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  17 %  Boston, MA 02110-1301, USA.
  18
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
  21 {-# LANGUAGE CPP, ScopedTypeVariables #-}
  22
  23 #include "gadts.h"
  24
  25 module Darcs.Repository ( Repository, ($-), maybeIdentifyRepository,
  26                           identifyRepositoryFor,
  27                           withRepoLock, withRepoReadLock,
  28                           withRepository, withRepositoryDirectory, withGutsOf,
  29                           makePatchLazy, writePatchSet,
  30                     findRepository, amInRepository, amNotInRepository,
  31                     slurp_pending, replacePristine, replacePristineFromSlurpy,
  32                     slurp_recorded, slurp_recorded_and_unrecorded,
  33                     withRecorded,
  34                     get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
  35                     read_repo, sync_repo,
  36                     prefsUrl,
  37                     add_to_pending,
  38                     tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
  39                     tentativelyReplacePatches,
  40                     tentativelyMergePatches, considerMergeToWorking,
  41                     revertRepositoryChanges, finalizeRepositoryChanges,
  42                           createRepository, copyRepository, copy_oldrepo_patches,
  43                     patchSetToRepository,
  44                     unrevertUrl,
  45                     applyToWorking, patchSetToPatches,
  46                     createPristineDirectoryTree, createPartialsPristineDirectoryTree,
  47                     optimizeInventory, cleanRepository, checkPristineAgainstCwd,
  48                     checkPristineAgainstSlurpy, getMarkedupFile,
  49                     PatchSet, SealedPatchSet, PatchInfoAnd,
  50                     setScriptsExecutable,
  51                     checkUnrelatedRepos,
  52                     testTentative
  53                   ) where
  54
  55 import System.Exit ( ExitCode(..), exitWith )
  56
  57 import Darcs.Repository.Internal
  58     (Repository(..), RepoType(..), ($-), pristineFromWorking,
  59      maybeIdentifyRepository, identifyRepositoryFor,
  60      findRepository, amInRepository, amNotInRepository,
  61      makePatchLazy,
  62      slurp_pending, replacePristine, replacePristineFromSlurpy,
  63      slurp_recorded, slurp_recorded_and_unrecorded,
  64      withRecorded,
  65      get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
  66      read_repo, sync_repo,
  67      prefsUrl, checkPristineAgainstCwd, checkPristineAgainstSlurpy,
  68      add_to_pending,
  69      withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,
  70      tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
  71      tentativelyReplacePatches,
  72      tentativelyMergePatches, considerMergeToWorking,
  73      revertRepositoryChanges, finalizeRepositoryChanges,
  74      unrevertUrl,
  75      applyToWorking, patchSetToPatches,
  76      createPristineDirectoryTree, createPartialsPristineDirectoryTree,
  77      optimizeInventory, cleanRepository,
  78      getMarkedupFile,
  79      setScriptsExecutable,
  80      testTentative
  81     )
  82 import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) )
  83 import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
  84
  85 import Control.Monad ( unless, when )
  86 import Data.Either(Either(..))
  87 import System.Directory ( createDirectory )
  88 import System.IO.Error ( isAlreadyExistsError )
  89
  90 import qualified Darcs.Repository.DarcsRepo as DarcsRepo
  91 import qualified Darcs.Repository.HashedRepo as HashedRepo
  92
  93 import Darcs.Hopefully ( PatchInfoAnd, info, extractHash )
  94 import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint )
  95 import Darcs.Repository.ApplyPatches ( apply_patches )
  96 import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine )
  97 import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply )
  98 import Darcs.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL,
  99                        concatRL, lengthRL, isShorterThanRL )
 100 import Darcs.Patch.Info ( PatchInfo )
 101 import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),
 102                                  create_repo_format, format_has, writeRepoFormat )
 103 import Darcs.Repository.Prefs ( write_default_prefs )
 104 import Darcs.Repository.Pristine ( createPristine, flagsToPristine )
 105 import Darcs.Patch.Depends ( get_patches_beyond_tag )
 106 import Darcs.RepoPath ( toFilePath )
 107 import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn )
 108 import Darcs.External ( copyFileOrUrl, Cachable(..) )
 109 import Darcs.Progress ( debugMessage, progressFL, progressRL, tediousSize,
 110                         beginTedious, endTedious, progress )
 111 import Darcs.Lock ( withTempDir, writeBinFile )
 112 import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped )
 113
 114 import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral,
 115                                 AllowUnrelatedRepos
 116                               ),
 117                      compression )
 118 import Darcs.Global ( darcsdir )
 119 #include "impossible.h"
 120
 121 \end{code}
 122
 123 \begin{code}
 124 createRepository :: [DarcsFlag] -> IO ()
 125 createRepository opts = do
 126   createDirectory darcsdir `catch`
 127       (\e-> if isAlreadyExistsError e
 128             then fail "Tree has already been initialized!"
 129             else fail $ "Error creating directory `"++darcsdir++"'.")
 130   let rf = create_repo_format opts
 131   createPristine $ flagsToPristine opts rf
 132   createDirectory $ darcsdir ++ "/patches"
 133   createDirectory $ darcsdir ++ "/prefs"
 134   write_default_prefs
 135   writeRepoFormat rf (darcsdir++"/format")
 136   if format_has HashedInventory rf
 137       then writeBinFile (darcsdir++"/hashed_inventory") ""
 138       else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(())) -- YUCK!
 139
 140 copyRepository :: RepoPatch p => Repository p C(r u t) -> IO ()
 141 copyRepository fromrepository@(Repo _ opts rf _)
 142     | Partial `elem` opts && not (format_has HashedInventory rf) =
 143         do isPartial <- copyPartialRepository fromrepository
 144            unless (isPartial == IsPartial) $ copyFullRepository fromrepository
 145     | otherwise = copyFullRepository fromrepository
 146
 147 data PorNP = NotPartial | IsPartial
 148              deriving ( Eq )
 149
 150 data RepoSort = Hashed | Old
 151
 152 copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
 153 copyInventory fromrepo@(Repo fromdir opts rf (DarcsRepository _ cremote)) = do
 154   repo@(Repo todir xx rf2 (DarcsRepository yy c)) <- identifyRepositoryFor fromrepo "."
 155   let newrepo :: Repository p C(r u t)
 156       newrepo = Repo todir xx rf2 (DarcsRepository yy (c `unionCaches` cremote))
 157       copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir
 158       copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>=
 159                             DarcsRepo.write_inventory_and_patches opts
 160       repoSort rfx | format_has HashedInventory rfx = Hashed
 161                    | otherwise = Old
 162   case repoSort rf2 of
 163     Hashed ->
 164         if format_has HashedInventory rf
 165         then copyHashedHashed
 166         else withCurrentDirectory todir $
 167              do HashedRepo.revert_tentative_changes
 168                 patches <- read_repo fromrepo
 169                 let k = "Copying patch"
 170                 beginTedious k
 171                 tediousSize k (lengthRL $ concatRL patches)
 172                 let patches' = mapRL_RL (mapRL_RL (progress k)) patches
 173                 HashedRepo.write_tentative_inventory c (compression opts) patches'
 174                 endTedious k
 175                 HashedRepo.finalize_tentative_changes repo (compression opts)
 176     Old -> case repoSort rf of
 177            Hashed -> copyAnythingToOld fromrepo
 178            _ -> copy_oldrepo_patches opts fromrepo todir
 179
 180 copy_oldrepo_patches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO ()
 181 copy_oldrepo_patches opts repository@(Repo dir _ _ _) out = do
 182   Sealed patches <- DarcsRepo.read_repo opts "." :: IO (SealedPatchSet Patch)
 183   mpi <- if Partial `elem` opts
 184          -- FIXME this should get last pinfo *before*
 185          -- desired tag...
 186          then identify_checkpoint repository
 187          else return Nothing
 188   FlippedSeal scp <- return $ since_checkpoint mpi $ concatRL patches
 189   DarcsRepo.copy_patches opts dir out $ mapRL info $ scp
 190       where since_checkpoint :: Maybe PatchInfo
 191                              -> RL (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (PatchInfoAnd p)) C(y)
 192             since_checkpoint Nothing ps = flipSeal ps
 193             since_checkpoint (Just ch) (hp:<:ps)
 194                 | ch == info hp = flipSeal $ hp :<: NilRL
 195                 | otherwise = (hp :<:) `mapFlipped` since_checkpoint (Just ch) ps
 196             since_checkpoint _ NilRL = flipSeal NilRL
 197
 198 copyPartialRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO PorNP
 199 copyPartialRepository fromrepository@(Repo _ opts _ _) = do
 200   mch <- get_checkpoint fromrepository :: IO (Maybe (Sealed (Named p C(x))))
 201   case mch of
 202     Nothing -> do putStrLn "No checkpoint."
 203                   return NotPartial
 204     Just (Sealed ch) ->
 205       do copyInventory fromrepository
 206          withRepoLock opts $- \torepository -> do
 207            write_checkpoint_patch ch
 208            local_patches <- read_repo torepository
 209            let pi_ch = patch2patchinfo ch
 210            FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches
 211            let needed_patches = reverseRL $ concatRL ps
 212            apply opts ch `catch`
 213                              \e -> fail ("Bad checkpoint!\n" ++ show e)
 214            apply_patches opts needed_patches
 215            debugMessage "Writing the pristine"
 216            pristineFromWorking torepository
 217            return IsPartial
 218
 219 copyFullRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
 220 copyFullRepository fromrepository@(Repo fromdir opts rffrom _) = do
 221   copyInventory fromrepository
 222   debugMessage "Copying prefs"
 223   copyFileOrUrl opts (fromdir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600)
 224                      `catchall` return ()
 225   debugMessage "Grabbing lock in new repository..."
 226   withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) ->
 227       if format_has HashedInventory rffrom && format_has HashedInventory rfto
 228       then do debugMessage "Writing working directory contents..."
 229               createPristineDirectoryTree torepository "."
 230               fetch_patches_if_necessary opts torepository
 231               when (Partial `elem` opts) $ putStrLn $
 232                        "--partial: hashed or darcs-2 repository detected, using --lazy instead"
 233       else if format_has HashedInventory rfto
 234            then do local_patches <- read_repo torepository
 235                    withTempDir "newpristine" $ \newpris ->
 236                        replacePristine torepository (toFilePath newpris)
 237                    let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $
 238                                         mapRL_RL reverseRL local_patches
 239                    sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply
 240                    finalizeRepositoryChanges torepository
 241                    debugMessage "Writing working directory contents..."
 242                    createPristineDirectoryTree torepository "."
 243            else do read_repo torepository >>= (apply_patches opts . reverseRL . concatRL)
 244                    debugMessage "Writing the pristine"
 245                    pristineFromWorking torepository
 246
 247 -- | writePatchSet is like patchSetToRepository, except that it doesn't
 248 -- touch the working directory or pristine cache.
 249 writePatchSet :: RepoPatch p => PatchSet p C(x) -> [DarcsFlag] -> IO (Repository p C(r u t))
 250 writePatchSet patchset opts = do
 251     maybeRepo <- maybeIdentifyRepository opts "."
 252     let repo@(Repo _ _ rf2 (DarcsRepository _ c)) =
 253           case maybeRepo of
 254             Right r -> r
 255             Left e  -> bug ("Current directory not repository in writePatchSet: " ++ e)
 256     debugMessage "Writing inventory"
 257     if format_has HashedInventory rf2
 258        then do HashedRepo.write_tentative_inventory c (compression opts) patchset
 259                HashedRepo.finalize_tentative_changes repo (compression opts)
 260        else DarcsRepo.write_inventory_and_patches opts patchset
 261     return repo
 262
 263 -- | patchSetToRepository takes a patch set, and writes a new repository in the current directory
 264 --   that contains all the patches in the patch set. This function is used when 'darcs get'ing a
 265 --   repository with the --to-match flag and the new repository is not in hashed format.
 266 --   This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell
 267 --   darcs to create a hashed repository, this function will call @error@.
 268 patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x)
 269                      -> [DarcsFlag] -> IO (Repository p C(r u t))
 270 patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do
 271     when (format_has HashedInventory rf) $ -- set up sources and all that
 272        do writeFile "_darcs/tentative_pristine" "" -- this is hokey
 273           repox <- writePatchSet patchset opts
 274           HashedRepo.copy_repo repox opts fromrepo
 275     repo <- writePatchSet patchset opts
 276     read_repo repo >>= (apply_patches opts . reverseRL . concatRL)
 277     debugMessage "Writing the pristine"
 278     pristineFromWorking repo
 279     return repo
 280
 281 checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(x) -> IO ()
 282 checkUnrelatedRepos opts common us them
 283     | AllowUnrelatedRepos `elem` opts || not (null common)
 284        || concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5
 285         = return ()
 286     | otherwise
 287         = do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?")
 288              when (yorn /= 'y') $ do putStrLn "Cancelled."
 289                                      exitWith ExitSuccess
 290
 291 -- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy,
 292 --   --partial or --ephemeral), this function fetches all patches that the given repository has
 293 --   with fetchFileUsingCache. This is used as a helper in copyFullRepository.
 294 fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO ()
 295 fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) =
 296     unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $
 297              do putInfo "Copying patches, to get lazy repository hit ctrl-C..."
 298                 r <- read_repo torepository
 299                 let peekaboo :: PatchInfoAnd p C(x y) -> IO ()
 300                     peekaboo x = case extractHash x of
 301                                  Left _ -> return ()
 302                                  Right h -> fetchFileUsingCache c HashedPatchesDir h >> return ()
 303                 sequence_ $ mapRL peekaboo $ progressRL "Copying patches" $ concatRL r
 304   where putInfo = when (not $ Quiet `elem` opts) . putStrLn
 305
 306 \end{code}