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