module Darcs.Repository.Hashed
( inventoriesDir
, pristineDir
, patchesDir
, hashedInventory
, revertTentativeChanges
, revertRepositoryChanges
, finalizeTentativeChanges
, cleanPristine
, filterDirContents
, cleanInventories
, cleanPatches
, copyPristine
, copyPartialsPristine
, applyToTentativePristine
, applyToTentativePristineCwd
, addToSpecificInventory
, addToTentativeInventory
, removeFromTentativeInventory
, readRepo
, readRepoHashed
, readTentativeRepo
, readRepoUsingSpecificInventory
, writeAndReadPatch
, writeTentativeInventory
, copyHashedInventory
, readHashedPristineRoot
, pris2inv
, inv2pris
, listInventories
, listInventoriesLocal
, listInventoriesRepoDir
, listPatchesLocalBucketed
, writePatchIfNecessary
, readRepoFromInventoryList
, readPatchIds
, set
, unset
, withRecorded
, withTentative
, tentativelyAddPatch
, tentativelyRemovePatches
, tentativelyRemovePatches_
, tentativelyAddPatch_
, tentativelyAddPatches_
, tentativelyReplacePatches
, finalizeRepositoryChanges
, unrevertUrl
, createPristineDirectoryTree
, createPartialsPristineDirectoryTree
, reorderInventory
, cleanRepository
, UpdatePristine(..)
, repoXor
) where
#include "impossible.h"
import Prelude ()
import Darcs.Prelude
import Control.Arrow ( (&&&) )
import Control.Exception ( catch, IOException )
import Darcs.Util.Exception ( catchall )
import Control.Monad ( when, unless, void )
import Data.Maybe
import Data.List( foldl' )
import qualified Data.ByteString as B ( null, length, empty ,tail, drop,
ByteString, splitAt, readFile )
import qualified Data.ByteString.Char8 as BC
( unpack, dropWhile, break, pack, append, ByteString )
import qualified Data.Set as Set
import Darcs.Util.Hash( encodeBase16, Hash(..) )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Crypt.SHA1 ( SHA1, sha1Xor, zero )
import Darcs.Util.Tree( treeHash, Tree )
import Darcs.Util.Tree.Hashed( hashedTreeIO, readDarcsHashedNosize,
readDarcsHashed, writeDarcsHashed,
decodeDarcsHash, decodeDarcsSize )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import System.Directory ( createDirectoryIfMissing, getDirectoryContents
, doesFileExist, doesDirectoryExist )
import System.FilePath.Posix( (</>) )
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( stderr, hPutStrLn )
import Darcs.Util.External
( copyFileOrUrl
, cloneFile
, fetchFilePS
, gzFetchFilePS
, Cachable( Uncachable )
)
import Darcs.Repository.Flags ( Compression, RemoteDarcs, remoteDarcs
, Verbosity(..), UpdateWorking (..), WithWorkingDir (WithWorkingDir) )
import Darcs.Repository.Format ( RepoProperty( HashedInventory ), formatHas )
import Darcs.Repository.Pending
( readPending
, pendingName
, tentativelyRemoveFromPending
, finalizePending
, setTentativePending
, prepend
)
import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist )
import Darcs.Repository.State ( readRecorded, updateIndex )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock
( writeBinFile
, writeDocBinFile
, writeAtomicFilePS
, appendDocBinFile
, removeFileMayNotExist
)
import Darcs.Patch.Set ( PatchSet(..), Tagged(..)
, SealedPatchSet, Origin
, patchSet2RL
)
import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info,
extractHash, createHashed, hopefully )
import Darcs.Patch ( IsRepoType, RepoPatch, Patchy, showPatch, apply
, Effect
, description
, commuteRL
, readPatch
, effect
, invert
)
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Prim ( PrimPatchBase )
import Darcs.Patch.Bundle ( scanBundle
, makeBundleN
)
import Darcs.Patch.Info ( isTag, makePatchname )
import Darcs.Patch.Named.Wrapped ( namedIsInternal )
import Darcs.Patch.Read ( ReadPatch )
import Darcs.Patch.ReadMonads ( parseStrictly )
import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset
, mergeThem, splitOnTag )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, displayPatchInfo,
readPatchInfo )
import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath
, AbsolutePath, toFilePath )
import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache,
speculateFilesUsingCache, writeFileUsingCache,
okayHash, takeHash,
HashedDir(..), hashedDir, peekInCache, bucketFolder )
import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,
cleanHashdir )
import Darcs.Repository.InternalTypes
( Repository
, repoCache
, repoFormat
, repoLocation
, withRepoLocation
, coerceT )
import qualified Darcs.Repository.Old as Old ( readOldRepo, oldRepoFailMsg )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Patch.Witnesses.Ordered
( (+<+), FL(..), RL(..), mapRL, foldFL_M
, (:>)(..), lengthFL, filterOutFLFL
, reverseFL, reverseRL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Util.ByteString ( gzReadFilePS, dropSpace )
import Darcs.Util.Crypt.SHA256 ( sha256sum )
import Darcs.Util.Printer.Color ( showDoc )
import Darcs.Util.Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text,
invisiblePS, putDocLn, (<+>) )
import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )
import Darcs.Patch.Progress (progressFL)
import Darcs.Util.Workaround ( renameFile )
import Darcs.Repository.Prefs ( globalCacheDir )
makeDarcsdirPath :: String -> String
makeDarcsdirPath name = darcsdir </> name
hashedInventory, hashedInventoryPath :: String
hashedInventory = "hashed_inventory"
hashedInventoryPath = makeDarcsdirPath hashedInventory
tentativeHashedInventory, tentativeHashedInventoryPath :: String
tentativeHashedInventory = "tentative_hashed_inventory"
tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory
inventoriesDir, inventoriesDirPath :: String
inventoriesDir = "inventories"
inventoriesDirPath = makeDarcsdirPath inventoriesDir
pristineDir, tentativePristinePath, pristineDirPath :: String
tentativePristinePath = makeDarcsdirPath "tentative_pristine"
pristineDir = "pristine.hashed"
pristineDirPath = makeDarcsdirPath pristineDir
patchesDir, patchesDirPath :: String
patchesDir = "patches"
patchesDirPath = makeDarcsdirPath patchesDir
pristineNamePrefix :: String
pristineNamePrefix = "pristine:"
pristineName :: B.ByteString
pristineName = BC.pack pristineNamePrefix
applyToHashedPristine :: (ApplyState p ~ Tree, Patchy p) => String -> p wX wY
-> IO String
applyToHashedPristine h p = applyOrConvertOldPristineAndApply
where
applyOrConvertOldPristineAndApply =
tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply
hash = decodeDarcsHash $ BC.pack h
failOnMalformedRoot (SHA256 _) = return ()
failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root
hash2root = BC.unpack . encodeBase16
tryApply :: Hash -> IO String
tryApply root = do
failOnMalformedRoot root
tree <- readDarcsHashedNosize pristineDirPath root
(_, updatedTree) <- hashedTreeIO (apply p) tree pristineDirPath
return . hash2root $ treeHash updatedTree
warn = "WARNING: Doing a one-time conversion of pristine format.\n"
++ "This may take a while. The new format is backwards-compatible."
handleOldPristineAndApply = do
hPutStrLn stderr warn
inv <- gzReadFilePS hashedInventoryPath
let oldroot = BC.pack $ inv2pris inv
oldrootSizeandHash = (decodeDarcsSize &&& decodeDarcsHash) oldroot
old <- readDarcsHashed pristineDirPath oldrootSizeandHash
root <- writeDarcsHashed old pristineDirPath
let newroot = hash2root root
writeDocBinFile hashedInventoryPath $ pris2inv newroot inv
cleanHashdir (Ca []) HashedPristineDir [newroot]
hPutStrLn stderr "Pristine conversion done..."
tryApply root
revertTentativeChanges :: IO ()
revertTentativeChanges = do
cloneFile hashedInventoryPath tentativeHashedInventoryPath
i <- gzReadFilePS hashedInventoryPath
writeBinFile tentativePristinePath $ BC.append pristineName (BC.pack (inv2pris i))
finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> Compression -> IO ()
finalizeTentativeChanges r compr = do
debugMessage "Optimizing the inventory..."
ps <- readTentativeRepo r "."
writeTentativeInventory (repoCache r) compr ps
i <- gzReadFilePS tentativeHashedInventoryPath
p <- gzReadFilePS tentativePristinePath
writeDocBinFile tentativeHashedInventoryPath $ pris2inv (inv2pris p) i
renameFile tentativeHashedInventoryPath hashedInventoryPath
readHashedPristineRoot :: Repository rt p wR wU wT -> IO (Maybe String)
readHashedPristineRoot r = withRepoLocation r $ do
i <- (Just <$> gzReadFilePS hashedInventoryPath)
`catch` (\(_ :: IOException) -> return Nothing)
return $ inv2pris <$> i
cleanPristine :: Repository rt p wR wU wT -> IO ()
cleanPristine r = withRepoLocation r $ do
debugMessage "Cleaning out the pristine cache..."
i <- gzReadFilePS hashedInventoryPath
cleanHashdir (repoCache r) HashedPristineDir [inv2pris i]
filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath]
filterDirContents d f = do
let realPath = makeDarcsdirPath d
exists <- doesDirectoryExist realPath
if exists
then filter (\x -> head x /= '.' && f x) <$>
getDirectoryContents realPath
else return []
set :: [String] -> Set.Set BC.ByteString
set = Set.fromList . map BC.pack
unset :: Set.Set BC.ByteString -> [String]
unset = map BC.unpack . Set.toList
cleanInventories :: Repository rt p wR wU wT -> IO ()
cleanInventories _ = do
debugMessage "Cleaning out inventories..."
hs <- listInventoriesLocal
fs <- filterDirContents inventoriesDir (const True)
mapM_ (removeFileMayNotExist . (inventoriesDirPath </>))
(unset $ (set fs) `Set.difference` (set hs))
specialPatches :: [FilePath]
specialPatches = ["unrevert", "pending", "pending.tentative"]
cleanPatches :: Repository rt p wR wU wT -> IO ()
cleanPatches _ = do
debugMessage "Cleaning out patches..."
hs <- listPatchesLocal darcsdir
fs <- filterDirContents patchesDir (`notElem` specialPatches)
mapM_ (removeFileMayNotExist . (patchesDirPath </>))
(unset $ (set fs) `Set.difference` (set hs))
addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression
-> PatchInfoAnd rt p wX wY -> IO FilePath
addToSpecificInventory invPath c compr p = do
let invFile = darcsdir </> invPath
hash <- snd <$> writePatchIfNecessary c compr p
appendDocBinFile invFile $ showPatchInfo ForStorage (info p) $$ text ("hash: " ++ hash ++ "\n")
return $ darcsdir </> "patches" </> hash
addToTentativeInventory :: RepoPatch p => Cache -> Compression
-> PatchInfoAnd rt p wX wY -> IO FilePath
addToTentativeInventory = addToSpecificInventory tentativeHashedInventory
removeFromTentativeInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> Compression
-> FL (PatchInfoAnd rt p) wX wT -> IO ()
removeFromTentativeInventory repo compr to_remove = do
debugMessage $ "Start removeFromTentativeInventory"
allpatches <- readTentativeRepo repo "."
remaining <- case removeFromPatchSet to_remove allpatches of
Nothing -> bug "Hashed.removeFromTentativeInventory: precondition violated"
Just r -> return r
writeTentativeInventory (repoCache repo) compr remaining
debugMessage $ "Done removeFromTentativeInventory"
writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String
writeHashFile c compr subdir d = do
debugMessage $ "Writing hash file to " ++ hashedDir subdir
writeFileUsingCache c compr subdir $ renderPS d
readRepoHashed :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT
-> String -> IO (PatchSet rt p Origin wR)
readRepoHashed = readRepoUsingSpecificInventory hashedInventory
readTentativeRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> String
-> IO (PatchSet rt p Origin wT)
readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory
readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> String -> Repository rt p wR wU wT
-> String -> IO (PatchSet rt p Origin wS)
readRepoUsingSpecificInventory invPath repo dir = do
realdir <- toPath <$> ioAbsoluteOrRemote dir
Sealed ps <- readRepoPrivate (repoCache repo) realdir invPath
`catch` \e -> do
hPutStrLn stderr ("Invalid repository: " ++ realdir)
ioError e
return $ unsafeCoerceP ps
where
readRepoPrivate :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath
-> FilePath -> IO (SealedPatchSet rt p Origin)
readRepoPrivate cache d iname = do
inventory <- readInventoryPrivate (d </> darcsdir) iname
readRepoFromInventoryList cache inventory
readRepoFromInventoryList :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Cache
-> (Maybe String, [(PatchInfo, String)])
-> IO (SealedPatchSet rt p Origin)
readRepoFromInventoryList cache = parseinvs
where
speculateAndParse h is i = speculate h is >> parse i h
read_patches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]
-> IO (Sealed (RL (PatchInfoAnd rt p) wX))
read_patches [] = return $ seal NilRL
read_patches allis@((i1, h1) : is1) =
lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1)
(createHashed h1 (const $ speculateAndParse h1 allis i1))
where
rp :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]
-> IO (Sealed (RL (PatchInfoAnd rt p) wX))
rp [] = return $ seal NilRL
rp [(i, h), (il, hl)] =
lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)
(rp [(il, hl)])
(createHashed h
(const $ speculateAndParse h (reverse allis) i))
rp ((i, h) : is) =
lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)
(rp is)
(createHashed h (parse i))
read_tag :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String)
-> IO (Sealed (PatchInfoAnd rt p wX))
read_tag (i, h) =
mapSeal (patchInfoAndPatch i) <$> createHashed h (parse i)
speculate :: String -> [(PatchInfo, String)] -> IO ()
speculate h is = do
already_got_one <- peekInCache cache HashedPatchesDir h
unless already_got_one $
speculateFilesUsingCache cache HashedPatchesDir (map snd is)
parse :: ReadPatch p => PatchInfo -> String -> IO (Sealed (p wX))
parse i h = do
debugMessage ("Reading patch file: "++ showDoc (displayPatchInfo i))
(fn, ps) <- fetchFileUsingCache cache HashedPatchesDir h
case readPatch ps of
Just p -> return p
Nothing -> fail $ unlines [ "Couldn't parse file " ++ fn
, "which is patch"
, renderString $ displayPatchInfo i ]
parseinvs :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> (Maybe String, [(PatchInfo, String)])
-> IO (SealedPatchSet rt p Origin)
parseinvs (Nothing, ris) =
mapSeal (PatchSet NilRL) <$> read_patches (reverse ris)
parseinvs (Just h, []) =
bug $ "bad inventory " ++ h ++ " (no tag) in parseinvs!"
parseinvs (Just h, t : ris) = do
Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h)
Sealed ps <- unseal seal <$>
unsafeInterleaveIO (read_patches $ reverse ris)
return $ seal $ PatchSet ts ps
read_ts :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String)
-> String -> IO (Sealed (RL (Tagged rt p) Origin))
read_ts tag0 h0 = do
contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash h0
let is = reverse $ case contents of
(Just _, _ : ris0) -> ris0
(Nothing, ris0) -> ris0
(Just _, []) -> bug "inventory without tag!"
Sealed ts <- unseal seal <$>
unsafeInterleaveIO
(case contents of
(Just h', t' : _) -> read_ts t' h'
(Just _, []) -> bug "inventory without tag!"
(Nothing, _) -> return $ seal NilRL)
Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches is)
Sealed tag00 <- read_tag tag0
return $ seal $ ts :<: Tagged tag00 (Just h0) ps
readTaggedInventoryFromHash :: String
-> IO (Maybe String, [(PatchInfo, String)])
readTaggedInventoryFromHash invHash = do
(fileName, pristineAndInventory) <-
fetchFileUsingCache cache HashedInventoriesDir invHash
readInventoryFromContent fileName pristineAndInventory
lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ)
-> IO (Sealed (p wX))
-> (forall wB . IO (Sealed (q wB)))
-> IO (Sealed (r wX))
lift2Sealed f iox ioy = do
Sealed x <- unseal seal <$> unsafeInterleaveIO iox
Sealed y <- unseal seal <$> unsafeInterleaveIO ioy
return $ seal $ f y x
readInventoryPrivate :: String -> String
-> IO (Maybe String, [(PatchInfo, String)])
readInventoryPrivate dir invName = do
inv <- skipPristine <$> gzFetchFilePS (dir </> invName) Uncachable
readInventoryFromContent (toPath dir ++ "/" ++ darcsdir ++ invName) inv
readInventoryFromContent :: FilePath -> B.ByteString
-> IO (Maybe String, [(PatchInfo, String)])
readInventoryFromContent fileName pristineAndInventory = do
(hash, patchIds) <-
if mbStartingWith == BC.pack "Starting with inventory:"
then let (hash, pids) = BC.break ('\n' ==) $ B.tail pistr
hashStr = BC.unpack hash in
if okayHash hashStr
then return (Just hashStr, pids)
else fail $ "Bad hash in file " ++ fileName
else return (Nothing, inventory)
return (hash, readPatchIds patchIds)
where
inventory = skipPristine pristineAndInventory
(mbStartingWith, pistr) = BC.break ('\n' ==) inventory
copyHashedInventory :: RepoPatch p => Repository rt p wR wU wT -> RemoteDarcs -> String -> IO ()
copyHashedInventory outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do
let outloc = repoLocation outrepo
createDirectoryIfMissing False (outloc ++ "/" ++ inventoriesDirPath)
copyFileOrUrl remote (inloc </> darcsdir </> hashedInventory)
(outloc </> darcsdir </> hashedInventory)
Uncachable
debugMessage "Done copying hashed inventory."
writeAndReadPatch :: (IsRepoType rt, RepoPatch p) => Cache -> Compression
-> PatchInfoAnd rt p wX wY -> IO (PatchInfoAnd rt p wX wY)
writeAndReadPatch c compr p = do
(i, h) <- writePatchIfNecessary c compr p
unsafeInterleaveIO $ readp h i
where
parse i h = do
debugMessage ("Rereading patch file: "++ showDoc (displayPatchInfo i))
(fn, ps) <- fetchFileUsingCache c HashedPatchesDir h
case readPatch ps of
Just x -> return x
Nothing -> fail $ unlines [ "Couldn't parse patch file " ++ fn
, "which is"
, renderString $ displayPatchInfo i]
readp h i = do Sealed x <- createHashed h (parse i)
return . patchInfoAndPatch i $ unsafeCoerceP x
writeTentativeInventory :: RepoPatch p => Cache -> Compression
-> PatchSet rt p Origin wX -> IO ()
writeTentativeInventory cache compr patchSet = do
debugMessage "in writeTentativeInventory..."
createDirectoryIfMissing False inventoriesDirPath
beginTedious tediousName
hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet
endTedious tediousName
debugMessage "still in writeTentativeInventory..."
case hsh of
Nothing -> writeBinFile (darcsdir </> tentativeHashedInventory) B.empty
Just h -> do
content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h
writeAtomicFilePS (darcsdir </> tentativeHashedInventory) content
where
tediousName = "Writing inventory"
writeInventoryPrivate :: RepoPatch p => PatchSet rt p Origin wX
-> IO (Maybe String)
writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing
writeInventoryPrivate (PatchSet NilRL ps) = do
inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps
let inventorylist = hcat (map pihash $ reverse inventory)
hash <- writeHashFile cache compr HashedInventoriesDir inventorylist
return $ Just hash
writeInventoryPrivate
(PatchSet xs@(_ :<: Tagged t _ _) x) = do
resthash <- write_ts xs
finishedOneIO tediousName $ fromMaybe "" resthash
inventory <- sequence $ mapRL (writePatchIfNecessary cache compr)
(NilRL :<: t +<+ x)
let inventorylist = hcat (map pihash $ reverse inventory)
inventorycontents =
case resthash of
Just h -> text ("Starting with inventory:\n" ++ h) $$
inventorylist
Nothing -> inventorylist
hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents
return $ Just hash
where
write_ts :: RepoPatch p => RL (Tagged rt p) Origin wX
-> IO (Maybe String)
write_ts (_ :<: Tagged _ (Just h) _) = return (Just h)
write_ts (tts :<: Tagged _ Nothing pps) =
writeInventoryPrivate $ PatchSet tts pps
write_ts NilRL = return Nothing
writePatchIfNecessary :: RepoPatch p => Cache -> Compression
-> PatchInfoAnd rt p wX wY -> IO (PatchInfo, String)
writePatchIfNecessary c compr hp = infohp `seq`
case extractHash hp of
Right h -> return (infohp, h)
Left p -> (\h -> (infohp, h)) <$>
writeHashFile c compr HashedPatchesDir (showPatch ForStorage p)
where
infohp = info hp
pihash :: (PatchInfo, String) -> Doc
pihash (pinf, hash) = showPatchInfo ForStorage pinf $$ text ("hash: " ++ hash ++ "\n")
listInventoriesWith :: (String -> String
-> IO (Maybe String, [(PatchInfo, String)]))
-> String -> String -> IO [String]
listInventoriesWith f darcsDir hashedRepoDir = do
mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory
followStartingWiths mbStartingWithInv
where
getStartingWithHash invDir inv =
fst <$> f invDir inv
followStartingWiths Nothing = return []
followStartingWiths (Just startingWith) = do
mbNextInv <- getStartingWithHash (darcsDir </> inventoriesDir) startingWith
(startingWith :) <$> followStartingWiths mbNextInv
listInventoriesBucketedWith :: (String -> String
-> IO (Maybe String, [(PatchInfo, String)]))
-> String -> String -> IO [String]
listInventoriesBucketedWith f darcsDir hashedRepoDir = do
mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory
followStartingWiths mbStartingWithInv
where
getStartingWithHash invDir inv =
fst <$> f invDir inv
followStartingWiths Nothing = return []
followStartingWiths (Just startingWith) = do
mbNextInv <- getStartingWithHash
(darcsDir </> inventoriesDir </> bucketFolder startingWith) startingWith
(startingWith :) <$> followStartingWiths mbNextInv
listInventories :: IO [String]
listInventories = listInventoriesWith readInventoryPrivate darcsdir darcsdir
readInventoryLocalPrivate :: String -> String
-> IO (Maybe String, [(PatchInfo, String)])
readInventoryLocalPrivate dir invName = do
b <- doesFileExist (dir </> invName)
if b then readInventoryPrivate dir invName
else return (Nothing, [])
listInventoriesLocal :: IO [String]
listInventoriesLocal = listInventoriesWith readInventoryLocalPrivate darcsdir darcsdir
listInventoriesRepoDir :: String -> IO [String]
listInventoriesRepoDir repoDir = do
gCacheDir' <- globalCacheDir
let gCacheInvDir = fromJust gCacheDir'
listInventoriesBucketedWith readInventoryLocalPrivate gCacheInvDir (repoDir </> darcsdir)
listPatchesLocal :: String -> IO [String]
listPatchesLocal darcsDir = do
inventory <- readInventoryPrivate darcsDir hashedInventory
followStartingWiths (fst inventory) (getPatches inventory)
where
followStartingWiths Nothing patches = return patches
followStartingWiths (Just startingWith) patches = do
inv <- readInventoryLocalPrivate (darcsDir </> inventoriesDir) startingWith
(patches++) <$> followStartingWiths (fst inv) (getPatches inv)
getPatches inv = map snd (snd inv)
listPatchesLocalBucketed :: String -> String -> IO [String]
listPatchesLocalBucketed darcsDir hashedRepoDir = do
inventory <- readInventoryPrivate hashedRepoDir hashedInventory
followStartingWiths (fst inventory) (getPatches inventory)
where
followStartingWiths Nothing patches = return patches
followStartingWiths (Just startingWith) patches = do
inv <- readInventoryLocalPrivate
(darcsDir </> inventoriesDir </> bucketFolder startingWith) startingWith
(patches++) <$> followStartingWiths (fst inv) (getPatches inv)
getPatches inv = map snd (snd inv)
readPatchIds :: B.ByteString -> [(PatchInfo, String)]
readPatchIds inv | B.null inv = []
readPatchIds inv = case parseStrictly readPatchInfo inv of
Nothing -> []
Just (pinfo, r) ->
case readHash r of
Nothing -> []
Just (h, r') -> (pinfo, h) : readPatchIds r'
where
readHash :: B.ByteString -> Maybe (String, B.ByteString)
readHash s = let s' = dropSpace s
(l, r) = BC.break ('\n' ==) s'
(kw, h) = BC.break (' ' ==) l in
if kw /= BC.pack "hash:" || B.length h <= 1
then Nothing
else Just (BC.unpack $ B.tail h, r)
copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()
copyPristine cache dir iname wwd = do
i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable
debugMessage $ "Copying hashed pristine tree: " ++ inv2pris i
let tediousName = "Copying pristine"
beginTedious tediousName
copyHashed tediousName cache wwd $ inv2pris i
endTedious tediousName
copyPartialsPristine :: FilePathLike fp => Cache -> String
-> String -> [fp] -> IO ()
copyPartialsPristine c d iname fps = do
i <- fetchFilePS (d ++ "/" ++ iname) Uncachable
copyPartialsHashed c (inv2pris i) fps
pris2inv :: String -> B.ByteString -> Doc
pris2inv h inv = invisiblePS pristineName <> text h $$
invisiblePS (skipPristine inv)
inv2pris :: B.ByteString -> String
inv2pris inv = case tryDropPristineName inv of
Just rest -> case takeHash rest of
Just (h, _) -> h
Nothing -> error "Bad hash in inventory!"
Nothing -> sha256sum B.empty
skipPristine :: B.ByteString -> B.ByteString
skipPristine ps = case tryDropPristineName ps of
Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest
Nothing -> ps
tryDropPristineName :: B.ByteString -> Maybe B.ByteString
tryDropPristineName input =
if prefix == pristineName then Just rest else Nothing
where
(prefix, rest) = B.splitAt (B.length pristineName) input
unrevertUrl :: Repository rt p wR wU wT -> String
unrevertUrl r = repoLocation r ++ "/"++darcsdir++"/patches/unrevert"
tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine
data UpdatePristine = UpdatePristine
| DontUpdatePristine
| DontUpdatePristineNorRevert deriving Eq
tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree)
=> UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ up r c v uw ps =
foldFL_M (\r' p -> tentativelyAddPatch_ up r' c v uw p) r ps
tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)
=> UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch_ up r compr verb uw p =
withRepoLocation r $ do
void $ addToTentativeInventory (repoCache r) compr p
when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."
applyToTentativePristine r verb p
debugMessage "Updating pending..."
tentativelyRemoveFromPending r uw p
return (coerceT r)
applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q)
=> Repository rt p wR wU wT
-> Verbosity
-> q wT wY
-> IO ()
applyToTentativePristine r verb p =
withRepoLocation r $
do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p
applyToTentativePristineCwd p
applyToTentativePristineCwd :: (ApplyState p ~ Tree, Patchy p) => p wX wY
-> IO ()
applyToTentativePristineCwd p = do
tentativePristine <- gzReadFilePS tentativePristinePath
let tentativePristineHash = inv2pris tentativePristine
newPristineHash <- applyToHashedPristine tentativePristineHash p
writeDocBinFile tentativePristinePath $
pris2inv newPristineHash tentativePristine
tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine
tentativelyRemovePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches_ up r compr uw ps =
withRepoLocation r $ do
when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."
prepend r uw $ effect ps
unless (up == DontUpdatePristineNorRevert) $ removeFromUnrevertContext r ps
debugMessage "Removing changes from tentative inventory..."
if formatHas HashedInventory (repoFormat r)
then do removeFromTentativeInventory r compr ps
when (up == UpdatePristine) $
applyToTentativePristineCwd $
progressFL "Applying inverse to pristine" $ invert ps
else fail Old.oldRepoFailMsg
return (coerceT r)
tentativelyReplacePatches :: forall rt p wR wU wT wX
. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> Verbosity
-> FL (PatchInfoAnd rt p) wX wT
-> IO ()
tentativelyReplacePatches repository compr uw verb ps =
do let ps' = filterOutFLFL (namedIsInternal . hopefully) ps
repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps'
mapAdd repository' ps'
where mapAdd :: Repository rt p wM wL wI
-> FL (PatchInfoAnd rt p) wI wJ
-> IO ()
mapAdd _ NilFL = return ()
mapAdd r (a:>:as) =
do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a
mapAdd r' as
finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> UpdateWorking
-> Compression
-> IO ()
finalizeRepositoryChanges r updateWorking compr
| formatHas HashedInventory (repoFormat r) =
withRepoLocation r $ do
debugMessage "Finalizing changes..."
withSignalsBlocked $ do
finalizeTentativeChanges r compr
recordedState <- readRecorded r
finalizePending r updateWorking recordedState
debugMessage "Done finalizing changes..."
ps <- readRepo r
doesPatchIndexExist (repoLocation r) >>= (`when` createOrUpdatePatchIndexDisk r ps)
updateIndex r
| otherwise = fail Old.oldRepoFailMsg
revertRepositoryChanges :: RepoPatch p
=> Repository rt p wR wU wT
-> UpdateWorking
-> IO ()
revertRepositoryChanges r uw
| formatHas HashedInventory (repoFormat r) =
withRepoLocation r $
do removeFileMayNotExist (pendingName ++ ".tentative")
Sealed x <- readPending r
setTentativePending r uw x
when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName
revertTentativeChanges
| otherwise = fail Old.oldRepoFailMsg
removeFromUnrevertContext :: forall rt p wR wU wT wX
. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> FL (PatchInfoAnd rt p) wX wT
-> IO ()
removeFromUnrevertContext r ps = do
Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL))
remove_from_unrevert_context_ bundle
where unrevert_impossible =
do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"
if confirmed then removeFileMayNotExist (unrevertUrl r)
else fail "Cancelled."
unrevert_patch_bundle :: IO (SealedPatchSet rt p Origin)
unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl r)
case scanBundle pf of
Right foo -> return foo
Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
remove_from_unrevert_context_ :: PatchSet rt p Origin wZ -> IO ()
remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()
remove_from_unrevert_context_ bundle =
do debugMessage "Adjusting the context of the unrevert changes..."
debugMessage $ "Removing "++ show (lengthFL ps) ++
" patches in removeFromUnrevertContext!"
ref <- readTentativeRepo r (repoLocation r)
let withSinglet :: Sealed (FL ppp wXxx)
-> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO ()
withSinglet (Sealed (x :>: NilFL)) j = j x
withSinglet _ _ = return ()
withSinglet (mergeThem ref bundle) $ \h_us ->
case commuteRL (reverseFL ps :> h_us) of
Nothing -> unrevert_impossible
Just (us' :> _) ->
case removeFromPatchSet ps ref of
Nothing -> unrevert_impossible
Just common ->
do debugMessage "Have now found the new context..."
bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL)
writeDocBinFile (unrevertUrl r) bundle'
debugMessage "Done adjusting the context of the unrevert changes!"
cleanRepository :: RepoPatch p => Repository rt p wR wU wT -> IO ()
cleanRepository r = cleanPristine r >> cleanInventories r >> cleanPatches r
createPristineDirectoryTree :: RepoPatch p => Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO ()
createPristineDirectoryTree r reldir wwd
| formatHas HashedInventory (repoFormat r) =
do createDirectoryIfMissing True reldir
withCurrentDirectory reldir $
copyPristine (repoCache r) (repoLocation r) (darcsdir++"/hashed_inventory") wwd
| otherwise = fail Old.oldRepoFailMsg
createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p)
=> Repository rt p wR wU wT
-> [fp]
-> FilePath
-> IO ()
createPartialsPristineDirectoryTree r prefs dir
| formatHas HashedInventory (repoFormat r) =
do createDirectoryIfMissing True dir
withCurrentDirectory dir $
copyPartialsPristine (repoCache r) (repoLocation r)
(darcsdir++"/hashed_inventory") prefs
| otherwise = fail Old.oldRepoFailMsg
withRecorded :: RepoPatch p
=> Repository rt p wR wU wT
-> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a)
-> IO a
withRecorded repository mk_dir f
= mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir
f d
withTentative :: forall rt p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a)
-> IO a
withTentative r mk_dir f
| formatHas HashedInventory (repoFormat r) =
mk_dir $ \d -> do copyPristine
(repoCache r)
(repoLocation r)
(darcsdir++"/tentative_pristine")
WithWorkingDir
f d
| otherwise = fail Old.oldRepoFailMsg
reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> Compression
-> UpdateWorking
-> Verbosity
-> IO ()
reorderInventory repository compr uw verb = do
debugMessage "Reordering the inventory."
PatchSet _ ps <- misplacedPatches `fmap` readRepo repository
tentativelyReplacePatches repository compr uw verb $ reverseRL ps
finalizeTentativeChanges repository compr
debugMessage "Done reordering the inventory."
misplacedPatches :: forall rt p wS wX . RepoPatch p
=> PatchSet rt p wS wX
-> PatchSet rt p wS wX
misplacedPatches ps =
case filter isTag $ mapRL info $ patchSet2RL ps of
[] -> ps
(lt:_) ->
case splitOnTag lt ps of
Just (PatchSet ts xs :> r) -> PatchSet ts (xs+<+r)
_ -> impossible
readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> IO (PatchSet rt p Origin wR)
readRepo r
| formatHas HashedInventory (repoFormat r) = readRepoHashed r (repoLocation r)
| otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r)
return $ unsafeCoerceP ps
repoXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> IO SHA1
repoXor repo = do
hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readRepo repo
return $ foldl' sha1Xor zero hashes