module Darcs.Repository
( Repository
, HashedDir(..)
, Cache(..)
, CacheLoc(..)
, WritableOrNot(..)
, RepoJob(..)
, maybeIdentifyRepository
, identifyRepositoryFor
, withRecorded
, withRepoLock
, withRepoLockCanFail
, withRepository
, withRepositoryDirectory
, writePatchSet
, findRepository
, amInRepository
, amNotInRepository
, amInHashedRepository
, replacePristine
, readRepo
, prefsUrl
, repoPatchType
, readRepoUsingSpecificInventory
, addToPending
, addPendingDiffToPending
, tentativelyAddPatch
, tentativelyRemovePatches
, tentativelyAddToPending
, tentativelyReplacePatches
, readTentativeRepo
, withManualRebaseUpdate
, tentativelyMergePatches
, considerMergeToWorking
, revertRepositoryChanges
, finalizeRepositoryChanges
, createRepository
, cloneRepository
, patchSetToRepository
, unrevertUrl
, applyToWorking
, patchSetToPatches
, createPristineDirectoryTree
, createPartialsPristineDirectoryTree
, reorderInventory
, cleanRepository
, PatchSet
, SealedPatchSet
, PatchInfoAnd
, setScriptsExecutable
, setScriptsExecutablePatches
, checkUnrelatedRepos
, testTentative
, modifyCache
, reportBadSources
, readRecorded
, readUnrecorded
, unrecordedChanges
, unrecordedChangesWithPatches
, filterOutConflicts
, readPending
, readRecordedAndPending
, readIndex
, invalidateIndex
, listFiles
, listRegisteredFiles
, listUnregisteredFiles
) where
import Prelude hiding ( catch, pi )
import System.Exit ( exitSuccess )
import Data.List ( (\\), isPrefixOf )
import Data.Maybe( catMaybes, isJust, listToMaybe )
import Darcs.Repository.State
( readRecorded
, readUnrecorded
, readWorking
, unrecordedChanges
, unrecordedChangesWithPatches
, readPendingAndWorking
, readPending
, readIndex
, invalidateIndex
, readRecordedAndPending
, restrictDarcsdir
, restrictBoring
, applyTreeFilter
, filterOutConflicts
)
import Darcs.Repository.Internal
(Repository(..)
, maybeIdentifyRepository
, identifyRepositoryFor
, identifyRepository
, IdentifyRepo(..)
, findRepository
, amInRepository
, amNotInRepository
, amInHashedRepository
, readRepo
, readTentativeRepo
, readRepoUsingSpecificInventory
, prefsUrl
, withRecorded
, tentativelyAddPatch
, tentativelyRemovePatches
, tentativelyReplacePatches
, tentativelyAddToPending
, revertRepositoryChanges
, finalizeRepositoryChanges
, unrevertUrl
, applyToWorking
, patchSetToPatches
, createPristineDirectoryTree
, createPartialsPristineDirectoryTree
, reorderInventory
, cleanRepository
, setScriptsExecutable
, setScriptsExecutablePatches
, makeNewPending
, seekRepo
)
import Darcs.Repository.Job
( RepoJob(..)
, withRepoLock
, withRepoLockCanFail
, withRepository
, withRepositoryDirectory
)
import Darcs.Repository.Rebase ( withManualRebaseUpdate )
import Darcs.Repository.Test
( testTentative )
import Darcs.Repository.Merge( tentativelyMergePatches
, considerMergeToWorking
)
import Darcs.Repository.Cache ( unionRemoteCaches
, fetchFileUsingCache
, speculateFileUsingCache
, HashedDir(..)
, Cache(..)
, CacheLoc(..)
, WritableOrNot(..)
, hashedDir
, bucketFolder
, CacheType(Directory)
, reportBadSources
)
import Darcs.Patch ( RepoPatch
, apply
, invert
, effect
, PrimOf
)
import Darcs.Patch.Set ( Origin
, PatchSet(..)
, SealedPatchSet
, newset2RL
, newset2FL
, progressPatchSet
)
import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch )
import Darcs.Patch.Commute( commuteFL )
import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )
import Control.Exception ( catch, Exception, throwIO, finally, IOException )
import Control.Concurrent ( forkIO )
import Control.Concurrent.MVar ( MVar
, newMVar
, putMVar
, takeMVar
)
import Control.Monad ( unless, when, void )
import Control.Applicative( (<$>) )
import System.Directory ( createDirectory
, createDirectoryIfMissing
, renameFile
, doesFileExist
, removeFile
, getDirectoryContents
, getCurrentDirectory
, setCurrentDirectory
)
import System.IO ( stderr )
import System.IO.Error ( isAlreadyExistsError )
import System.Posix.Files ( createLink )
import qualified Darcs.Repository.HashedRepo as HashedRepo
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully )
import Darcs.Repository.ApplyPatches ( applyPatches, runDefault )
import Darcs.Repository.HashedRepo ( applyToTentativePristine
, pris2inv
, inv2pris
, revertTentativeChanges
, copySources
)
import Darcs.Repository.InternalTypes ( modifyCache )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FreeLeft, unFreeLeft )
import Darcs.Patch.Witnesses.Ordered
((:>)(..), reverseRL, reverseFL, lengthFL, mapFL_FL, FL(..),
RL(..), bunchFL, mapFL, mapRL, lengthRL, (+>+), (:\/:)(..))
import Darcs.Repository.Format ( RepoProperty ( HashedInventory, Darcs2 )
, RepoFormat
, createRepoFormat
, formatHas
, writeRepoFormat
, readProblem
)
import Darcs.Repository.Prefs ( writeDefaultPrefs, addRepoSource, deleteSources )
import Darcs.Repository.Match ( getOnePatchset )
import Darcs.Patch.Depends ( areUnrelatedRepos, findUncommon, findCommonWithThem
, countUsThem )
import Darcs.Patch.Type ( PatchType(..) )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.English ( englishNum, Noun(..) )
import Darcs.Repository.External
( copyFileOrUrl
, Cachable(..)
, fetchFileLazyPS
, gzFetchFilePS
)
import Darcs.Util.Progress ( debugMessage
, tediousSize
, beginTedious
, endTedious
)
import Darcs.Patch.Progress
( progressRLShowTags
, progressFL
)
import Darcs.Repository.Lock
( writeBinFile
, writeDocBinFile
, withTemp
)
import Darcs.Repository.Flags
( UpdateWorking(..)
, UseCache(..)
, UseIndex(..)
, ScanKnown(..)
, RemoteDarcs (..)
, Reorder (..)
, Compression (..)
, CloneKind (..)
, Verbosity (..)
, DryRun (..)
, UMask (..)
, AllowConflicts (..)
, ExternalMerge (..)
, WantGuiPause (..)
, SetScriptsExecutable (..)
, RemoteRepos (..)
, SetDefault (..)
, DiffAlgorithm (..)
, WithWorkingDir (..)
, ForgetParent (..)
, WithPatchIndex (..)
)
import Darcs.Util.Download ( maxPipelineLength )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.URL ( isValidLocalPath )
import Darcs.Util.SignalHandler ( catchInterrupt )
import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc, RenderMode(..) )
import Storage.Hashed.Plain( readPlainTree )
import Storage.Hashed.Tree( Tree, emptyTree, expand, list )
import Storage.Hashed.Hash( encodeBase16 )
import Darcs.Util.Path( anchorPath )
import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes )
import Darcs.Util.ByteString( gzReadFilePS )
import System.FilePath( (</>)
, takeFileName
, splitPath
, joinPath
, takeDirectory
)
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.Char8 as BL
import Darcs.Repository.PatchIndex (createOrUpdatePatchIndexDisk, doesPatchIndexExist, createPIWithInterrupt)
#include "impossible.h"
createRepository :: Bool -> WithWorkingDir -> WithPatchIndex -> IO ()
createRepository useFormat1 withWorkingDir createPatchIndex = do
createDirectory darcsdir `catch`
(\e-> if isAlreadyExistsError e
then fail "Tree has already been initialized!"
else fail $ "Error creating directory `"++darcsdir++"'.")
cwd <- getCurrentDirectory
x <- seekRepo
when (isJust x) $ do
setCurrentDirectory cwd
putStrLn "WARNING: creating a nested repository."
createDirectory $ darcsdir ++ "/pristine.hashed"
createDirectory $ darcsdir ++ "/patches"
createDirectory $ darcsdir ++ "/inventories"
createDirectory $ darcsdir ++ "/prefs"
writeDefaultPrefs
let repoFormat = createRepoFormat useFormat1 withWorkingDir
writeRepoFormat repoFormat (darcsdir++"/format")
writeBinFile (darcsdir++"/hashed_inventory") ""
writePristine "." emptyTree
withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of
NoPatchIndex -> return ()
YesPatchIndex -> createOrUpdatePatchIndexDisk repo
repoPatchType :: Repository p wR wU wT -> PatchType p
repoPatchType _ = PatchType
cloneRepository ::
String
-> String
-> Verbosity -> UseCache
-> CloneKind
-> UMask -> RemoteDarcs
-> SetScriptsExecutable
-> RemoteRepos -> SetDefault
-> [MatchFlag]
-> RepoFormat
-> WithWorkingDir
-> WithPatchIndex
-> Bool
-> Bool
-> ForgetParent
-> IO ()
cloneRepository repodir mysimplename v uc cloneKind um rdarcs sse remoteRepos
setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks toMatch forget = do
createDirectory mysimplename
setCurrentDirectory mysimplename
createRepository (not $ formatHas Darcs2 rfsource)
withWorkingDir
(if cloneKind == LazyClone then NoPatchIndex else usePatchIndex)
debugMessage "Finished initializing new directory."
addRepoSource repodir NoDryRun remoteRepos setDefault
if toMatch && cloneKind /= LazyClone
then withRepository uc $ RepoJob $ \repository -> do
debugMessage "Using economical clone --to-match handling"
fromrepo <- identifyRepositoryFor repository uc repodir
Sealed patches_to_get <- getOnePatchset fromrepo matchFlags
patchSetToRepository fromrepo patches_to_get uc rdarcs
debugMessage "Finished converting selected patch set to new repository"
else copyRepoAndGoToChosenVersion repodir v uc cloneKind um rdarcs sse
matchFlags withWorkingDir usePacks forget
copyRepoAndGoToChosenVersion ::
String
-> Verbosity -> UseCache
-> CloneKind
-> UMask -> RemoteDarcs
-> SetScriptsExecutable
-> [MatchFlag]
-> WithWorkingDir -> Bool
-> ForgetParent
-> IO ()
copyRepoAndGoToChosenVersion repodir v uc gk um rdarcs sse matchFlags withWorkingDir usePacks forget =
withRepository uc $ RepoJob $ \repository -> do
debugMessage "Identifying and copying repository..."
fromRepo@(Repo fromDir rffrom _ _) <- identifyRepositoryFor repository uc repodir
case readProblem rffrom of
Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e
Nothing -> return ()
debugMessage "Copying prefs"
copyFileOrUrl rdarcs (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs")
(darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()
if formatHas HashedInventory rffrom
then do
if usePacks && (not . isValidLocalPath) fromDir
then copyBasicRepoPacked fromRepo v uc um rdarcs withWorkingDir
else copyBasicRepoNotPacked fromRepo v uc um rdarcs withWorkingDir
when (gk /= LazyClone) $ do
when (gk /= CompleteClone) $
putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..."
if usePacks && (not . isValidLocalPath) fromDir
then copyCompleteRepoPacked fromRepo v uc um gk
else copyCompleteRepoNotPacked fromRepo v uc um gk
else
copyRepoOldFashioned fromRepo v uc um withWorkingDir
when (sse == YesSetScriptsExecutable) setScriptsExecutable
when (havePatchsetMatch matchFlags) $ do
putStrLn "Going to specified version..."
withRepoLock NoDryRun uc YesUpdateWorking um $ RepoJob $ \repository' -> do
patches <- readRepo repository'
Sealed context <- getOnePatchset repository' matchFlags
when (snd (countUsThem patches context) > 0) $
errorDoc $ text "Missing patches from context!"
_ :> us' <- return $ findCommonWithThem patches context
let ps = mapFL_FL hopefully us'
putInfo v $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++
englishNum (lengthFL ps) (Noun "patch") ""
invalidateIndex repository'
_ <- tentativelyRemovePatches repository' GzipCompression YesUpdateWorking us'
tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect us'
finalizeRepositoryChanges repository' YesUpdateWorking GzipCompression
runDefault (apply (invert $ effect ps)) `catch` \(e :: IOException) ->
fail ("Couldn't undo patch in working dir.\n" ++ show e)
when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps)
when (forget == YesForgetParent) deleteSources
putInfo :: Verbosity -> Doc -> IO ()
putInfo Quiet _ = return ()
putInfo _ d = hPutDocLn Encode stderr d
putVerbose :: Verbosity -> Doc -> IO ()
putVerbose Verbose d = putDocLn d
putVerbose _ _ = return ()
copyBasicRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> Verbosity -> UseCache
-> UMask -> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoNotPacked (Repo fromDir _ _ fromCache) verb useCache umask rdarcs withWorkingDir = do
toRepo@(Repo toDir toFormat toPristine toCache) <- identifyRepository useCache "."
let (_dummy :: Repository p wR wU wT) = toRepo
toCache2 <- unionRemoteCaches toCache fromCache fromDir
let toRepo2 :: Repository p wR wU wT
toRepo2 = Repo toDir toFormat toPristine toCache2
HashedRepo.copyHashedInventory toRepo2 rdarcs fromDir
HashedRepo.copySources toRepo2 fromDir
debugMessage "Grabbing lock in new repository to copy basic repo..."
withRepoLock NoDryRun useCache YesUpdateWorking umask
$ RepoJob $ \torepository -> do
putVerbose verb $ text "Writing pristine and working directory contents..."
createPristineDirectoryTree torepository "." withWorkingDir
copyCompleteRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> Verbosity -> UseCache
-> UMask -> CloneKind
-> IO ()
copyCompleteRepoNotPacked _ verb useCache umask cloneKind = do
debugMessage "Grabbing lock in new repository to copy complete repo..."
withRepoLock NoDryRun useCache YesUpdateWorking umask
$ RepoJob $ \torepository@(Repo todir _ _ _) -> do
let cleanup = putInfo verb $ text "Using lazy repository."
allowCtrlC cloneKind cleanup $ do
fetchPatchesIfNecessary torepository
pi <- doesPatchIndexExist todir
when pi $ createPIWithInterrupt torepository
packsDir :: String
packsDir = "/" ++ darcsdir ++ "/packs/"
copyBasicRepoPacked ::
forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> Verbosity -> UseCache
-> UMask -> RemoteDarcs
-> WithWorkingDir
-> IO ()
copyBasicRepoPacked r@(Repo fromDir _ _ _) verb useCache umask rdarcs withWorkingDir =
do let hashURL = fromDir ++ packsDir ++ "pristine"
mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing)
let hiURL = fromDir ++ "/" ++ darcsdir ++ "/hashed_inventory"
i <- gzFetchFilePS hiURL Uncachable
let currentHash = BS.pack $ inv2pris i
let copyNormally = copyBasicRepoNotPacked r verb useCache umask rdarcs withWorkingDir
case mPackHash of
Just packHash | packHash == currentHash
-> ( copyBasicRepoPacked2 r verb useCache withWorkingDir
`catchall` do putStrLn "Problem while copying basic pack, copying normally."
copyNormally)
_ -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally."
copyNormally
copyBasicRepoPacked2 ::
forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> Verbosity -> UseCache
-> WithWorkingDir -> IO ()
copyBasicRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache withWorkingDir = do
b <- fetchFileLazyPS (fromDir ++ packsDir ++ "basic.tar.gz") Uncachable
putVerbose verb $ text "Cloning packed basic repository."
Repo toDir toFormat toPristine toCache <-
identifyRepositoryFor fromRepo useCache "."
toCache2 <- unionRemoteCaches toCache fromCache fromDir
let toRepo :: Repository p wR wU wR
toRepo = Repo toDir toFormat toPristine toCache2
copySources toRepo fromDir
Repo _ _ _ toCache3 <-
identifyRepositoryFor toRepo useCache "."
cleanDir "pristine.hashed"
removeFile $ darcsdir </> "hashed_inventory"
unpackBasic toCache3 . Tar.read $ decompress b
createPristineDirectoryTree toRepo "." withWorkingDir
putVerbose verb $ text "Basic repository unpacked. Will now see if there are new patches."
us <- readRepo toRepo
them <- readRepo fromRepo
us' :\/: them' <- return $ findUncommon us them
revertTentativeChanges
Sealed pw <- tentativelyMergePatches toRepo "clone" NoAllowConflicts YesUpdateWorking NoExternalMerge NoWantGuiPause GzipCompression verb NoReorder ( UseIndex, ScanKnown, MyersDiff ) us' them'
invalidateIndex toRepo
finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression
when (withWorkingDir == WithWorkingDir) $ void $ applyToWorking toRepo verb pw
where
cleanDir d = mapM_ (\x -> removeFile $ darcsdir </> d </> x) .
filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir </> d)
copyCompleteRepoPacked ::
forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> Verbosity -> UseCache
-> UMask
-> CloneKind
-> IO ()
copyCompleteRepoPacked r verb useCache umask cloneKind =
( copyCompleteRepoPacked2 r verb useCache cloneKind
`catchall` do putVerbose verb $ text "Problem while copying patches pack, copying normally."
copyCompleteRepoNotPacked r verb useCache umask cloneKind )
copyCompleteRepoPacked2 ::
forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> Verbosity -> UseCache
-> CloneKind
-> IO ()
copyCompleteRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache cloneKind = do
Repo toDir toFormat toPristine toCache <- identifyRepositoryFor fromRepo useCache "."
toCache2 <- unionRemoteCaches toCache fromCache fromDir
let toRepo :: Repository p wR wU wR
toRepo = Repo toDir toFormat toPristine toCache2
Repo _ _ _ toCache3 <- identifyRepositoryFor toRepo useCache "."
us <- readRepo toRepo
let cleanup = putInfo verb $ text "Using lazy repository."
allowCtrlC cloneKind cleanup $ do
cleanDir "patches"
putVerbose verb $ text "Using patches pack."
unpackPatches toCache3 (mapRL hashedPatchFileName $ newset2RL us) .
Tar.read . decompress =<< fetchFileLazyPS (fromDir ++ packsDir ++ "patches.tar.gz") Uncachable
pi <- doesPatchIndexExist toDir
when pi $ createPIWithInterrupt toRepo
where
cleanDir d = mapM_ (\x -> removeFile $ darcsdir </> d </> x) .
filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir </> d)
allowCtrlC :: CloneKind -> IO () -> IO () -> IO ()
allowCtrlC CompleteClone _ action = action
allowCtrlC _ cleanup action = action `catchInterrupt` cleanup
copyRepoOldFashioned :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> Verbosity -> UseCache
-> UMask
-> WithWorkingDir
-> IO ()
copyRepoOldFashioned fromrepository verb useCache umask withWorkingDir = do
toRepo@(Repo _ _ _ toCache) <- identifyRepository useCache "."
let (_dummy :: Repository p wR wU wT) = toRepo
HashedRepo.revertTentativeChanges
patches <- readRepo fromrepository
let k = "Copying patch"
beginTedious k
tediousSize k (lengthRL $ newset2RL patches)
let patches' = progressPatchSet k patches
HashedRepo.writeTentativeInventory toCache GzipCompression patches'
endTedious k
HashedRepo.finalizeTentativeChanges toRepo GzipCompression
debugMessage "Grabbing lock in new repository..."
withRepoLock NoDryRun useCache YesUpdateWorking umask
$ RepoJob $ \torepository -> do
local_patches <- readRepo torepository
replacePristine torepository emptyTree
let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches
sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply
finalizeRepositoryChanges torepository YesUpdateWorking GzipCompression
putVerbose verb $ text "Writing pristine and working directory contents..."
createPristineDirectoryTree torepository "." withWorkingDir
withControlMVar :: (MVar () -> IO ()) -> IO ()
withControlMVar f = do
mv <- newMVar ()
f mv
takeMVar mv
forkWithControlMVar :: MVar () -> IO () -> IO ()
forkWithControlMVar mv f = do
takeMVar mv
_ <- forkIO $ finally f (putMVar mv ())
return ()
removeMetaFiles :: IO ()
removeMetaFiles = mapM_ (removeFile . (darcsdir </>)) .
filter ("meta-" `isPrefixOf`) =<< getDirectoryContents darcsdir
unpackBasic :: Exception e => Cache -> Tar.Entries e -> IO ()
unpackBasic c x = do
withControlMVar $ \mv -> unpackTar c (basicMetaHandler c mv) x
removeMetaFiles
unpackPatches :: Exception e => Cache -> [String] -> Tar.Entries e -> IO ()
unpackPatches c ps x = do
withControlMVar $ \mv -> unpackTar c (patchesMetaHandler c ps mv) x
removeMetaFiles
unpackTar :: Exception e => Cache -> IO () -> Tar.Entries e -> IO ()
unpackTar _ _ Tar.Done = return ()
unpackTar _ _ (Tar.Fail e)= throwIO e
unpackTar c mh (Tar.Next x xs) = case Tar.entryContent x of
Tar.NormalFile x' _ -> do
let p = Tar.entryPath x
if "meta-" `isPrefixOf` takeFileName p
then do
BL.writeFile p x'
mh
unpackTar c mh xs
else do
ex <- doesFileExist p
if ex
then debugMessage $ "Tar thread: STOP " ++ p
else do
if p == darcsdir </> "hashed_inventory"
then writeFile' Nothing p x'
else writeFile' (cacheDir c) p $ compress x'
debugMessage $ "Tar thread: GET " ++ p
unpackTar c mh xs
_ -> fail "Unexpected non-file tar entry"
where
writeFile' Nothing path content = withTemp $ \tmp -> do
BL.writeFile tmp content
renameFile tmp path
writeFile' (Just ca) path content = do
let fileFullPath = case splitPath path of
_:hDir:hFile:_ -> joinPath [ca, hDir, bucketFolder hFile, hFile]
_ -> fail "Unexpected file path"
createDirectoryIfMissing True $ takeDirectory path
createLink fileFullPath path `catch` (\(ex :: IOException) -> do
if isAlreadyExistsError ex then
return ()
else
writeFile' Nothing path content)
basicMetaHandler :: Cache -> MVar () -> IO ()
basicMetaHandler ca mv = do
ex <- doesFileExist $ darcsdir </> "meta-filelist-pristine"
when ex . forkWithControlMVar mv $
fetchFilesUsingCache ca HashedPristineDir . lines =<<
readFile (darcsdir </> "meta-filelist-pristine")
patchesMetaHandler :: Cache -> [String] -> MVar () -> IO ()
patchesMetaHandler ca ps mv = do
ex <- doesFileExist $ darcsdir </> "meta-filelist-inventories"
when ex $ do
forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPristineDir .
lines =<< readFile (darcsdir </> "meta-filelist-inventories")
forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPatchesDir ps
cacheDir :: Cache -> Maybe String
cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of
Cache Directory Writable x' -> Just x'
_ -> Nothing
hashedPatchFileName :: PatchInfoAnd p wA wB -> String
hashedPatchFileName x = case extractHash x of
Left _ -> fail "unexpected unhashed patch"
Right h -> h
fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO ()
fetchFilesUsingCache _ _ [] = return ()
fetchFilesUsingCache c d (f:fs) = do
ex <- doesFileExist $ darcsdir </> hashedDir d </> f
if ex
then debugMessage $ "Cache thread: STOP " ++
(darcsdir </> hashedDir d </> f)
else do
debugMessage $ "Cache thread: GET " ++
(darcsdir </> hashedDir d </> f)
_ <- fetchFileUsingCache c d f
fetchFilesUsingCache c d fs
writePatchSet :: (RepoPatch p, ApplyState p ~ Tree)
=> PatchSet p Origin wX
-> UseCache
-> IO (Repository p wR wU wT)
writePatchSet patchset useCache = do
maybeRepo <- maybeIdentifyRepository useCache "."
let repo@(Repo _ _ _ 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"
HashedRepo.writeTentativeInventory c GzipCompression patchset
HashedRepo.finalizeTentativeChanges repo GzipCompression
return repo
patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR1 wU1 wR1
-> PatchSet p Origin wX
-> UseCache -> RemoteDarcs
-> IO ()
patchSetToRepository (Repo fromrepo rf _ _) patchset useCache remoteDarcs = do
when (formatHas HashedInventory rf) $
do writeFile (darcsdir </> "tentative_pristine") ""
repox <- writePatchSet patchset useCache
HashedRepo.copyHashedInventory repox remoteDarcs fromrepo
HashedRepo.copySources repox fromrepo
repo <- writePatchSet patchset useCache
readRepo repo >>= (runDefault . applyPatches . newset2FL)
debugMessage "Writing the pristine"
pristineFromWorking repo
checkUnrelatedRepos :: RepoPatch p
=> Bool
-> PatchSet p wStart wX
-> PatchSet p wStart wY
-> IO ()
checkUnrelatedRepos allowUnrelatedRepos us them =
when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $
do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"
unless confirmed $ do putStrLn "Cancelled."
exitSuccess
fetchPatchesIfNecessary :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT
-> IO ()
fetchPatchesIfNecessary torepository@(Repo _ _ _ c) =
do 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 hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [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
addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT -> UpdateWorking
-> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending _ NoUpdateWorking _ = return ()
addPendingDiffToPending repo@(Repo{}) uw@YesUpdateWorking newP = do
(toPend :> _) <-
readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing
invalidateIndex repo
case unFreeLeft newP of
(Sealed p) -> makeNewPending repo uw $ toPend +>+ p
addToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending _ NoUpdateWorking _ = return ()
addToPending repo@(Repo{}) uw@YesUpdateWorking p = do
(toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing
invalidateIndex repo
case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of
(toP' :> p' :> _excessUnrec) ->
makeNewPending repo uw $ toPend +>+ reverseRL toP' +>+ p'
replacePristine :: Repository p wR wU wT -> Tree IO -> IO ()
replacePristine (Repo r _ _ _) = writePristine r
writePristine :: FilePath -> Tree IO -> IO ()
writePristine r tree = withCurrentDirectory r $
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
pristineFromWorking :: RepoPatch p => Repository p wR wU wT -> IO ()
pristineFromWorking repo@(Repo dir _ _ _) =
withCurrentDirectory dir $ readWorking >>= replacePristine repo
listFiles :: Bool -> IO [String]
listFiles takeBoring =
do
nonboring <- considered emptyTree
working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "."
return $ map (anchorPath "" . fst) $ list working
where
considered = if takeBoring
then const (return restrictDarcsdir)
else restrictBoring
listUnregisteredFiles :: Bool -> IO [String]
listUnregisteredFiles includeBoring =
do unregd <- listFiles includeBoring
regd <- listRegisteredFiles
return $ unregd \\ regd
listRegisteredFiles :: IO [String]
listRegisteredFiles =
do recorded <- expand =<< withRepository YesUseCache (RepoJob readRecordedAndPending)
return $ map (anchorPath "" . fst) $ list recorded