#include "gadts.h"
module Darcs.Repository
( Repository, ($-), maybeIdentifyRepository, identifyRepositoryFor
, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory
, withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository
, amNotInRepository, slurp_pending, replacePristine, slurp_recorded
, slurp_recorded_and_unrecorded, withRecorded, read_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
, getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd
, setScriptsExecutable, checkUnrelatedRepos, testTentative, testRecorded
, readRecorded, readUnrecorded, unrecordedChanges, readPending, pendingChanges
, readRecordedAndPending
, readIndex, invalidateIndex
) where
import System.Exit ( ExitCode(..), exitWith )
import Darcs.Repository.State( readRecorded, readUnrecorded, readWorking, unrecordedChanges
, readPending, pendingChanges, readIndex, invalidateIndex
, readRecordedAndPending )
import Darcs.Repository.Internal
(Repository(..), RepoType(..), ($-),
maybeIdentifyRepository, identifyRepositoryFor,
findRepository, amInRepository, amNotInRepository,
makePatchLazy,
slurp_pending,
slurp_recorded, slurp_recorded_and_unrecorded,
withRecorded,
read_repo,
prefsUrl,
withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,
tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
tentativelyReplacePatches,
revertRepositoryChanges, finalizeRepositoryChanges,
unrevertUrl,
applyToWorking, patchSetToPatches,
createPristineDirectoryTree, createPartialsPristineDirectoryTree,
optimizeInventory, cleanRepository,
getMarkedupFile,
setScriptsExecutable,
testTentative, testRecorded,
make_new_pending
)
import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking )
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, renameDirectory )
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, pris2inv )
import Darcs.Repository.InternalTypes ( Pristine(..) )
import Darcs.Patch ( RepoPatch, Named, Prim, Patch, patch2patchinfo, apply )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL
, reverseRL ,concatRL, lengthRL, isShorterThanRL, (+>+) )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),
createRepoFormat, formatHas, writeRepoFormat )
import Darcs.Repository.Prefs ( writeDefaultPrefs )
import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking )
import Darcs.Patch.Depends ( get_patches_beyond_tag )
import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError )
import Darcs.External ( copyFileOrUrl, Cachable(..) )
import Progress ( debugMessage, tediousSize,
beginTedious, endTedious, progress )
import Darcs.ProgressPatches (progressRLShowTags, progressFL)
import Darcs.Lock ( writeBinFile, writeDocBinFile, rm_recursive )
import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped )
import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, Complete,
AllowUnrelatedRepos, NoUpdateWorking )
, compression )
import Darcs.Global ( darcsdir )
import Storage.Hashed.Tree( Tree, emptyTree )
import Storage.Hashed.Hash( encodeBase16 )
import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes )
import Storage.Hashed( writePlainTree )
import ByteStringUtils( gzReadFilePS )
import System.FilePath( (</>) )
import qualified Data.ByteString.Char8 as BS
#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 = createRepoFormat opts
createPristine $ flagsToPristine opts rf
createDirectory $ darcsdir ++ "/patches"
createDirectory $ darcsdir ++ "/prefs"
writeDefaultPrefs
writeRepoFormat rf (darcsdir++"/format")
if formatHas 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 (formatHas 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 | formatHas HashedInventory rfx = Hashed
| otherwise = Old
case repoSort rf2 of
Hashed ->
if formatHas 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 ps
apply opts ch `catch`
\e -> fail ("Bad checkpoint!\n" ++ prettyError 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 formatHas HashedInventory rffrom && formatHas 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 formatHas HashedInventory rfto
then do local_patches <- read_repo torepository
replacePristine torepository emptyTree
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 formatHas 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 (formatHas 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(y) -> 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 unless (Complete `elem` opts) $
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
add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()
add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
add_to_pending repo@(Repo _ opts _ _) p =
do pend <- unrecordedChanges opts repo []
invalidateIndex repo
make_new_pending repo (pend +>+ p)
replacePristine :: Repository p C(r u t) -> Tree IO -> IO ()
replacePristine (Repo r _opts _rf (DarcsRepository pris _c)) tree =
withCurrentDirectory r $ replace pris
where replace HashedPristine =
do let t = darcsdir </> "hashed_inventory"
i <- gzReadFilePS t
tree' <- darcsAddMissingHashes tree
root <- writeDarcsHashed tree' $ darcsdir </> "pristine.hashed"
writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i
replace (PlainPristine n) =
do rm_recursive nold `catchall` return ()
writePlainTree tree ntmp
renameDirectory n nold
renameDirectory ntmp n
return ()
replace (NoPristine _) = return ()
nold = darcsdir </> "pristine-old"
ntmp = darcsdir </> "pristine-tmp"
pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()
pristineFromWorking repo@(Repo dir _ rf _)
| formatHas HashedInventory rf =
withCurrentDirectory dir $ readWorking >>= replacePristine repo
pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) =
withCurrentDirectory dir $ createPristineFromWorking p