1 -- Copyright (C) 2006-2007 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; if not, write to the Free Software Foundation, 15 -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 16 17 {-# OPTIONS_GHC -cpp -fglasgow-exts #-} 18 {-# LANGUAGE CPP, ScopedTypeVariables #-} 19 20 #include "gadts.h" 21 22 module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes, 23 slurp_pristine, sync_repo, clean_pristine, 24 copy_pristine, copy_partials_pristine, pristine_from_working, 25 apply_to_tentative_pristine, 26 replacePristineFromSlurpy, 27 add_to_tentative_inventory, remove_from_tentative_inventory, 28 read_repo, read_tentative_repo, write_and_read_patch, 29 write_tentative_inventory, copy_repo, slurp_all_but_darcs, 30 readHashedPristineRoot 31 ) where 32 33 import System.Directory ( doesFileExist, createDirectoryIfMissing ) 34 import System.IO.Unsafe ( unsafeInterleaveIO ) 35 import System.IO ( stderr, hPutStrLn ) 36 import Data.List ( delete ) 37 import Control.Monad ( unless ) 38 39 import Workaround ( renameFile ) 40 import Darcs.Flags ( DarcsFlag, Compression ) 41 import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) 42 import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath ) 43 import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, speculateFileUsingCache, 44 writeFileUsingCache, 45 unionCaches, repo2cache, okayHash, takeHash, 46 HashedDir(..), hashedDir ) 47 import Darcs.Repository.HashedIO ( applyHashed, slurpHashedPristine, 48 copyHashed, syncHashedPristine, copyPartialsHashed, 49 writeHashedPristine, clean_hashdir ) 50 import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) 51 import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info, 52 extractHash, createHashed ) 53 import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, slurp_remove, slurp ) 54 import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch ) 55 import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset ) 56 import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo ) 57 import Darcs.Ordered ( unsafeCoerceP, (:<)(..) ) 58 import Darcs.Patch.FileName ( fp2fn ) 59 60 import ByteStringUtils ( gzReadFilePS, dropSpace ) 61 import qualified Data.ByteString as B (null, length, readFile, empty 62 ,tail, take, drop, ByteString) 63 import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack) 64 65 import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS ) 66 import SHA1 ( sha1PS ) 67 import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) ) 68 import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile ) 69 import Darcs.Utils ( withCurrentDirectory ) 70 import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO ) 71 #include "impossible.h" 72 import Darcs.Ordered ( FL(..), RL(..), 73 mapRL, mapFL, lengthRL ) 74 import Darcs.Sealed ( Sealed(..), seal, unseal ) 75 import Darcs.Global ( darcsdir ) 76 77 revert_tentative_changes :: IO () 78 revert_tentative_changes = 79 do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory") 80 i <- gzReadFilePS (darcsdir++"/hashed_inventory") 81 writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i 82 83 finalize_tentative_changes :: RepoPatch p => Repository p C(r u t) -> Compression -> IO () 84 finalize_tentative_changes r compr = 85 do let t = darcsdir++"/tentative_hashed_inventory" 86 -- first let's optimize it... 87 debugMessage "Optimizing the inventory..." 88 ps <- read_tentative_repo r "." 89 write_tentative_inventory (extractCache r) compr ps 90 -- then we'll add in the pristine cache, 91 i <- gzReadFilePS t 92 p <- gzReadFilePS $ darcsdir++"/tentative_pristine" 93 writeDocBinFile t $ pris2inv (inv2pris p) i 94 -- and rename it to its final value 95 renameFile t $ darcsdir++"/hashed_inventory" 96 -- note: in general we can't clean the pristine cache, because a 97 -- simultaneous get might be in progress 98 99 readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String) 100 readHashedPristineRoot (Repo d _ _ _) = 101 withCurrentDirectory d $ do 102 i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\_ -> return Nothing) 103 return $ inv2pris `fmap` i 104 105 clean_pristine :: Repository p C(r u t) -> IO () 106 clean_pristine r@(Repo d _ _ _) = withCurrentDirectory d $ 107 do -- we'll remove obsolete bits of our pristine cache 108 debugMessage "Cleaning out the pristine cache..." 109 i <- gzReadFilePS (darcsdir++"/hashed_inventory") 110 clean_hashdir (extractCache r) HashedPristineDir [inv2pris i] 111 112 add_to_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) -> IO FilePath 113 add_to_tentative_inventory c compr p = 114 do hash <- snd `fmap` write_patch_if_necesary c compr p 115 appendDocBinFile (darcsdir++"/tentative_hashed_inventory") $ showPatchInfo $ info p 116 appendBinFile (darcsdir++"/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n" 117 return $ darcsdir++"/patches/" ++ hash 118 119 remove_from_tentative_inventory :: RepoPatch p => Repository p C(r u t) -> Compression 120 -> FL (Named p) C(x t) -> IO () 121 remove_from_tentative_inventory repo compr to_remove = 122 -- FIXME: This algorithm should be *far* simpler. All we need do is 123 -- to to remove the patches from a patchset and then write that 124 -- patchset. The commutation behavior of PatchInfoAnd should track 125 -- which patches need to be rewritten for us. 126 do allpatches <- read_tentative_repo repo "." 127 skipped :< _ <- return $ commute_to_end to_remove allpatches 128 okay <- simple_remove_from_tentative_inventory repo compr 129 (mapFL patch2patchinfo to_remove ++ mapFL patch2patchinfo skipped) 130 unless okay $ bug "bug in HashedRepo.remove_from_tentative_inventory" 131 sequence_ $ mapFL (add_to_tentative_inventory (extractCache repo) compr . n2pia) skipped 132 133 simple_remove_from_tentative_inventory :: forall p C(r u t). RepoPatch p => 134 Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool 135 simple_remove_from_tentative_inventory repo compr pis = do 136 inv <- read_tentative_repo repo "." 137 case cut_inv pis inv of 138 Nothing -> return False 139 Just (Sealed inv') -> do write_tentative_inventory (extractCache repo) compr inv' 140 return True 141 where cut_inv :: [PatchInfo] -> PatchSet p C(x) -> Maybe (SealedPatchSet p) 142 cut_inv [] x = Just $ seal x 143 cut_inv x (NilRL:<:rs) = cut_inv x rs 144 cut_inv xs ((hp:<:r):<:rs) | info hp `elem` xs = cut_inv (info hp `delete` xs) (r:<:rs) 145 cut_inv _ _ = Nothing 146 147 writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String 148 writeHashFile c compr subdir d = do debugMessage $ "Writing hash file to "++(hashedDir subdir) 149 writeFileUsingCache c compr subdir $ renderPS d 150 151 read_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(r)) 152 read_repo repo d = do 153 realdir <- toPath `fmap` ioAbsoluteOrRemote d 154 Sealed ps <- read_repo_private repo realdir "hashed_inventory" `catch` 155 (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) 156 ioError e) 157 return $ unsafeCoerceP ps 158 159 read_tentative_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(t)) 160 read_tentative_repo repo d = do 161 realdir <- toPath `fmap` ioAbsoluteOrRemote d 162 Sealed ps <- read_repo_private repo realdir "tentative_hashed_inventory" `catch` 163 (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) 164 ioError e) 165 return $ unsafeCoerceP ps 166 167 read_repo_private :: RepoPatch p => Repository p C(r u t) 168 -> FilePath -> FilePath -> IO (SealedPatchSet p) 169 read_repo_private repo d iname = 170 do inventories <- read_inventory_private repo (d++"/"++darcsdir) iname 171 parseinvs inventories 172 where read_patches :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) 173 read_patches [] = return $ seal NilRL 174 read_patches allis@((i1,h1):is1) = 175 lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest) 176 (rp is1) 177 (createHashed h1 (const $ speculate h1 allis >> parse i1 h1)) 178 where rp :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x))) 179 rp [] = return $ seal NilRL 180 rp [(i,h),(il,hl)] = 181 lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) 182 (rp [(il,hl)]) 183 (createHashed h (const $ speculate h (reverse allis) >> parse i h)) 184 rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest) 185 (rp is) 186 (createHashed h (parse i)) 187 speculate :: String -> [(PatchInfo, String)] -> IO () 188 speculate h is = do already_got_one <- doesFileExist (d++"/"++darcsdir++"/patches/"++h) 189 unless already_got_one $ 190 mapM_ (speculateFileUsingCache (extractCache repo) HashedPatchesDir . snd) is 191 parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x))) 192 parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly i)) 193 (fn,ps) <- fetchFileUsingCache (extractCache repo) HashedPatchesDir h 194 case readPatch ps of 195 Just (p,_) -> return p 196 Nothing -> fail $ unlines ["Couldn't parse file "++fn, 197 "which is patch", 198 renderString $ human_friendly i] 199 parseinvs :: RepoPatch p => [[(PatchInfo, String)]] -> IO (SealedPatchSet p) 200 parseinvs [] = return $ seal NilRL 201 parseinvs (i:is) = lift2Sealed (:<:) (parseinvs is) (read_patches i) 202 lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z)) 203 -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x))) 204 lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox 205 Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy 206 return $ seal $ f y x 207 208 write_and_read_patch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) 209 -> IO (PatchInfoAnd p C(x y)) 210 write_and_read_patch c compr p = do (i,h) <- write_patch_if_necesary c compr p 211 unsafeInterleaveIO $ readp h i 212 where parse i h = do debugMessage ("Rereading patch file: "++ show (human_friendly i)) 213 (fn,ps) <- fetchFileUsingCache c HashedPatchesDir h 214 case readPatch ps of 215 Just (x,_) -> return x 216 Nothing -> fail $ unlines ["Couldn't parse patch file "++fn, 217 "which is", 218 renderString $ human_friendly i] 219 readp h i = do Sealed x <- createHashed h (parse i) 220 return $ patchInfoAndPatch i $ unsafeCoerceP x 221 222 write_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(x) -> IO () 223 write_tentative_inventory c compr = write_either_inventory c compr "tentative_hashed_inventory" 224 225 copy_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO () 226 copy_repo repo@(Repo outr _ _ _) opts inr = do 227 createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories") 228 copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory") 229 Uncachable -- no need to copy anything but hashed_inventory! 230 appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` extractCache repo) 231 debugMessage "Done copying hashed inventory." 232 233 write_either_inventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(x) -> IO () 234 write_either_inventory c compr iname x = 235 do createDirectoryIfMissing False $ darcsdir++"/inventories" 236 let k = "Writing inventory" 237 beginTedious k 238 tediousSize k (lengthRL x) 239 hsh <- write_inventory_private k c compr $ slightly_optimize_patchset x 240 endTedious k 241 case hsh of 242 Nothing -> writeBinFile (darcsdir++"/"++iname) "" 243 Just h -> gzReadFilePS (darcsdir++"/inventories/"++h) >>= writeAtomicFilePS (darcsdir++"/"++iname) 244 245 write_inventory_private :: RepoPatch p => String -> Cache -> Compression 246 -> PatchSet p C(x) -> IO (Maybe String) 247 write_inventory_private _ _ _ NilRL = return Nothing 248 write_inventory_private _ _ _ (NilRL:<:NilRL) = return Nothing 249 write_inventory_private _ _ _ (NilRL:<:_) = -- This shouldn't be possible, so best to check... 250 bug "malformed PatchSet in HashedRepo.write_inventory_private" 251 write_inventory_private k c compr (x:<:xs) = 252 do resthash <- write_inventory_private k c compr xs 253 finishedOneIO k (case resthash of Nothing -> ""; Just h -> h) 254 inventory <- sequence $ mapRL (write_patch_if_necesary c compr) x 255 let inventorylist = hcat (map pihash $ reverse inventory) 256 inventorycontents = case resthash of 257 Just lasthash -> text ("Starting with inventory:\n"++lasthash) $$ 258 inventorylist 259 _ -> inventorylist 260 hash <- writeHashFile c compr HashedInventoriesDir inventorycontents 261 return $ Just hash 262 263 write_patch_if_necesary :: RepoPatch p => Cache -> Compression 264 -> PatchInfoAnd p C(x y) -> IO (PatchInfo, String) 265 write_patch_if_necesary c compr hp = 266 seq infohp $ case extractHash hp of 267 Right h -> return (infohp, h) 268 Left p -> (\h -> (infohp, h)) `fmap` 269 writeHashFile c compr HashedPatchesDir (showPatch p) 270 where infohp = info hp 271 272 pihash :: (PatchInfo,String) -> Doc 273 pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n") 274 275 read_inventory_private :: Repository p C(r u t) -> String -> String 276 -> IO [[(PatchInfo, String)]] 277 read_inventory_private repo d iname = do 278 i <- skip_pristine `fmap` fetchFilePS (d++"/"++iname) Uncachable 279 (rest,str) <- case BC.break ((==)'\n') i of 280 (swt,pistr) | swt == BC.pack "Starting with inventory:" -> 281 case BC.break ((==)'\n') $ B.tail pistr of 282 (h,thisinv) | okayHash $ BC.unpack h -> 283 do r <- unsafeInterleaveIO $ read_inventories 284 (extractCache repo) (BC.unpack h) -- don't unpack twice! 285 return (r,thisinv) 286 _ -> fail $ "Bad hash in " ++ d ++ "/"++darcsdir++"/" ++ iname 287 _ -> return ([],i) 288 return $ reverse (read_patch_ids str) : rest 289 290 read_inventories :: Cache -> String -> IO [[(PatchInfo, String)]] 291 read_inventories cache ihash = do 292 (fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash 293 let i = skip_pristine i_and_p 294 (rest,str) <- case BC.break ((==)'\n') i of 295 (swt,pistr) | swt == BC.pack "Starting with inventory:" -> 296 case BC.break ((==)'\n') $ B.tail pistr of 297 (h,thisinv) | okayHash $ BC.unpack h -> 298 do r <- unsafeInterleaveIO $ 299 read_inventories cache (BC.unpack h) -- again. no. 300 return (r,thisinv) 301 _ -> fail $ "Bad hash in file " ++ fn 302 _ -> return ([],i) 303 return $ reverse (read_patch_ids str) : rest 304 305 read_patch_ids :: B.ByteString -> [(PatchInfo, String)] 306 read_patch_ids inv | B.null inv = [] 307 read_patch_ids inv = case readPatchInfo inv of 308 Nothing -> [] 309 Just (pinfo,r) -> 310 case readHash r of 311 Nothing -> [] 312 Just (h,r') -> (pinfo,h) : read_patch_ids r' 313 314 readHash :: B.ByteString -> Maybe (String, B.ByteString) 315 readHash s = let s' = dropSpace s 316 (l,r) = BC.break ((==)'\n') s' 317 (kw,h) = BC.break ((==)' ') l 318 in if kw /= BC.pack "hash:" || B.length h <= 1 319 then Nothing 320 else Just (BC.unpack $ B.tail h,r) 321 322 apply_pristine :: Patchy q => Cache -> [DarcsFlag] -> String -> String -> q C(x y) -> IO () 323 apply_pristine c opts d iname p = 324 do i <- gzReadFilePS (d++"/"++iname) 325 h <- applyHashed c opts (inv2pris i) p 326 writeDocBinFile (d++"/"++iname) $ pris2inv h i 327 328 apply_to_tentative_pristine :: Patchy q => Cache -> [DarcsFlag] -> q C(x y) -> IO () 329 apply_to_tentative_pristine c opts p = apply_pristine c opts "." (darcsdir++"/tentative_pristine") p 330 331 slurp_pristine :: Cache -> Compression -> String -> String -> IO Slurpy 332 slurp_pristine c compr d iname = do 333 i <- fetchFilePS (d++"/"++iname) Uncachable 334 slurp_pristine_private c compr i 335 336 slurp_pristine_private :: Cache -> Compression -> B.ByteString -> IO Slurpy 337 slurp_pristine_private c compr inv = case inv2pris inv of 338 h | h == sha1PS B.empty -> return empty_slurpy 339 | otherwise -> slurpHashedPristine c compr h 340 341 pristine_from_working :: Cache -> Compression -> IO () 342 pristine_from_working c compr = do 343 s <- slurp_all_but_darcs "." 344 replacePristineFromSlurpy c compr s 345 346 replacePristineFromSlurpy :: Cache -> Compression -> Slurpy -> IO () 347 replacePristineFromSlurpy c compr s = do 348 h <- writeHashedPristine c compr s 349 let t = darcsdir++"/hashed_inventory" 350 i <- gzReadFilePS t 351 writeDocBinFile t $ pris2inv h i 352 353 copy_pristine :: Cache -> Compression -> String -> String -> IO () 354 copy_pristine c compr d iname = do 355 i <- fetchFilePS (d++"/"++iname) Uncachable 356 debugMessage $ "Copying hashed pristine tree: "++inv2pris i 357 let k = "Copying pristine" 358 beginTedious k 359 copyHashed k c compr $ inv2pris i 360 endTedious k 361 362 sync_repo :: Cache -> IO () 363 sync_repo c = do i <- B.readFile $ darcsdir++"/hashed_inventory" 364 s <- slurp_all_but_darcs "." 365 beginTedious "Synchronizing pristine" 366 syncHashedPristine c s $ inv2pris i 367 368 369 copy_partials_pristine :: FilePathLike fp => 370 Cache -> Compression -> String -> String -> [fp] -> IO () 371 copy_partials_pristine c compr d iname fps = 372 do i <- fetchFilePS (d++"/"++iname) Uncachable 373 copyPartialsHashed c compr (inv2pris i) fps 374 375 inv2pris :: B.ByteString -> String 376 inv2pris inv | B.take pristine_name_length inv == pristine_name = 377 case takeHash $ B.drop pristine_name_length inv of 378 Just (h,_) -> h 379 Nothing -> error "Bad hash in inventory!" 380 | otherwise = sha1PS B.empty 381 382 pris2inv :: String -> B.ByteString -> Doc 383 pris2inv h inv = invisiblePS pristine_name <> text h $$ invisiblePS (skip_pristine inv) 384 385 pristine_name :: B.ByteString 386 pristine_name = BC.pack "pristine:" 387 388 skip_pristine :: B.ByteString -> B.ByteString 389 skip_pristine ps 390 | B.take pristine_name_length ps == pristine_name = B.drop 1 $ BC.dropWhile (/= '\n') $ 391 B.drop pristine_name_length ps 392 | otherwise = ps 393 394 pristine_name_length :: Int 395 pristine_name_length = B.length pristine_name 396 397 slurp_all_but_darcs :: FilePath -> IO Slurpy 398 slurp_all_but_darcs d = do s <- slurp d 399 case slurp_remove (fp2fn $ "./"++darcsdir) s of 400 Nothing -> return s 401 Just s' -> return s'