src/Darcs/Repository/HashedRepo.lhs

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