#include "gadts.h"
module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes,
slurp_pristine, sync_repo, clean_pristine,
copy_pristine, copy_partials_pristine, pristine_from_working,
apply_to_tentative_pristine, replacePristine,
replacePristineFromSlurpy,
add_to_tentative_inventory, remove_from_tentative_inventory,
read_repo, read_tentative_repo, write_and_read_patch,
write_tentative_inventory, copy_repo, slurp_all_but_darcs,
readHashedPristineRoot
) where
import System.Directory ( doesFileExist, createDirectoryIfMissing )
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( stderr, hPutStrLn )
import Data.List ( delete )
import Control.Monad ( unless )
import Workaround ( renameFile )
import Darcs.Flags ( DarcsFlag, Compression )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath )
import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, speculateFileUsingCache,
writeFileUsingCache,
unionCaches, repo2cache, okayHash, takeHash,
HashedDir(..), hashedDir )
import Darcs.Repository.HashedIO ( applyHashed, slurpHashedPristine,
copyHashed, syncHashedPristine, copyPartialsHashed,
writeHashedPristine, clean_hashdir )
import Darcs.Repository.InternalTypes ( Repository(..), extractCache )
import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info,
extractHash, createHashed )
import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, slurp_remove, slurp )
import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch )
import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo )
import Darcs.Ordered ( unsafeCoerceP, (:<)(..) )
import Darcs.Patch.FileName ( fp2fn )
import ByteStringUtils ( gzReadFilePS, dropSpace )
import qualified Data.ByteString as B (null, length, readFile, 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 SHA1 ( sha1PS )
import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) )
import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile )
import Darcs.Utils ( withCurrentDirectory )
import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO )
#include "impossible.h"
import Darcs.Ordered ( FL(..), RL(..),
mapRL, mapFL, lengthRL )
import Darcs.Sealed ( Sealed(..), seal, unseal )
import Darcs.Global ( darcsdir )
revert_tentative_changes :: IO ()
revert_tentative_changes =
do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory")
i <- gzReadFilePS (darcsdir++"/hashed_inventory")
writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i
finalize_tentative_changes :: RepoPatch p => Repository p C(r u t) -> Compression -> IO ()
finalize_tentative_changes r compr =
do let t = darcsdir++"/tentative_hashed_inventory"
debugMessage "Optimizing the inventory..."
ps <- read_tentative_repo r "."
write_tentative_inventory (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
clean_pristine :: Repository p C(r u t) -> IO ()
clean_pristine r@(Repo d _ _ _) = withCurrentDirectory d $
do
debugMessage "Cleaning out the pristine cache..."
i <- gzReadFilePS (darcsdir++"/hashed_inventory")
clean_hashdir (extractCache r) HashedPristineDir [inv2pris i]
add_to_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) -> IO FilePath
add_to_tentative_inventory c compr p =
do hash <- snd `fmap` write_patch_if_necesary c compr p
appendDocBinFile (darcsdir++"/tentative_hashed_inventory") $ showPatchInfo $ info p
appendBinFile (darcsdir++"/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n"
return $ darcsdir++"/patches/" ++ hash
remove_from_tentative_inventory :: RepoPatch p => Repository p C(r u t) -> Compression
-> FL (Named p) C(x t) -> IO ()
remove_from_tentative_inventory repo compr to_remove =
do allpatches <- read_tentative_repo repo "."
skipped :< _ <- return $ commute_to_end to_remove allpatches
okay <- simple_remove_from_tentative_inventory repo compr
(mapFL patch2patchinfo to_remove ++ mapFL patch2patchinfo skipped)
unless okay $ bug "bug in HashedRepo.remove_from_tentative_inventory"
sequence_ $ mapFL (add_to_tentative_inventory (extractCache repo) compr . n2pia) skipped
simple_remove_from_tentative_inventory :: forall p C(r u t). RepoPatch p =>
Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool
simple_remove_from_tentative_inventory repo compr pis = do
inv <- read_tentative_repo repo "."
case cut_inv pis inv of
Nothing -> return False
Just (Sealed inv') -> do write_tentative_inventory (extractCache repo) compr inv'
return True
where cut_inv :: [PatchInfo] -> PatchSet p C(x) -> Maybe (SealedPatchSet p)
cut_inv [] x = Just $ seal x
cut_inv x (NilRL:<:rs) = cut_inv x rs
cut_inv xs ((hp:<:r):<:rs) | info hp `elem` xs = cut_inv (info hp `delete` xs) (r:<:rs)
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
read_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(r))
read_repo repo d = do
realdir <- toPath `fmap` ioAbsoluteOrRemote d
Sealed ps <- read_repo_private repo realdir "hashed_inventory" `catch`
(\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir)
ioError e)
return $ unsafeCoerceP ps
read_tentative_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(t))
read_tentative_repo repo d = do
realdir <- toPath `fmap` ioAbsoluteOrRemote d
Sealed ps <- read_repo_private repo realdir "tentative_hashed_inventory" `catch`
(\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir)
ioError e)
return $ unsafeCoerceP ps
read_repo_private :: RepoPatch p => Repository p C(r u t)
-> FilePath -> FilePath -> IO (SealedPatchSet p)
read_repo_private repo d iname =
do inventories <- read_inventory_private repo (d++"/"++darcsdir) iname
parseinvs inventories
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))
speculate :: String -> [(PatchInfo, String)] -> IO ()
speculate h is = do already_got_one <- doesFileExist (d++"/"++darcsdir++"/patches/"++h)
unless already_got_one $
mapM_ (speculateFileUsingCache (extractCache repo) HashedPatchesDir . snd) is
parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x)))
parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly i))
(fn,ps) <- fetchFileUsingCache (extractCache repo) HashedPatchesDir h
case readPatch ps of
Just (p,_) -> return p
Nothing -> fail $ unlines ["Couldn't parse file "++fn,
"which is patch",
renderString $ human_friendly i]
parseinvs :: RepoPatch p => [[(PatchInfo, String)]] -> IO (SealedPatchSet p)
parseinvs [] = return $ seal NilRL
parseinvs (i:is) = lift2Sealed (:<:) (parseinvs is) (read_patches i)
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
write_and_read_patch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y)
-> IO (PatchInfoAnd p C(x y))
write_and_read_patch c compr p = do (i,h) <- write_patch_if_necesary c compr p
Sealed x <- createHashed h (parse i)
return $ patchInfoAndPatch i $ unsafeCoerceP x
where parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly 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 $ human_friendly i]
write_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(x) -> IO ()
write_tentative_inventory c compr = write_either_inventory c compr "tentative_hashed_inventory"
copy_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO ()
copy_repo repo@(Repo outr _ _ _) opts inr = do
createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories")
copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory")
Uncachable
appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` extractCache repo)
debugMessage "Done copying hashed inventory."
write_either_inventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(x) -> IO ()
write_either_inventory c compr iname x =
do createDirectoryIfMissing False $ darcsdir++"/inventories"
let k = "Writing inventory"
beginTedious k
tediousSize k (lengthRL x)
hsh <- write_inventory_private k c compr $ slightly_optimize_patchset x
endTedious k
case hsh of
Nothing -> writeBinFile (darcsdir++"/"++iname) ""
Just h -> gzReadFilePS (darcsdir++"/inventories/"++h) >>= writeAtomicFilePS (darcsdir++"/"++iname)
write_inventory_private :: RepoPatch p => String -> Cache -> Compression
-> PatchSet p C(x) -> IO (Maybe String)
write_inventory_private _ _ _ NilRL = return Nothing
write_inventory_private _ _ _ (NilRL:<:NilRL) = return Nothing
write_inventory_private _ _ _ (NilRL:<:_) =
bug "malformed PatchSet in HashedRepo.write_inventory_private"
write_inventory_private k c compr (x:<:xs) =
do resthash <- write_inventory_private k c compr xs
finishedOneIO k (case resthash of Nothing -> ""; Just h -> h)
inventory <- sequence $ mapRL (write_patch_if_necesary c compr) x
let inventorylist = hcat (map pihash $ reverse inventory)
inventorycontents = case resthash of
Just lasthash -> text ("Starting with inventory:\n"++lasthash) $$
inventorylist
_ -> inventorylist
hash <- writeHashFile c compr HashedInventoriesDir inventorycontents
return $ Just hash
write_patch_if_necesary :: RepoPatch p => Cache -> Compression
-> PatchInfoAnd p C(x y) -> IO (PatchInfo, String)
write_patch_if_necesary c compr hp =
case extractHash hp of
Right h -> return (info hp, h)
Left p -> fmap (\h -> (info hp, h)) $ writeHashFile c compr HashedPatchesDir $ showPatch p
pihash :: (PatchInfo,String) -> Doc
pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n")
read_inventory_private :: Repository p C(r u t) -> String -> String
-> IO [[(PatchInfo, String)]]
read_inventory_private repo d iname = do
i <- skip_pristine `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 $ BC.unpack h ->
do r <- unsafeInterleaveIO $ read_inventories
(extractCache repo) (BC.unpack h)
return (r,thisinv)
_ -> fail $ "Bad hash in " ++ d ++ "/"++darcsdir++"/" ++ iname
_ -> return ([],i)
return $ reverse (read_patch_ids str) : rest
read_inventories :: Cache -> String -> IO [[(PatchInfo, String)]]
read_inventories cache ihash = do
(fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash
let i = skip_pristine 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 $
read_inventories cache (BC.unpack h)
return (r,thisinv)
_ -> fail $ "Bad hash in file " ++ fn
_ -> return ([],i)
return $ reverse (read_patch_ids str) : rest
read_patch_ids :: B.ByteString -> [(PatchInfo, String)]
read_patch_ids inv | B.null inv = []
read_patch_ids inv = case readPatchInfo inv of
Nothing -> []
Just (pinfo,r) ->
case readHash r of
Nothing -> []
Just (h,r') -> (pinfo,h) : read_patch_ids 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)
apply_pristine :: Patchy q => Cache -> [DarcsFlag] -> String -> String -> q C(x y) -> IO ()
apply_pristine c opts d iname p =
do i <- gzReadFilePS (d++"/"++iname)
h <- applyHashed c opts (inv2pris i) p
writeDocBinFile (d++"/"++iname) $ pris2inv h i
apply_to_tentative_pristine :: Patchy q => Cache -> [DarcsFlag] -> q C(x y) -> IO ()
apply_to_tentative_pristine c opts p = apply_pristine c opts "." (darcsdir++"/tentative_pristine") p
slurp_pristine :: Cache -> Compression -> String -> String -> IO Slurpy
slurp_pristine c compr d iname = do
i <- fetchFilePS (d++"/"++iname) Uncachable
slurp_pristine_private c compr i
slurp_pristine_private :: Cache -> Compression -> B.ByteString -> IO Slurpy
slurp_pristine_private c compr inv = case inv2pris inv of
h | h == sha1PS B.empty -> return empty_slurpy
| otherwise -> slurpHashedPristine c compr h
pristine_from_working :: Cache -> Compression -> IO ()
pristine_from_working c compr = replacePristine c compr "."
replacePristine :: Cache -> Compression -> FilePath -> IO ()
replacePristine c compr d = do s <- slurp_all_but_darcs d
replacePristineFromSlurpy c compr s
replacePristineFromSlurpy :: Cache -> Compression -> Slurpy -> IO ()
replacePristineFromSlurpy c compr s = do
h <- writeHashedPristine c compr s
let t = darcsdir++"/hashed_inventory"
i <- gzReadFilePS t
writeDocBinFile t $ pris2inv h i
copy_pristine :: Cache -> Compression -> String -> String -> IO ()
copy_pristine 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
sync_repo :: Cache -> IO ()
sync_repo c = do i <- B.readFile $ darcsdir++"/hashed_inventory"
s <- slurp_all_but_darcs "."
beginTedious "Synchronizing pristine"
syncHashedPristine c s $ inv2pris i
copy_partials_pristine :: FilePathLike fp =>
Cache -> Compression -> String -> String -> [fp] -> IO ()
copy_partials_pristine 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 pristine_name_length inv == pristine_name =
case takeHash $ B.drop pristine_name_length inv of
Just (h,_) -> h
Nothing -> error "Bad hash in inventory!"
| otherwise = sha1PS B.empty
pris2inv :: String -> B.ByteString -> Doc
pris2inv h inv = invisiblePS pristine_name <> text h $$ invisiblePS (skip_pristine inv)
pristine_name :: B.ByteString
pristine_name = BC.pack "pristine:"
skip_pristine :: B.ByteString -> B.ByteString
skip_pristine ps
| B.take pristine_name_length ps == pristine_name = B.drop 1 $ BC.dropWhile (/= '\n') $
B.drop pristine_name_length ps
| otherwise = ps
pristine_name_length :: Int
pristine_name_length = B.length pristine_name
slurp_all_but_darcs :: FilePath -> IO Slurpy
slurp_all_but_darcs d = do s <- slurp d
case slurp_remove (fp2fn $ "./"++darcsdir) s of
Nothing -> return s
Just s' -> return s'