#include "gadts.h"
module Darcs.Repository.HashedRepo ( revertTentativeChanges, finalizeTentativeChanges,
cleanPristine,
copyPristine, copyPartialsPristine,
applyToTentativePristine,
addToTentativeInventory, removeFromTentativeInventory,
readRepo, readTentativeRepo, writeAndReadPatch,
writeTentativeInventory, copyRepo,
readHashedPristineRoot, pris2inv, copySources
) where
import System.Directory ( createDirectoryIfMissing )
import System.FilePath.Posix( (</>) )
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( stderr, hPutStrLn )
import Data.List ( delete, filter )
import Control.Monad ( unless )
import Workaround ( renameFile )
import Darcs.Flags ( DarcsFlag, Compression )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath )
import Darcs.Repository.Cache ( Cache(..), CacheLoc(..), fetchFileUsingCache,
speculateFilesUsingCache, writeFileUsingCache,
unionCaches, repo2cache, okayHash, takeHash,
HashedDir(..),WritableOrNot(..), hashedDir,
peekInCache )
import qualified Darcs.Repository.Cache as DarcsCache
import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,
cleanHashdir )
import Darcs.Repository.InternalTypes ( Repository(..), extractCache, modifyCache )
import Darcs.Repository.Prefs ( globalCacheDir )
import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, info,
extractHash, createHashed )
import Darcs.Patch ( RepoPatch, Patchy, showPatch, readPatch, apply )
import Darcs.Patch.Depends ( commuteToEnd, slightlyOptimizePatchset )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, humanFriendly, readPatchInfo )
import Darcs.Witnesses.Ordered ( unsafeCoerceP, reverseRL, reverseFL, (+<+) )
import ByteStringUtils ( gzReadFilePS, dropSpace )
import qualified Data.ByteString as B (null, length, empty
,tail, take, drop, ByteString)
import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack)
import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS )
import Crypt.SHA256 ( sha256sum )
import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) )
import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile )
import Darcs.Utils ( withCurrentDirectory )
import Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )
#include "impossible.h"
import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>>)(..), mapRL, mapFL )
import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal )
import Darcs.Global ( darcsdir )
import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed,
writeDarcsHashed, readDarcsHashedDir, darcsLocation,
decodeDarcsHash, decodeDarcsSize )
import Storage.Hashed.Tree( treeHash, ItemType(..) )
import Storage.Hashed.Hash( encodeBase16, Hash(..) )
applyHashed' fs root p = do case root of
(SHA256 _) -> return ()
_ -> fail $ "Cannot handle hash: " ++ show root
s <- readDarcsHashedNosize "_darcs/pristine.hashed" root
(_, t) <- (hashedTreeIO (apply fs p) s "_darcs/pristine.hashed")
return $ BC.unpack . encodeBase16 $ treeHash t
applyHashed :: Patchy q => [DarcsFlag] -> String -> q C(x y) -> IO String
applyHashed fs h p = applyHashed' fs hash p `catch` \_ -> do
hPutStrLn stderr warn
inv <- gzReadFilePS invpath
let oldroot = BC.pack $ inv2pris inv
oldroot_hash = decodeDarcsHash oldroot
oldroot_size = decodeDarcsSize oldroot
old <- readDarcsHashed "_darcs/pristine.hashed" (oldroot_size, oldroot_hash)
root <- writeDarcsHashed old "_darcs/pristine.hashed"
let newroot = BC.unpack $ encodeBase16 root
writeDocBinFile invpath $ pris2inv newroot inv
cleanHashdir (Ca []) HashedPristineDir [newroot]
hPutStrLn stderr "Pristine conversion done..."
applyHashed' fs root p
where invpath = darcsdir ++ "/hashed_inventory"
hash = decodeDarcsHash $ BC.pack h
warn = "WARNING: Doing a one-time conversion of pristine format.\n" ++
"This may take a while. The new format is backwards-compatible."
revertTentativeChanges :: IO ()
revertTentativeChanges =
do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory")
i <- gzReadFilePS (darcsdir++"/hashed_inventory")
writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i
finalizeTentativeChanges :: RepoPatch p => Repository p C(r u t) -> Compression -> IO ()
finalizeTentativeChanges r compr =
do let t = darcsdir++"/tentative_hashed_inventory"
debugMessage "Optimizing the inventory..."
ps <- readTentativeRepo r "."
writeTentativeInventory (extractCache r) compr ps
i <- gzReadFilePS t
p <- gzReadFilePS $ darcsdir++"/tentative_pristine"
writeDocBinFile t $ pris2inv (inv2pris p) i
renameFile t $ darcsdir++"/hashed_inventory"
readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String)
readHashedPristineRoot (Repo d _ _ _) =
withCurrentDirectory d $ do
i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\_ -> return Nothing)
return $ inv2pris `fmap` i
cleanPristine :: Repository p C(r u t) -> IO ()
cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $
do
debugMessage "Cleaning out the pristine cache..."
i <- gzReadFilePS (darcsdir++"/hashed_inventory")
cleanHashdir (extractCache r) HashedPristineDir [inv2pris i]
addToTentativeInventory :: RepoPatch p => Cache -> Compression
-> PatchInfoAnd p C(x y) -> IO FilePath
addToTentativeInventory c compr p =
do hash <- snd `fmap` writePatchIfNecesary c compr p
appendDocBinFile (darcsdir++"/tentative_hashed_inventory") $ showPatchInfo $ info p
appendBinFile (darcsdir++"/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n"
return $ darcsdir++"/patches/" ++ hash
removeFromTentativeInventory :: RepoPatch p => Repository p C(r u t) -> Compression
-> FL (PatchInfoAnd p) C(x t) -> IO ()
removeFromTentativeInventory repo compr to_remove =
do allpatches <- readTentativeRepo repo "."
_ :>> skipped <- return $ commuteToEnd (reverseFL to_remove) allpatches
okay <- simpleRemoveFromTentativeInventory repo compr
(mapFL info to_remove ++ mapRL info skipped)
unless okay $ bug "bug in HashedRepo.removeFromTentativeInventory"
sequence_ $ mapFL (addToTentativeInventory (extractCache repo) compr) (reverseRL skipped)
simpleRemoveFromTentativeInventory :: forall p C(r u t). RepoPatch p =>
Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool
simpleRemoveFromTentativeInventory repo compr pis = do
inv <- readTentativeRepo repo "."
case cut_inv pis inv of
Nothing -> return False
Just (Sealed inv') -> do writeTentativeInventory (extractCache repo) compr inv'
return True
where cut_inv :: [PatchInfo] -> PatchSet p C(start x) -> Maybe (SealedPatchSet p C(start))
cut_inv [] x = Just $ seal x
cut_inv x (PatchSet NilRL (Tagged t _ ps :<: ts))
= cut_inv x (PatchSet (t :<: ps) ts)
cut_inv xs (PatchSet (hp:<:r) ts)
| info hp `elem` xs = cut_inv (info hp `delete` xs) (PatchSet r ts)
cut_inv _ _ = Nothing
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
readRepo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin r))
readRepo repo d = do
realdir <- toPath `fmap` ioAbsoluteOrRemote d
Sealed ps <- readRepoPrivate (extractCache repo) realdir "hashed_inventory" `catch`
(\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir)
ioError e)
return $ unsafeCoerceP ps
readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin t))
readTentativeRepo repo d = do
realdir <- toPath `fmap` ioAbsoluteOrRemote d
Sealed ps <- readRepoPrivate (extractCache repo) realdir "tentative_hashed_inventory" `catch`
(\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir)
ioError e)
return $ unsafeCoerceP ps
readRepoPrivate :: RepoPatch p => Cache -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin))
readRepoPrivate cache d iname =
do inventory <- readInventoryPrivate cache (d </> "_darcs") iname
parseinvs inventory
where read_patches :: RepoPatch p => [(PatchInfo, String)]
-> IO (Sealed (RL (PatchInfoAnd p) C(x)))
read_patches [] = return $ seal NilRL
read_patches allis@((i1,h1):is1) =
lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest)
(rp is1)
(createHashed h1 (const $ speculate h1 allis >> parse i1 h1))
where rp :: RepoPatch p => [(PatchInfo, String)]
-> IO (Sealed (RL (PatchInfoAnd p) C(x)))
rp [] = return $ seal NilRL
rp [(i,h),(il,hl)] =
lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)
(rp [(il,hl)])
(createHashed h (const $ speculate h (reverse allis) >> parse i h))
rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)
(rp is)
(createHashed h (parse i))
read_tag :: RepoPatch p => (PatchInfo, String) -> IO (Sealed (PatchInfoAnd p C(x)))
read_tag (i,h) = mapSeal (patchInfoAndPatch i) `fmap` 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 :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x)))
parse i h = do debugMessage ("Reading patch file: "++ show (humanFriendly 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 $ humanFriendly i]
parseinvs :: RepoPatch p => (Maybe String, [(PatchInfo, String)])
-> IO (SealedPatchSet p C(Origin))
parseinvs (Nothing, ris) = mapSeal (\ps -> PatchSet ps NilRL)
`fmap` (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 `fmap`
unsafeInterleaveIO (read_ts t h)
Sealed ps <- unseal seal `fmap`
unsafeInterleaveIO (read_patches $
reverse ris)
return $ seal $ PatchSet ps ts
read_ts :: RepoPatch p => (PatchInfo, String) -> String -> IO (Sealed (RL (Tagged p) C(Origin)))
read_ts tag0 h0 =
do contents <- unsafeInterleaveIO $ readTaggedInventory cache h0
let is = reverse $ case contents of (Just _, _:ris0) -> ris0
(Nothing, ris0) -> ris0
(Just _, []) -> bug "inventory without tag!!!!"
Sealed ts <- fmap (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 `fmap` unsafeInterleaveIO (read_patches is)
Sealed tag00 <- read_tag tag0
return $ seal $ Tagged tag00 (Just h0) ps :<: ts
lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z))
-> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b))))
-> IO (Sealed (r C(x)))
lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap`
unsafeInterleaveIO iox
Sealed y <- unseal seal `fmap`
unsafeInterleaveIO ioy
return $ seal $ f y x
readTaggedInventory :: Cache -> String -> IO (Maybe String, [(PatchInfo, String)])
readTaggedInventory cache ihash = do
(fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash
let i = skipPristine i_and_p
(rest,str) <- case BC.break ((==)'\n') i of
(swt,pistr) | swt == BC.pack "Starting with inventory:" ->
case BC.break ((==)'\n') $ B.tail pistr of
(h,thisinv) | okayHash hash -> return (Just hash, thisinv)
where hash = BC.unpack h
_ -> fail $ "Bad hash in file " ++ fn
_ -> return (Nothing,i)
return (rest, readPatchIds str)
copyRepo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO ()
copyRepo repo@(Repo outr _ _ _) opts inr = do
createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories")
copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory")
Uncachable
copySources repo inr
debugMessage "Done copying hashed inventory."
copySources :: RepoPatch p => Repository p C(r u t) -> String -> IO ()
copySources repo@(Repo outr _ _ _) inr = do
let repoCache = extractCache $ modifyCache repo dropGlobalCaches
appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` repoCache )
where
dropGlobalCaches (Ca cache) = Ca $ filter notGlobalCache cache
notGlobalCache xs = case xs of
Cache DarcsCache.Directory _ _ -> False
_ -> True
writeAndReadPatch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y)
-> IO (PatchInfoAnd p C(x y))
writeAndReadPatch c compr p = do (i,h) <- writePatchIfNecesary c compr p
unsafeInterleaveIO $ readp h i
where parse i h = do debugMessage ("Rereading patch file: "++ show (humanFriendly 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 $ humanFriendly i]
readp h i = do Sealed x <- createHashed h (parse i)
return $ patchInfoAndPatch i $ unsafeCoerceP x
writeTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(Origin x) -> IO ()
writeTentativeInventory cache compr = writeEitherInventory cache compr "tentative_hashed_inventory"
writeEitherInventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(Origin x) -> IO ()
writeEitherInventory cache compr iname x =
do debugMessage "in writeEitherInventory..."
createDirectoryIfMissing False $ "_darcs/inventories"
let k = "Writing inventory"
beginTedious k
hsh <- writeInventoryPrivate cache k compr $ slightlyOptimizePatchset x
endTedious k
debugMessage "still in writeEitherInventory..."
case hsh of
Nothing -> writeBinFile ("_darcs" </> iname) ""
Just h -> fmap snd (fetchFileUsingCache cache HashedInventoriesDir h)
>>= writeAtomicFilePS ("_darcs" </> iname)
writeInventoryPrivate :: RepoPatch p => Cache -> String -> Compression
-> PatchSet p C(Origin x) -> IO (Maybe String)
writeInventoryPrivate _ _ _ (PatchSet NilRL NilRL) = return Nothing
writeInventoryPrivate cache _ compr (PatchSet x NilRL) =
do inventory <- sequence $ mapRL (writePatchIfNecesary cache compr) x
let inventorylist = hcat (map pihash $ reverse inventory)
hash <- writeHashFile cache compr HashedInventoriesDir inventorylist
return $ Just hash
writeInventoryPrivate cache k compr (PatchSet x xs@(Tagged t _ _ :<: _)) =
do resthash <- write_ts xs
finishedOneIO k $ maybe "" id resthash
inventory <- sequence $ mapRL (writePatchIfNecesary cache compr) (x+<+t:<:NilRL)
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 p) C(Origin x) -> IO (Maybe String)
write_ts (Tagged _ (Just h) _ :<: _) = return (Just h)
write_ts (Tagged _ Nothing pps :<: tts) =
writeInventoryPrivate cache k compr $ PatchSet pps tts
write_ts NilRL = return Nothing
writePatchIfNecesary :: RepoPatch p => Cache -> Compression
-> PatchInfoAnd p C(x y) -> IO (PatchInfo, String)
writePatchIfNecesary c compr hp =
seq infohp $ case extractHash hp of
Right h -> return (infohp, h)
Left p -> (\h -> (infohp, h)) `fmap`
writeHashFile c compr HashedPatchesDir (showPatch p)
where infohp = info hp
pihash :: (PatchInfo,String) -> Doc
pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n")
readInventoryPrivate :: Cache -> String -> String -> IO (Maybe String, [(PatchInfo, String)])
readInventoryPrivate _ d iname = do
i <- skipPristine `fmap` fetchFilePS (d </> iname) Uncachable
(rest,str) <- case BC.break ((==)'\n') i of
(swt,pistr) | swt == BC.pack "Starting with inventory:" ->
case BC.break ((==)'\n') $ B.tail pistr of
(h,thisinv) | okayHash hash -> return (Just hash, thisinv)
where hash = BC.unpack h
_ -> fail $ "Bad hash in " ++ toPath d ++ "/_darcs/" ++ iname
_ -> return (Nothing, i)
return (rest, readPatchIds str)
readInventories :: Cache -> String -> IO [[(PatchInfo, String)]]
readInventories cache ihash = do
(fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash
let i = skipPristine i_and_p
(rest,str) <- case BC.break ((==)'\n') i of
(swt,pistr) | swt == BC.pack "Starting with inventory:" ->
case BC.break ((==)'\n') $ B.tail pistr of
(h,thisinv) | okayHash $ BC.unpack h ->
do r <- unsafeInterleaveIO $
readInventories cache (BC.unpack h)
return (r,thisinv)
_ -> fail $ "Bad hash in file " ++ fn
_ -> return ([],i)
return $ reverse (readPatchIds str) : rest
readPatchIds :: B.ByteString -> [(PatchInfo, String)]
readPatchIds inv | B.null inv = []
readPatchIds inv = case readPatchInfo inv of
Nothing -> []
Just (pinfo,r) ->
case readHash r of
Nothing -> []
Just (h,r') -> (pinfo,h) : readPatchIds r'
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)
applyPristine :: Patchy q => [DarcsFlag] -> String -> String -> q C(x y) -> IO ()
applyPristine opts d iname p =
do i <- gzReadFilePS (d++"/"++iname)
h <- applyHashed opts (inv2pris i) p
writeDocBinFile (d++"/"++iname) $ pris2inv h i
applyToTentativePristine :: Patchy q => [DarcsFlag] -> q C(x y) -> IO ()
applyToTentativePristine opts p = applyPristine opts "." (darcsdir++"/tentative_pristine") p
copyPristine :: Cache -> Compression -> String -> String -> IO ()
copyPristine c compr d iname = do
i <- fetchFilePS (d++"/"++iname) Uncachable
debugMessage $ "Copying hashed pristine tree: "++inv2pris i
let k = "Copying pristine"
beginTedious k
copyHashed k c compr $ inv2pris i
endTedious k
copyPartialsPristine :: FilePathLike fp =>
Cache -> Compression -> String -> String -> [fp] -> IO ()
copyPartialsPristine c compr d iname fps =
do i <- fetchFilePS (d++"/"++iname) Uncachable
copyPartialsHashed c compr (inv2pris i) fps
inv2pris :: B.ByteString -> String
inv2pris inv | B.take pristineNameLength inv == pristineName =
case takeHash $ B.drop pristineNameLength inv of
Just (h,_) -> h
Nothing -> error "Bad hash in inventory!"
| otherwise = sha256sum B.empty
pris2inv :: String -> B.ByteString -> Doc
pris2inv h inv = invisiblePS pristineName <> text h $$ invisiblePS (skipPristine inv)
pristineName :: B.ByteString
pristineName = BC.pack "pristine:"
skipPristine :: B.ByteString -> B.ByteString
skipPristine ps
| B.take pristineNameLength ps == pristineName = B.drop 1 $ BC.dropWhile (/= '\n') $
B.drop pristineNameLength ps
| otherwise = ps
pristineNameLength :: Int
pristineNameLength = B.length pristineName