#include "gadts.h"
module Darcs.Repository
( Repository, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..), ($-), maybeIdentifyRepository, identifyRepositoryFor
, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory
, withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository
, amNotInRepository, replacePristine
, withRecorded, readRepo, prefsUrl
, addToPending, tentativelyAddPatch, tentativelyRemovePatches
, tentativelyAddToPending, tentativelyReplacePatches, readTentativeRepo
, tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges
, finalizeRepositoryChanges, createRepository, copyRepository
, copyOldrepoPatches, patchSetToRepository, unrevertUrl, applyToWorking
, patchSetToPatches, createPristineDirectoryTree
, createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository
, getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd
, setScriptsExecutable, checkUnrelatedRepos, testTentative, testRecorded
, extractOptions, modifyCache
, readRecorded, readUnrecorded, unrecordedChanges, readPending
, readRecordedAndPending
, readIndex, invalidateIndex
) where
import System.Exit ( ExitCode(..), exitWith )
import Data.List ( isSuffixOf )
import Data.Maybe( catMaybes )
import Darcs.Repository.State( readRecorded, readUnrecorded, readWorking, unrecordedChanges
, readPending, readIndex, invalidateIndex
, readRecordedAndPending )
import Darcs.Repository.Internal
(Repository(..), RepoType(..), ($-),
maybeIdentifyRepository, identifyRepositoryFor, IdentifyRepo(..),
findRepository, amInRepository, amNotInRepository,
makePatchLazy,
withRecorded,
readRepo, readTentativeRepo,
prefsUrl,
withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,
tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
tentativelyReplacePatches,
revertRepositoryChanges, finalizeRepositoryChanges,
unrevertUrl,
applyToWorking, patchSetToPatches,
createPristineDirectoryTree, createPartialsPristineDirectoryTree,
optimizeInventory, cleanRepository,
getMarkedupFile,
setScriptsExecutable,
testTentative, testRecorded,
makeNewPending
)
import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking )
import Darcs.Repository.Cache ( unionRemoteCaches, fetchFileUsingCache,
speculateFileUsingCache, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..))
import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2RL, newset2FL, progressPatchSet )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import URL ( maxPipelineLength )
import Control.Applicative ( (<$>) )
import Control.Monad ( unless, when )
import System.Directory ( createDirectory, renameDirectory,
createDirectoryIfMissing, renameFile )
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 ( identifyCheckpoint, writeCheckpointPatch, getCheckpoint )
import Darcs.Repository.ApplyPatches ( applyPatches )
import Darcs.Repository.HashedRepo ( applyToTentativePristine, pris2inv, revertTentativeChanges,
copySources )
import Darcs.Repository.InternalTypes ( Pristine(..), extractOptions, modifyCache )
import Darcs.Patch ( RepoPatch, Named, Prim, Patch, patch2patchinfo, apply )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL
, reverseRL ,lengthRL, (+>+), (:\/:)(..) )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), RepoFormat,
createRepoFormat, formatHas, writeRepoFormat )
import Darcs.Repository.Prefs ( writeDefaultPrefs )
import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking )
import Darcs.Patch.Depends ( getPatchesBeyondTag, areUnrelatedRepos, findUncommon )
import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError )
import Darcs.External ( copyFileOrUrl, Cachable(..), fetchFileLazyPS )
import Progress ( debugMessage, tediousSize, beginTedious, endTedious )
import Darcs.ProgressPatches (progressRLShowTags, progressFL)
import Darcs.Lock ( writeBinFile, writeDocBinFile, rmRecursive, withTemp )
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 Darcs.URL ( isFile )
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 Codec.Archive.Tar as Tar
import Codec.Compression.GZip ( compress, decompress )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
#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.writeInventory "." (PatchSet NilRL NilRL :: PatchSet Patch C(Origin Origin))
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
repoSort :: RepoFormat -> RepoSort
repoSort f
| formatHas HashedInventory f = Hashed
| otherwise = Old
copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
copyInventory fromRepo@(Repo fromDir opts fromFormat (DarcsRepository _ fromCache)) = do
toRepo@(Repo toDir opts' toFormat (DarcsRepository toPristine toCache)) <-
identifyRepositoryFor fromRepo "."
toCache2 <- unionRemoteCaches toCache fromCache fromDir
let toRepo2 :: Repository p C(r u t)
toRepo2 = Repo toDir opts' toFormat $ DarcsRepository toPristine toCache2
copyHashedHashed = HashedRepo.copyRepo toRepo2 opts fromDir
copyAnyToOld r = withCurrentDirectory toDir $ readRepo r >>=
DarcsRepo.writeInventoryAndPatches opts
case repoSort fromFormat of
Hashed -> case repoSort toFormat of
Hashed -> copyHashedHashed
Old -> copyAnyToOld fromRepo
Old -> case repoSort toFormat of
Hashed -> withCurrentDirectory toDir $ do
HashedRepo.revertTentativeChanges
patches <- readRepo fromRepo
let k = "Copying patch"
beginTedious k
tediousSize k (lengthRL $ newset2RL patches)
let patches' = progressPatchSet k patches
HashedRepo.writeTentativeInventory toCache (compression opts) patches'
endTedious k
HashedRepo.finalizeTentativeChanges toRepo $ compression opts
Old -> copyOldrepoPatches opts fromRepo toDir
copyOldrepoPatches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO ()
copyOldrepoPatches opts repository@(Repo dir _ _ _) out = do
Sealed patches <- DarcsRepo.readRepo opts "." :: IO (SealedPatchSet Patch C(Origin))
mpi <- if Partial `elem` opts
then identifyCheckpoint repository
else return Nothing
FlippedSeal scp <- return $ since_checkpoint mpi $ newset2RL patches
DarcsRepo.copyPatches 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 <- getCheckpoint 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
writeCheckpointPatch ch
local_patches <- readRepo torepository
let pi_ch = patch2patchinfo ch
FlippedSeal ps <- return $ getPatchesBeyondTag pi_ch local_patches
let needed_patches = reverseRL ps
apply opts ch `catch`
\e -> fail ("Bad checkpoint!\n" ++ prettyError e)
applyPatches 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 fromRepo@(Repo fromDir opts _ _) = do
debugMessage "Copying prefs"
copyFileOrUrl opts (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs")
(darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()
if True
then copyNotPackedRepository fromRepo
else do
b <- (Just <$> fetchFileLazyPS (fromDir ++ "/" ++ darcsdir ++
"/packs/basic.tar.gz") Uncachable) `catchall` return Nothing
case b of
Nothing -> copyNotPackedRepository fromRepo
Just b' -> copyPackedRepository fromRepo b'
copyNotPackedRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
copyNotPackedRepository fromrepository@(Repo _ opts rffrom _) = do
copyInventory fromrepository
debugMessage "Grabbing lock in new repository..."
withRepoLock opts $- \torepository@(Repo _ _ rfto _) ->
if formatHas HashedInventory rffrom && formatHas HashedInventory rfto
then do debugMessage "Writing working directory contents..."
createPristineDirectoryTree torepository "."
fetchPatchesIfNecessary 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 <- readRepo torepository
replacePristine torepository emptyTree
let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches
sequence_ $ mapFL (applyToTentativePristine opts) $ bunchFL 100 patchesToApply
finalizeRepositoryChanges torepository
debugMessage "Writing working directory contents..."
createPristineDirectoryTree torepository "."
else do readRepo torepository >>= (applyPatches opts . newset2FL)
debugMessage "Writing the pristine"
pristineFromWorking torepository
copyPackedRepository :: forall p C(r u t). RepoPatch p =>
Repository p C(r u t) -> BL.ByteString -> IO ()
copyPackedRepository fromRepo@(Repo fromDir opts _ (DarcsRepository _ fromCache)) b = do
Repo toDir _ toFormat (DarcsRepository toPristine toCache) <-
identifyRepositoryFor fromRepo "."
toCache2 <- unionRemoteCaches toCache fromCache fromDir
let toRepo :: Repository p C(r u r)
toRepo = Repo toDir opts toFormat $ DarcsRepository toPristine toCache2
fromPacksDir = fromDir ++ "/" ++ darcsdir ++ "/packs/"
createDirectoryIfMissing False $ toDir </> darcsdir </> "inventories"
createDirectoryIfMissing False $ toDir </> darcsdir </> "pristine.hashed"
createDirectoryIfMissing False $ toDir </> darcsdir </> "patches"
copySources toRepo fromDir
writeCompressed . Tar.read $ decompress b
createPristineDirectoryTree toRepo "."
us <- readRepo toRepo
them <- readRepo fromRepo
us' :\/: them' <- return $ findUncommon us them
revertTentativeChanges
Sealed pw <- tentativelyMergePatches toRepo "get" opts us' them'
invalidateIndex toRepo
withGutsOf toRepo $ do
finalizeRepositoryChanges toRepo
applyToWorking toRepo opts pw
return ()
unless (any (`elem` opts) [Partial, Lazy, Ephemeral]) $ do
putInfo "Copying patches, to get lazy repository hit ctrl-C..."
writeCompressed . Tar.read . decompress =<< fetchFileLazyPS (fromPacksDir ++
"patches.tar.gz") Uncachable
where
writeCompressed Tar.Done = return ()
writeCompressed (Tar.Next x xs) = case Tar.entryContent x of
Tar.NormalFile x' _ -> do
let p = Tar.entryPath x
withTemp $ \p' -> do
BL.writeFile p' $ if "hashed_inventory" `isSuffixOf` p
then x'
else compress x'
renameFile p' p
writeCompressed xs
_ -> fail "Unexpected non-file tar entry"
writeCompressed (Tar.Fail e) = fail e
putInfo = when (not $ Quiet `elem` opts) . putStrLn
writePatchSet :: RepoPatch p => PatchSet p C(Origin 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
GoodRepository r -> r
BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e)
NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e)
debugMessage "Writing inventory"
if formatHas HashedInventory rf2
then do HashedRepo.writeTentativeInventory c (compression opts) patchset
HashedRepo.finalizeTentativeChanges repo (compression opts)
else DarcsRepo.writeInventoryAndPatches opts patchset
return repo
patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(Origin 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.copyRepo repox opts fromrepo
repo <- writePatchSet patchset opts
readRepo repo >>= (applyPatches opts . newset2FL)
debugMessage "Writing the pristine"
pristineFromWorking repo
return repo
checkUnrelatedRepos :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> PatchSet p C(start y)
-> IO ()
checkUnrelatedRepos opts _ _ | AllowUnrelatedRepos `elem` opts = return ()
checkUnrelatedRepos _ us them =
if areUnrelatedRepos us them
then do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?")
when (yorn /= 'y') $ do putStrLn "Cancelled."
exitWith ExitSuccess
else return ()
fetchPatchesIfNecessary :: forall p C(r u t). RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO ()
fetchPatchesIfNecessary 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 <- readRepo torepository
pipelineLength <- maxPipelineLength
let patches = newset2RL r
ppatches = progressRLShowTags "Copying patches" patches
(first, other) = splitAt (pipelineLength 1) $ tail $ hashes patches
speculate | pipelineLength > 1 = [] : first : map (:[]) other
| otherwise = []
mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])
where putInfo = when (not $ Quiet `elem` opts) . putStrLn
hashes :: FORALL(x y) RL (PatchInfoAnd p) C(x y) -> [String]
hashes = catMaybes . mapRL ((either (const Nothing) Just) . extractHash)
fetchAndSpeculate :: (String, [String]) -> IO ()
fetchAndSpeculate (f, ss) = do
fetchFileUsingCache c HashedPatchesDir f
mapM_ (speculateFileUsingCache c HashedPatchesDir) ss
addToPending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()
addToPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
addToPending repo@(Repo _ opts _ _) p =
do pend <- unrecordedChanges opts repo []
invalidateIndex repo
makeNewPending 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 rmRecursive 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