#include "gadts.h"
module Darcs.Repository.HashedIO ( HashedIO, applyHashed,
copyHashed, syncHashedPristine, copyPartialsHashed, listHashedContents,
slurpHashedPristine, writeHashedPristine,
clean_hashdir ) where
import Darcs.Global ( darcsdir )
import Data.List ( (\\) )
import qualified Data.Map as Map
import System.Directory ( getDirectoryContents, createDirectoryIfMissing )
import System.Posix.Types ( EpochTime )
import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift )
import Control.Monad ( when )
import Data.Maybe ( isJust )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Darcs.SlurpDirectory.Internal ( Slurpy(..), SlurpyContents(..), map_to_slurpies, slurpies_to_map )
import Darcs.SlurpDirectory ( withSlurpy, undefined_time, undefined_size )
import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,
peekInCache, speculateFileUsingCache,
findFileMtimeUsingCache, setFileMtimeUsingCache,
okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )
import Darcs.Patch ( Patchy, apply )
import Darcs.RepoPath ( FilePathLike, toFilePath )
import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
import Darcs.Flags ( DarcsFlag, Compression( .. ), compression )
import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist )
import Darcs.Utils ( withCurrentDirectory )
import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress )
import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn,
break_on_dir, own_name, super_name )
import ByteStringUtils ( linesPS, unlinesPS )
import qualified Data.ByteString as B (ByteString, length, empty)
import qualified Data.ByteString.Char8 as BC (unpack, pack)
import SHA1 ( sha1PS )
readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString)
readHashFile c subdir hash =
do debugMessage $ "Reading hash file "++hash++" from "++(hashedDir subdir)++"/"
fetchFileUsingCache c subdir hash
applyHashed :: Patchy q => Cache -> [DarcsFlag] -> String -> q C(x y) -> IO String
applyHashed c fs h p = do s <- slurpHashedPristine c (compression fs) h
let ms = withSlurpy s $ apply fs p
case ms of
Left e -> fail e
Right (s', ()) -> writeHashedPristine c (compression fs) s'
data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,
compress :: !Compression, rootHash :: !String }
type HashedIO r p = StateT (HashDir r p) IO
data RO = RO
data RW = RW
instance ReadableDirectory (HashedIO r p) where
mDoesDirectoryExist fn = do thing <- identifyThing fn
case thing of Just (D,_) -> return True
_ -> return False
mDoesFileExist fn = do thing <- identifyThing fn
case thing of Just (F,_) -> return True
_ -> return False
mInCurrentDirectory fn j | fn' == fp2fn "" = j
| otherwise =
case break_on_dir fn' of
Nothing -> do c <- readroot
case geta D fn' c of
Nothing -> fail "dir doesn't exist mInCurrentDirectory..."
Just h -> inh h j
Just (d,fn'') -> do c <- readroot
case geta D d c of
Nothing -> fail "dir doesn't exist..."
Just h -> inh h $ mInCurrentDirectory fn'' j
where fn' = norm_path fn
mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot
mReadFilePS fn = mInCurrentDirectory (super_name fn) $ do
c <- readroot
case geta F (own_name fn) c of
Nothing -> fail $ " file don't exist... "++ fn2fp fn
Just h -> readhash h
instance WriteableDirectory (HashedIO RW p) where
mWithCurrentDirectory fn j
| fn' == fp2fn "" = j
| otherwise =
case break_on_dir fn' of
Nothing -> do c <- readroot
case geta D fn' c of
Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..."
Just h -> do (h',x) <- withh h j
writeroot $ seta D fn' h' c
return x
Just (d,fn'') -> do c <- readroot
case geta D d c of
Nothing -> fail "dir doesn't exist..."
Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j
writeroot $ seta D d h' c
return x
where fn' = norm_path fn
mSetFileExecutable _ _ = return ()
mWriteFilePS fn ps = do mexists <- identifyThing fn
case mexists of
Just (D,_) -> fail "can't write file over directory"
_ -> do h <- writeHashFile ps
makeThing fn (F,h)
mCreateDirectory fn = do h <- writeHashFile B.empty
exists <- isJust `fmap` identifyThing fn
when exists $ fail "can't mCreateDirectory over an existing object."
makeThing fn (D,h)
mRename o n = do nexists <- isJust `fmap` identifyThing n
when nexists $ fail "mRename failed..."
mx <- identifyThing o
case mx of Nothing -> return ()
Just x -> do rmThing o
makeThing n x
mRemoveDirectory = rmThing
mRemoveFile f = do x <- mReadFilePS f
when (B.length x /= 0) $
fail $ "Cannot remove non-empty file "++fn2fp f
rmThing f
identifyThing :: FileName -> HashedIO r p (Maybe (ObjType,String))
identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash
return $ Just (D, h)
| otherwise = case break_on_dir fn' of
Nothing -> getany fn' `fmap` readroot
Just (d,fn'') -> do c <- readroot
case geta D d c of
Nothing -> return Nothing
Just h -> inh h $ identifyThing fn''
where fn' = norm_path fn
makeThing :: FileName -> (ObjType,String) -> HashedIO RW p ()
makeThing fn (o,h) = mWithCurrentDirectory (super_name $ norm_path fn) $
seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot
rmThing :: FileName -> HashedIO RW p ()
rmThing fn = mWithCurrentDirectory (super_name $ norm_path fn) $
do c <- readroot
let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c
if length c' == length c 1
then writeroot c'
else fail "obj doesn't exist in rmThing"
readhash :: String -> HashedIO r p B.ByteString
readhash h = do c <- gets cache
z <- lift $ unsafeInterleaveIO $ readHashFile c HashedPristineDir h
let (_,out) = z
return out
readTediousHash :: String -> String -> HashedIO r p B.ByteString
readTediousHash k h = do lift $ finishedOneIO k h
readhash h
gethashmtime :: String -> HashedIO r p EpochTime
gethashmtime h = do HashDir _ c _ _ <- get
lift $ unsafeInterleaveIO $ findFileMtimeUsingCache c HashedPristineDir h
withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a)
withh h j = do hd <- get
put $ hd { rootHash = h }
x <- j
h' <- gets rootHash
put hd
return (h',x)
inh :: String -> HashedIO r p a -> HashedIO r p a
inh h j = do hd <- get
put $ hd { rootHash = h }
x <- j
put hd
return x
safeInterleave :: HashedIO RO p a -> HashedIO r p a
safeInterleave job = do HashDir _ c compr h <- get
z <- lift $ unsafeInterleaveIO $ runStateT job
(HashDir { permissions = RO, cache = c, compress = compr, rootHash = h })
let (x,_) = z
return x
readroot :: HashedIO r p [(ObjType, FileName, String)]
readroot = do haveitalready <- peekroot
cc <- gets rootHash >>= readdir
when (not haveitalready) $ speculate cc
return cc
where speculate :: [(a,b,String)] -> HashedIO r q ()
speculate c = do cac <- gets cache
mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir z) c
peekroot :: HashedIO r p Bool
peekroot = do HashDir _ c _ h <- get
lift $ peekInCache c HashedPristineDir h
writeroot :: [(ObjType, FileName, String)] -> HashedIO r p ()
writeroot c = do h <- writedir c
modify $ \hd -> hd { rootHash = h }
data ObjType = F | D deriving Eq
geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta o f c = do (o',h) <- getany f c
if o == o' then Just h else Nothing
getany :: FileName -> [(ObjType, FileName, String)] -> Maybe (ObjType,String)
getany _ [] = Nothing
getany f ((o,f',h):_) | f == f' = Just (o,h)
getany f (_:r) = getany f r
seta :: ObjType -> FileName -> String -> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]
seta o f h [] = [(o,f,h)]
seta o f h ((_,f',_):r) | f == f' = (o,f,h):r
seta o f h (x:xs) = x : seta o f h xs
readdir :: String -> HashedIO r p [(ObjType, FileName, String)]
readdir hash = (parsed . linesPS) `fmap` readhash hash
where parsed (t:n:h:rest) | t == dir = (D, niceps2fn n, BC.unpack h) : parsed rest
| t == file = (F, niceps2fn n, BC.unpack h) : parsed rest
parsed _ = []
dir :: B.ByteString
dir = BC.pack "directory:"
file :: B.ByteString
file = BC.pack "file:"
writedir :: [(ObjType, FileName, String)] -> HashedIO r p String
writedir c = writeHashFile cps
where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,BC.pack h]) c++[B.empty]
showO D = dir
showO F = file
writeHashFile :: B.ByteString -> HashedIO r p String
writeHashFile ps = do c <- gets cache
compr <- gets compress
lift $ writeFileUsingCache c compr HashedPristineDir ps
slurpHashedPristine :: Cache -> Compression -> String -> IO Slurpy
slurpHashedPristine c compr h = fst `fmap` runStateT slh
(HashDir { permissions = RO, cache = c,
compress = compr, rootHash = h })
slh :: HashedIO r p Slurpy
slh = do c <- readroot
hroot <- gets rootHash
lift $ beginTedious k
safeInterleave $ (Slurpy rootdir . SlurpDir (Just hroot) . slurpies_to_map) `fmap` mapM sl c
where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h
t <- gethashmtime h
let len = if length h == 75 then read (take 10 h)
else undefined_size
return $ Slurpy n $ SlurpFile (Just h, t, len) ps
sl (D,n,h) = inh h $ do c <- readroot
lift $ tediousSize k (length c)
lift $ finishedOneIO k h
(Slurpy n . SlurpDir (Just h) . slurpies_to_map) `fmap` mapM sl c
k = "Reading pristine"
rootdir :: FileName
rootdir = fp2fn "."
writeHashedPristine :: Cache -> Compression -> Slurpy -> IO String
writeHashedPristine c compr sl =
do beginTedious k
h <- fst `fmap` runStateT (hsl sl)
(HashDir { permissions = RW, cache = c,
compress = compr, rootHash = sha1PS B.empty })
endTedious k
return h
where hsl (Slurpy _ (SlurpDir (Just h) _)) = return h
hsl (Slurpy _ (SlurpDir Nothing ss)) = do lift $ tediousSize k (Map.size ss)
mapM hs (map_to_slurpies ss) >>= writedir
hsl (Slurpy _ (SlurpFile (Just h,_,_) _)) = return h
hsl (Slurpy _ (SlurpFile _ x)) = writeHashFile x
hs (Slurpy d (SlurpDir (Just h) _)) = progress k $ return (D, d, h)
hs s@(Slurpy d (SlurpDir Nothing _)) = do h <- hsl s
lift $ finishedOneIO k h
return (D, d, h)
hs (Slurpy f (SlurpFile (Just h,_,_) _)) = progress k $ return (F, f, h)
hs s@(Slurpy f (SlurpFile _ _)) = do h <- hsl s
lift $ finishedOneIO k h
return (F, f, h)
k = "Writing pristine"
grab :: FileName -> Slurpy -> Maybe Slurpy
grab _ (Slurpy _ (SlurpFile _ _)) = Nothing
grab fn (Slurpy _ (SlurpDir _ ss)) = fmap (Slurpy fn) $ Map.lookup fn ss
syncHashedPristine :: Cache -> Slurpy -> String -> IO ()
syncHashedPristine c s r = do runStateT sh $ HashDir { permissions=RW, cache=c,
compress=compression [], rootHash=r }
return ()
where sh = do cc <- readroot
lift $ tediousSize k (length cc)
mapM_ sh' cc
sh' (D,n,h) = case progress k $ grab n s of
Just s' -> lift $ syncHashedPristine c s' h
Nothing -> return ()
sh' (F,n,h) = case progress k $ grab n s of
Just (Slurpy _ (SlurpFile (_,t',l) x)) ->
do t <- lift $ findFileMtimeUsingCache c HashedPristineDir h
when (t' /= undefined_time && t' /= t) $
do ps <- readhash h
when (B.length ps == fromIntegral l && ps == x) $
lift $ setFileMtimeUsingCache c HashedPristineDir h t'
_ -> return ()
k = "Synchronizing pristine"
copyHashed :: String -> Cache -> Compression -> String -> IO ()
copyHashed k c compr z = do runStateT cph $ HashDir { permissions = RO, cache = c,
compress = compr, rootHash = z }
return ()
where cph = do cc <- readroot
lift $ tediousSize k (length cc)
mapM_ cp cc
cp (F,n,h) = do ps <- readhash h
lift $ finishedOneIO k (fn2fp n)
lift $ writeAtomicFilePS (fn2fp n) ps
cp (D,n,h) = do lift $ createDirectoryIfMissing False (fn2fp n)
lift $ finishedOneIO k (fn2fp n)
lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c compr h
copyPartialsHashed :: FilePathLike fp =>
Cache -> Compression -> String -> [fp] -> IO ()
copyPartialsHashed c compr root = mapM_ (copyPartialHashed c compr root)
copyPartialHashed :: FilePathLike fp => Cache -> Compression -> String -> fp -> IO ()
copyPartialHashed c compr root ff =
do createDirectoryIfMissing True (basename $ toFilePath ff)
runStateT (cp $ fp2fn $ toFilePath ff) $
HashDir { permissions = RO, cache = c,
compress=compr, rootHash = root }
return ()
where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse
cp f = do mt <- identifyThing f
case mt of
Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f)
lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c compr h
Just (F,h) -> do ps <- readhash h
lift $ writeAtomicFilePS (fn2fp f) ps
Nothing -> return ()
listHashedContents :: String -> Cache -> String -> IO [String]
listHashedContents k c root =
do beginTedious k
tediousSize k 1
x <- fst `fmap` runStateT (lhc (D,fp2fn ".",root)) (HashDir RO c NoCompression root)
endTedious k
return x
where lhc :: (ObjType, FileName, String) -> HashedIO r a [String]
lhc (D,dname,d) = do xs <- inh d $ readroot
lift $ finishedOneIO k (fn2fp dname)
lift $ tediousSize k (length $ filter (\(x,_,_) -> x == D) xs)
hcxs <- mapM lhc xs
return (d:concat hcxs)
lhc (F,_,h) = return [h]
clean_hashdir :: Cache -> HashedDir -> [String] -> IO ()
clean_hashdir c dir_ hashroots =
do
debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..."
let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/"
hs <- concat `fmap` (mapM (listHashedContents "cleaning up..." c) hashroots)
fs <- filter okayHash `fmap` getDirectoryContents hashdir
mapM_ (removeFileMayNotExist . (hashdir++)) (fs \\ hs)
debugMessage "Cleaning out any global caches..."
cleanCachesWithHint c dir_ (fs \\ hs)