src/Darcs/Repository/HashedIO.lhs

   1 %  Copyright (C) 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 \begin{code}
  18 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
  19 {-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}
  20
  21 #include "gadts.h"
  22
  23 module Darcs.Repository.HashedIO ( HashedIO, applyHashed,
  24                                    copyHashed, syncHashedPristine, copyPartialsHashed, listHashedContents,
  25                                    slurpHashedPristine, writeHashedPristine,
  26                                    clean_hashdir ) where
  27
  28 import Darcs.Global ( darcsdir )
  29 import Data.List ( (\\) )
  30 import System.Directory ( getDirectoryContents, createDirectoryIfMissing )
  31 import System.Posix.Types ( EpochTime )
  32 import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift )
  33 import Control.Monad ( when )
  34 import Data.Maybe ( isJust )
  35 import System.IO.Unsafe ( unsafeInterleaveIO )
  36
  37 import Darcs.SlurpDirectory ( Slurpy(..), withSlurpy, undefined_time, undefined_size )
  38 import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,
  39                                 peekInCache, speculateFileUsingCache,
  40                                 findFileMtimeUsingCache, setFileMtimeUsingCache,
  41                                 okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )
  42 import Darcs.Patch ( Patchy, apply )
  43 import Darcs.RepoPath ( FilePathLike, toFilePath )
  44 import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
  45 import Darcs.Flags ( DarcsFlag, Compression( .. ), compression )
  46 import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist )
  47 import Darcs.Utils ( withCurrentDirectory )
  48 import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress )
  49 import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn,
  50                               break_on_dir, own_name, super_name )
  51
  52 import ByteStringUtils ( linesPS, unlinesPS )
  53 import qualified Data.ByteString       as B  (ByteString, length, empty)
  54 import qualified Data.ByteString.Char8 as BC (unpack, pack)
  55
  56 import SHA1 ( sha1PS )
  57
  58 readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString)
  59 readHashFile c subdir hash =
  60     do debugMessage $ "Reading hash file "++hash++" from "++(hashedDir subdir)++"/"
  61        fetchFileUsingCache c subdir hash
  62
  63 applyHashed :: Patchy q => Cache -> [DarcsFlag] -> String -> q C(x y) -> IO String
  64 applyHashed c fs h p = do s <- slurpHashedPristine c (compression fs) h
  65                           let ms = withSlurpy s $ apply fs p
  66                           case ms of
  67                             Left e -> fail e
  68                             Right (s', ()) -> writeHashedPristine c (compression fs) s'
  69 {-
  70 applyHashed c fs h p = do (_,hd) <- runStateT (apply fs p) $
  71                                     HashDir { permissions = RW, cache = c,
  72                                               options = fs, rootHash = h }
  73                           return $ rootHash hd
  74 -}
  75
  76 data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,
  77                              compress :: !Compression, rootHash :: !String }
  78 type HashedIO r p = StateT (HashDir r p) IO
  79
  80 data RO = RO
  81 data RW = RW
  82 {-
  83 class Readable r where
  84     isRO :: r -> Bool
  85     isRO = const False
  86 instance Readable RW
  87 instance Readable RO where
  88     isRO RO = True
  89 -}
  90
  91 instance ReadableDirectory (HashedIO r p) where
  92     mDoesDirectoryExist fn = do thing <- identifyThing fn
  93                                 case thing of Just (D,_) -> return True
  94                                               _ -> return False
  95     mDoesFileExist fn = do thing <- identifyThing fn
  96                            case thing of Just (F,_) -> return True
  97                                          _ -> return False
  98     mInCurrentDirectory fn j | fn' == fp2fn "" = j
  99                              | otherwise =
 100                                  case break_on_dir fn' of
 101                                  Nothing -> do c <- readroot
 102                                                case geta D fn' c of
 103                                                  Nothing -> fail "dir doesn't exist mInCurrentDirectory..."
 104                                                  Just h -> inh h j
 105                                  Just (d,fn'') -> do c <- readroot
 106                                                      case geta D d c of
 107                                                        Nothing -> fail "dir doesn't exist..."
 108                                                        Just h -> inh h $ mInCurrentDirectory fn'' j
 109         where fn' = norm_path fn
 110     mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot
 111     mReadFilePS fn = mInCurrentDirectory (super_name fn) $ do
 112                                           c <- readroot
 113                                           case geta F (own_name fn) c of
 114                                             Nothing -> fail $ " file don't exist... "++ fn2fp fn
 115                                             Just h -> readhash h
 116
 117 instance WriteableDirectory (HashedIO RW p) where
 118     mWithCurrentDirectory fn j
 119         | fn' == fp2fn "" = j
 120         | otherwise =
 121             case break_on_dir fn' of
 122             Nothing -> do c <- readroot
 123                           case geta D fn' c of
 124                             Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..."
 125                             Just h -> do (h',x) <- withh h j
 126                                          writeroot $ seta D fn' h' c
 127                                          return x
 128             Just (d,fn'') -> do c <- readroot
 129                                 case geta D d c of
 130                                   Nothing -> fail "dir doesn't exist..."
 131                                   Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j
 132                                                writeroot $ seta D d h' c
 133                                                return x
 134         where fn' = norm_path fn
 135     mSetFileExecutable _ _ = return ()
 136     mWriteFilePS fn ps = do mexists <- identifyThing fn
 137                             case mexists of
 138                               Just (D,_) -> fail "can't write file over directory"
 139                               _ -> do h <- writeHashFile ps
 140                                       makeThing fn (F,h)
 141     mCreateDirectory fn = do h <- writeHashFile B.empty
 142                              exists <- isJust `fmap` identifyThing fn
 143                              when exists $ fail "can't mCreateDirectory over an existing object."
 144                              makeThing fn (D,h)
 145     mRename o n = do nexists <- isJust `fmap` identifyThing n
 146                      when nexists $ fail "mRename failed..."
 147                      mx <- identifyThing o
 148                      -- for backwards compatibility accept rename of nonexistent files.
 149                      case mx of Nothing -> return ()
 150                                 Just x -> do rmThing o
 151                                              makeThing n x
 152     mRemoveDirectory = rmThing
 153     mRemoveFile f = do x <- mReadFilePS f
 154                        when (B.length x /= 0) $
 155                             fail $ "Cannot remove non-empty file "++fn2fp f
 156                        rmThing f
 157
 158 identifyThing :: FileName -> HashedIO r p (Maybe (ObjType,String))
 159 identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash
 160                                         return $ Just (D, h)
 161                  | otherwise = case break_on_dir fn' of
 162                                Nothing -> getany fn' `fmap` readroot
 163                                Just (d,fn'') -> do c <- readroot
 164                                                    case geta D d c of
 165                                                      Nothing -> return Nothing
 166                                                      Just h -> inh h $ identifyThing fn''
 167         where fn' = norm_path fn
 168
 169 makeThing :: FileName -> (ObjType,String) -> HashedIO RW p ()
 170 makeThing fn (o,h) = mWithCurrentDirectory (super_name $ norm_path fn) $
 171                      seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot
 172
 173 rmThing :: FileName -> HashedIO RW p ()
 174 rmThing fn = mWithCurrentDirectory (super_name $ norm_path fn) $
 175              do c <- readroot
 176                 let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c
 177                 if length c' == length c - 1
 178                   then writeroot c'
 179                   else fail "obj doesn't exist in rmThing"
 180
 181 readhash :: String -> HashedIO r p B.ByteString
 182 readhash h = do c <- gets cache
 183                 z <- lift $ unsafeInterleaveIO $ readHashFile c HashedPristineDir h
 184                 let (_,out) = z
 185                 return out
 186
 187 readTediousHash :: String -> String -> HashedIO r p B.ByteString
 188 readTediousHash k h = do lift $ finishedOneIO k h
 189                          readhash h
 190
 191 gethashmtime :: String -> HashedIO r p EpochTime
 192 gethashmtime h = do HashDir _ c _ _ <- get
 193                     lift $ unsafeInterleaveIO $ findFileMtimeUsingCache c HashedPristineDir h
 194
 195 withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a)
 196 withh h j = do hd <- get
 197                put $ hd { rootHash = h }
 198                x <- j
 199                h' <- gets rootHash
 200                put hd
 201                return (h',x)
 202
 203 inh :: String -> HashedIO r p a -> HashedIO r p a
 204 inh h j = do hd <- get
 205              put $ hd { rootHash = h }
 206              x <- j
 207              put hd
 208              return x
 209
 210 safeInterleave :: HashedIO RO p a -> HashedIO r p a
 211 safeInterleave job = do HashDir _ c compr h <- get
 212                         z <- lift $ unsafeInterleaveIO $ runStateT job
 213                              (HashDir { permissions = RO, cache = c, compress = compr, rootHash = h })
 214                         let (x,_) = z
 215                         return x
 216
 217 readroot :: HashedIO r p [(ObjType, FileName, String)]
 218 readroot = do haveitalready <- peekroot
 219               cc <- gets rootHash >>= readdir
 220               when (not haveitalready) $ speculate cc
 221               return cc
 222     where speculate :: [(a,b,String)] -> HashedIO r q ()
 223           speculate c = do cac <- gets cache
 224                            mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir z) c
 225           peekroot :: HashedIO r p Bool
 226           peekroot = do HashDir _ c _ h <- get
 227                         lift $ peekInCache c HashedPristineDir h
 228
 229 writeroot :: [(ObjType, FileName, String)] -> HashedIO r p ()
 230 writeroot c = do h <- writedir c
 231                  modify $ \hd -> hd { rootHash = h }
 232
 233 data ObjType = F | D deriving Eq
 234
 235 geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String
 236 geta o f c = do (o',h) <- getany f c
 237                 if o == o' then Just h else Nothing
 238
 239 getany :: FileName -> [(ObjType, FileName, String)] -> Maybe (ObjType,String)
 240 getany _ [] = Nothing
 241 getany f ((o,f',h):_) | f == f' = Just (o,h)
 242 getany f (_:r) = getany f r
 243
 244 seta :: ObjType -> FileName -> String -> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]
 245 seta o f h [] = [(o,f,h)]
 246 seta o f h ((_,f',_):r) | f == f' = (o,f,h):r
 247 seta o f h (x:xs) = x : seta o f h xs
 248
 249 readdir :: String -> HashedIO r p [(ObjType, FileName, String)]
 250 readdir hash = (parsed . linesPS) `fmap` readhash hash
 251     where parsed (t:n:h:rest) | t == dir = (D, niceps2fn n, BC.unpack h) : parsed rest
 252                               | t == file = (F, niceps2fn n, BC.unpack h) : parsed rest
 253           parsed _ = []
 254 dir :: B.ByteString
 255 dir = BC.pack "directory:"
 256 file :: B.ByteString
 257 file = BC.pack "file:"
 258
 259
 260 writedir :: [(ObjType, FileName, String)] -> HashedIO r p String
 261 writedir c = writeHashFile cps
 262     where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,BC.pack h]) c++[B.empty]
 263           showO D = dir
 264           showO F = file
 265
 266 writeHashFile :: B.ByteString -> HashedIO r p String
 267 writeHashFile ps = do c <- gets cache
 268                       compr <- gets compress
 269                       lift $ writeFileUsingCache c compr HashedPristineDir ps
 270
 271 -- |Create a Slurpy representing the pristine content determined by the
 272 -- supplied root hash (which uniquely determines the pristine tree)
 273 slurpHashedPristine :: Cache -> Compression -> String -> IO Slurpy
 274 slurpHashedPristine c compr h = fst `fmap` runStateT slh
 275                                   (HashDir { permissions = RO, cache = c,
 276                                              compress = compr, rootHash = h })
 277
 278 slh :: HashedIO r p Slurpy
 279 slh = do c <- readroot
 280          hroot <- gets rootHash
 281          lift $ beginTedious k
 282          safeInterleave $ SlurpDir rootdir (Just hroot) `fmap` mapM sl c
 283     where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h
 284                           t <- gethashmtime h
 285                           let len = if length h == 75 then read (take 10 h)
 286                                                       else undefined_size
 287                           return $ SlurpFile n (Just h, t, len) ps
 288           sl (D,n,h) = inh h $ do c <- readroot
 289                                   lift $ tediousSize k (length c)
 290                                   lift $ finishedOneIO k h
 291                                   SlurpDir n (Just h) `fmap` mapM sl c
 292           k = "Reading pristine"
 293
 294 rootdir :: FileName
 295 rootdir = fp2fn "."
 296
 297 -- |Write contents of a Slurpy into hashed pristine. Only files that have not
 298 -- not yet been hashed (that is, the hash corresponding to their content is
 299 -- already present in hashed pristine) will be written out, so it is efficient
 300 -- to use this function to update existing pristine cache. Note that the
 301 -- pristine root hash will *not* be updated. You need to do that manually.
 302 writeHashedPristine :: Cache -> Compression -> Slurpy -> IO String
 303 writeHashedPristine c compr sl =
 304     do beginTedious k
 305        h <- fst `fmap` runStateT (hsl sl)
 306             (HashDir { permissions = RW, cache = c,
 307                        compress = compr, rootHash = sha1PS B.empty })
 308        endTedious k
 309        return h
 310     where hsl (SlurpDir _ (Just h) _) = return h
 311           hsl (SlurpDir _ Nothing ss) = do lift $ tediousSize k (length ss)
 312                                            mapM hs ss >>= writedir
 313           hsl (SlurpFile _ (Just h,_,_) _) = return h
 314           hsl (SlurpFile _ _ x) = writeHashFile x
 315           hs (SlurpDir d (Just h) _) = progress k $ return (D, d, h)
 316           hs s@(SlurpDir d Nothing _) = do h <- hsl s
 317                                            lift $ finishedOneIO k h
 318                                            return (D, d, h)
 319           hs (SlurpFile f (Just h,_,_) _) = progress k $ return (F, f, h)
 320           hs s@(SlurpFile f _ _) = do h <- hsl s
 321                                       lift $ finishedOneIO k h
 322                                       return (F, f, h)
 323           k = "Writing pristine"
 324
 325 grab :: FileName -> Slurpy -> Maybe Slurpy
 326 grab _ (SlurpFile _ _ _) = Nothing
 327 grab fn (SlurpDir _ _ ss) = g ss where g [] = Nothing
 328                                        g (s@(SlurpDir fn' _ _):_) | fn' == fn = Just s
 329                                        g (s@(SlurpFile fn' _ _):_) | fn' == fn = Just s
 330                                        g (_:x) = g x
 331
 332 -- |Update timestamps on pristine files to match those in the working directory
 333 -- (which is passed to this function in form of a Slurpy). It needed for the
 334 -- mtime-based unsafeDiff optimisation to work efficiently.
 335 syncHashedPristine :: Cache -> Slurpy -> String -> IO ()
 336 syncHashedPristine c s r = do runStateT sh $ HashDir { permissions=RW, cache=c,
 337                                                        compress=compression [], rootHash=r }
 338                               return ()
 339     where sh = do cc <- readroot
 340                   lift $ tediousSize k (length cc)
 341                   mapM_ sh' cc
 342           sh' (D,n,h) = case progress k $ grab n s of
 343                         Just s' -> lift $ syncHashedPristine c s' h
 344                         Nothing -> return ()
 345           sh' (F,n,h) = case progress k $ grab n s of
 346                         Just (SlurpFile _ (_,t',l) x) ->
 347                             do t <- lift $ findFileMtimeUsingCache c HashedPristineDir h
 348                                when (t' /= undefined_time && t' /= t) $
 349                                     do ps <- readhash h
 350                                        when (B.length ps == fromIntegral l && ps == x) $
 351                                             lift $ setFileMtimeUsingCache c HashedPristineDir h t'
 352                         _ -> return ()
 353           k = "Synchronizing pristine"
 354
 355 copyHashed :: String -> Cache -> Compression -> String -> IO ()
 356 copyHashed k c compr z = do runStateT cph $ HashDir { permissions = RO, cache = c,
 357                                                       compress = compr, rootHash = z }
 358                             return ()
 359     where cph = do cc <- readroot
 360                    lift $ tediousSize k (length cc)
 361                    mapM_ cp cc
 362           cp (F,n,h) = do ps <- readhash h
 363                           lift $ finishedOneIO k (fn2fp n)
 364                           lift $ writeAtomicFilePS (fn2fp n) ps
 365           cp (D,n,h) = do lift $ createDirectoryIfMissing False (fn2fp n)
 366                           lift $ finishedOneIO k (fn2fp n)
 367                           lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c compr h
 368
 369 copyPartialsHashed :: FilePathLike fp =>
 370                       Cache -> Compression -> String -> [fp] -> IO ()
 371 copyPartialsHashed c compr root = mapM_ (copyPartialHashed c compr root)
 372
 373 copyPartialHashed :: FilePathLike fp => Cache -> Compression -> String -> fp -> IO ()
 374 copyPartialHashed c compr root ff =
 375     do createDirectoryIfMissing True (basename $ toFilePath ff)
 376        runStateT (cp $ fp2fn $ toFilePath ff) $
 377                  HashDir { permissions = RO, cache = c,
 378                            compress=compr, rootHash = root }
 379        return ()
 380  where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse
 381        cp f = do mt <- identifyThing f
 382                  case mt of
 383                    Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f)
 384                                     lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c compr h
 385                    Just (F,h) -> do ps <- readhash h
 386                                     lift $ writeAtomicFilePS (fn2fp f) ps
 387                    Nothing -> return ()
 388
 389 -- Seems to list all hashes reachable from "root".
 390 listHashedContents :: String -> Cache -> String -> IO [String]
 391 listHashedContents k c root =
 392     do beginTedious k
 393        tediousSize k 1
 394        x <- fst `fmap` runStateT (lhc (D,fp2fn ".",root)) (HashDir RO c NoCompression root)
 395        endTedious k
 396        return x
 397     where lhc :: (ObjType, FileName, String) -> HashedIO r a [String]
 398           lhc (D,dname,d) = do xs <- inh d $ readroot
 399                                lift $ finishedOneIO k (fn2fp dname)
 400                                lift $ tediousSize k (length $ filter (\(x,_,_) -> x == D) xs)
 401                                hcxs <- mapM lhc xs
 402                                return (d:concat hcxs)
 403           lhc (F,_,h) = return [h]
 404
 405 clean_hashdir :: Cache -> HashedDir -> [String] -> IO ()
 406 clean_hashdir c dir_ hashroots =
 407    do -- we'll remove obsolete bits of "dir"
 408       debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..."
 409       let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/"
 410       hs <- concat `fmap` (mapM (listHashedContents "cleaning up..." c) hashroots)
 411       fs <- filter okayHash `fmap` getDirectoryContents hashdir
 412       mapM_ (removeFileMayNotExist . (hashdir++)) (fs \\ hs)
 413       -- and also clean out any global caches.
 414       debugMessage "Cleaning out any global caches..."
 415       cleanCachesWithHint c dir_ (fs \\ hs)
 416
 417 \end{code}