#include "gadts.h"
module Darcs.Repository ( Repository, ($-), maybeIdentifyRepository,
identifyRepositoryFor,
withRepoLock, withRepoReadLock,
withRepository, withRepositoryDirectory, withGutsOf,
makePatchLazy, writePatchSet,
findRepository, amInRepository, amNotInRepository,
slurp_pending, replacePristine, replacePristineFromSlurpy,
slurp_recorded, slurp_recorded_and_unrecorded,
withRecorded,
get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
get_unrecorded_in_files,
read_repo, sync_repo,
prefsUrl,
add_to_pending,
tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
tentativelyReplacePatches,
tentativelyMergePatches, considerMergeToWorking,
revertRepositoryChanges, finalizeRepositoryChanges,
createRepository, copyRepository, copy_oldrepo_patches,
patchSetToRepository,
unrevertUrl,
applyToWorking, patchSetToPatches,
createPristineDirectoryTree, createPartialsPristineDirectoryTree,
optimizeInventory, cleanRepository,
checkPristineAgainstSlurpy, getMarkedupFile,
PatchSet, SealedPatchSet, PatchInfoAnd,
setScriptsExecutable,
checkUnrelatedRepos,
testTentative, testRecorded
) where
import System.Exit ( ExitCode(..), exitWith )
import Darcs.Repository.Internal
(Repository(..), RepoType(..), ($-), pristineFromWorking,
maybeIdentifyRepository, identifyRepositoryFor,
findRepository, amInRepository, amNotInRepository,
makePatchLazy,
slurp_pending, replacePristine, replacePristineFromSlurpy,
slurp_recorded, slurp_recorded_and_unrecorded,
withRecorded,
get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
get_unrecorded_in_files,
read_repo, sync_repo,
prefsUrl, checkPristineAgainstSlurpy,
add_to_pending,
withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,
tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
tentativelyReplacePatches,
tentativelyMergePatches, considerMergeToWorking,
revertRepositoryChanges, finalizeRepositoryChanges,
unrevertUrl,
applyToWorking, patchSetToPatches,
createPristineDirectoryTree, createPartialsPristineDirectoryTree,
optimizeInventory, cleanRepository,
getMarkedupFile,
setScriptsExecutable,
testTentative, testRecorded
)
import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
import Control.Monad ( unless, when )
import Data.Either(Either(..))
import System.Directory ( createDirectory )
import System.IO.Error ( isAlreadyExistsError )
import qualified Darcs.Repository.DarcsRepo as DarcsRepo
import qualified Darcs.Repository.HashedRepo as HashedRepo
import Darcs.Hopefully ( PatchInfoAnd, info, extractHash )
import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint )
import Darcs.Repository.ApplyPatches ( apply_patches )
import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine )
import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply )
import Darcs.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL,
concatRL, lengthRL, isShorterThanRL )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),
create_repo_format, format_has, writeRepoFormat )
import Darcs.Repository.Prefs ( write_default_prefs )
import Darcs.Repository.Pristine ( createPristine, flagsToPristine )
import Darcs.Patch.Depends ( get_patches_beyond_tag )
import Darcs.SlurpDirectory ( empty_slurpy )
import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn )
import Darcs.External ( copyFileOrUrl, Cachable(..) )
import Progress ( debugMessage, tediousSize,
beginTedious, endTedious, progress )
import Darcs.ProgressPatches (progressRLShowTags, progressFL)
import Darcs.Lock ( writeBinFile )
import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped )
import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral,
AllowUnrelatedRepos
),
compression )
import Darcs.Global ( darcsdir )
#include "impossible.h"
createRepository :: [DarcsFlag] -> IO ()
createRepository opts = do
createDirectory darcsdir `catch`
(\e-> if isAlreadyExistsError e
then fail "Tree has already been initialized!"
else fail $ "Error creating directory `"++darcsdir++"'.")
let rf = create_repo_format opts
createPristine $ flagsToPristine opts rf
createDirectory $ darcsdir ++ "/patches"
createDirectory $ darcsdir ++ "/prefs"
write_default_prefs
writeRepoFormat rf (darcsdir++"/format")
if format_has HashedInventory rf
then writeBinFile (darcsdir++"/hashed_inventory") ""
else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(()))
copyRepository :: RepoPatch p => Repository p C(r u t) -> IO ()
copyRepository fromrepository@(Repo _ opts rf _)
| Partial `elem` opts && not (format_has HashedInventory rf) =
do isPartial <- copyPartialRepository fromrepository
unless (isPartial == IsPartial) $ copyFullRepository fromrepository
| otherwise = copyFullRepository fromrepository
data PorNP = NotPartial | IsPartial
deriving ( Eq )
data RepoSort = Hashed | Old
copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
copyInventory fromrepo@(Repo fromdir opts rf (DarcsRepository _ cremote)) = do
repo@(Repo todir xx rf2 (DarcsRepository yy c)) <- identifyRepositoryFor fromrepo "."
let newrepo :: Repository p C(r u t)
newrepo = Repo todir xx rf2 (DarcsRepository yy (c `unionCaches` cremote))
copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir
copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>=
DarcsRepo.write_inventory_and_patches opts
repoSort rfx | format_has HashedInventory rfx = Hashed
| otherwise = Old
case repoSort rf2 of
Hashed ->
if format_has HashedInventory rf
then copyHashedHashed
else withCurrentDirectory todir $
do HashedRepo.revert_tentative_changes
patches <- read_repo fromrepo
let k = "Copying patch"
beginTedious k
tediousSize k (lengthRL $ concatRL patches)
let patches' = mapRL_RL (mapRL_RL (progress k)) patches
HashedRepo.write_tentative_inventory c (compression opts) patches'
endTedious k
HashedRepo.finalize_tentative_changes repo (compression opts)
Old -> case repoSort rf of
Hashed -> copyAnythingToOld fromrepo
_ -> copy_oldrepo_patches opts fromrepo todir
copy_oldrepo_patches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO ()
copy_oldrepo_patches opts repository@(Repo dir _ _ _) out = do
Sealed patches <- DarcsRepo.read_repo opts "." :: IO (SealedPatchSet Patch)
mpi <- if Partial `elem` opts
then identify_checkpoint repository
else return Nothing
FlippedSeal scp <- return $ since_checkpoint mpi $ concatRL patches
DarcsRepo.copy_patches opts dir out $ mapRL info $ scp
where since_checkpoint :: Maybe PatchInfo
-> RL (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (PatchInfoAnd p)) C(y)
since_checkpoint Nothing ps = flipSeal ps
since_checkpoint (Just ch) (hp:<:ps)
| ch == info hp = flipSeal $ hp :<: NilRL
| otherwise = (hp :<:) `mapFlipped` since_checkpoint (Just ch) ps
since_checkpoint _ NilRL = flipSeal NilRL
copyPartialRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO PorNP
copyPartialRepository fromrepository@(Repo _ opts _ _) = do
mch <- get_checkpoint fromrepository :: IO (Maybe (Sealed (Named p C(x))))
case mch of
Nothing -> do putStrLn "No checkpoint."
return NotPartial
Just (Sealed ch) ->
do copyInventory fromrepository
withRepoLock opts $- \torepository -> do
write_checkpoint_patch ch
local_patches <- read_repo torepository
let pi_ch = patch2patchinfo ch
FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches
let needed_patches = reverseRL $ concatRL ps
apply opts ch `catch`
\e -> fail ("Bad checkpoint!\n" ++ show e)
apply_patches opts needed_patches
debugMessage "Writing the pristine"
pristineFromWorking torepository
return IsPartial
copyFullRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
copyFullRepository fromrepository@(Repo fromdir opts rffrom _) = do
copyInventory fromrepository
debugMessage "Copying prefs"
copyFileOrUrl opts (fromdir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600)
`catchall` return ()
debugMessage "Grabbing lock in new repository..."
withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) ->
if format_has HashedInventory rffrom && format_has HashedInventory rfto
then do debugMessage "Writing working directory contents..."
createPristineDirectoryTree torepository "."
fetch_patches_if_necessary opts torepository
when (Partial `elem` opts) $ putStrLn $
"--partial: hashed or darcs-2 repository detected, using --lazy instead"
else if format_has HashedInventory rfto
then do local_patches <- read_repo torepository
replacePristineFromSlurpy torepository empty_slurpy
let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $
mapRL_RL reverseRL local_patches
sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply
finalizeRepositoryChanges torepository
debugMessage "Writing working directory contents..."
createPristineDirectoryTree torepository "."
else do read_repo torepository >>= (apply_patches opts . reverseRL . concatRL)
debugMessage "Writing the pristine"
pristineFromWorking torepository
writePatchSet :: RepoPatch p => PatchSet p C(x) -> [DarcsFlag] -> IO (Repository p C(r u t))
writePatchSet patchset opts = do
maybeRepo <- maybeIdentifyRepository opts "."
let repo@(Repo _ _ rf2 (DarcsRepository _ c)) =
case maybeRepo of
Right r -> r
Left e -> bug ("Current directory not repository in writePatchSet: " ++ e)
debugMessage "Writing inventory"
if format_has HashedInventory rf2
then do HashedRepo.write_tentative_inventory c (compression opts) patchset
HashedRepo.finalize_tentative_changes repo (compression opts)
else DarcsRepo.write_inventory_and_patches opts patchset
return repo
patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x)
-> [DarcsFlag] -> IO (Repository p C(r u t))
patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do
when (format_has HashedInventory rf) $
do writeFile "_darcs/tentative_pristine" ""
repox <- writePatchSet patchset opts
HashedRepo.copy_repo repox opts fromrepo
repo <- writePatchSet patchset opts
read_repo repo >>= (apply_patches opts . reverseRL . concatRL)
debugMessage "Writing the pristine"
pristineFromWorking repo
return repo
checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(x) -> IO ()
checkUnrelatedRepos opts common us them
| AllowUnrelatedRepos `elem` opts || not (null common)
|| concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5
= return ()
| otherwise
= do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?")
when (yorn /= 'y') $ do putStrLn "Cancelled."
exitWith ExitSuccess
fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO ()
fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) =
unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $
do putInfo "Copying patches, to get lazy repository hit ctrl-C..."
r <- read_repo torepository
let peekaboo :: PatchInfoAnd p C(x y) -> IO ()
peekaboo x = case extractHash x of
Left _ -> return ()
Right h -> fetchFileUsingCache c HashedPatchesDir h >> return ()
sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r
where putInfo = when (not $ Quiet `elem` opts) . putStrLn