darcs-cabalized-2.0.2: src/Darcs/Repository/HashedIO.lhs
% Copyright (C) 2007 David Roundy
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; if not, write to the Free Software Foundation,
% Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
#include "gadts.h"
module Darcs.Repository.HashedIO ( HashedIO, applyHashed,
copyHashed, syncHashed, copyPartialsHashed, listHashedContents,
slurpHashed, hashSlurped ) where
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 Workaround ( createDirectoryIfMissing )
import Darcs.SlurpDirectory ( Slurpy(..), withSlurpy, undefined_time, undefined_size )
import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache, writeFileUsingCache,
peekInCache, speculateFileUsingCache,
findFileMtimeUsingCache, setFileMtimeUsingCache )
import Darcs.Patch ( Patchy, apply )
import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
import Darcs.Flags ( DarcsFlag )
import Darcs.Lock ( writeAtomicFilePS )
import Darcs.Utils ( withCurrentDirectory )
import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress )
import FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn,
break_on_dir, own_name, super_name )
import FastPackedString ( PackedString, packString, unpackPS, linesPS, unlinesPS, nilPS, lengthPS )
import SHA1 ( sha1PS )
readHashFile :: Cache -> String -> String -> IO (String,PackedString)
readHashFile c subdir hash =
do debugMessage $ "Reading hash file "++hash++" from "++subdir++"/"
fetchFileUsingCache c subdir hash
applyHashed :: Patchy q => Cache -> [DarcsFlag] -> String -> q C(x y) -> IO String
applyHashed c fs h p = do s <- slurpHashed c fs h
let ms = withSlurpy s $ apply fs p
case ms of
Left e -> fail e
Right (s', ()) -> hashSlurped c fs s'
{-
applyHashed c fs h p = do (_,hd) <- runStateT (apply fs p) $
HashDir { permissions = RW, cache = c,
options = fs, rootHash = h }
return $ rootHash hd
-}
data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,
options :: ![DarcsFlag], rootHash :: !String }
type HashedIO r p = StateT (HashDir r p) IO
data RO = RO
data RW = RW
{-
class Readable r where
isRO :: r -> Bool
isRO = const False
instance Readable RW
instance Readable RO where
isRO RO = True
-}
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 nilPS
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
-- for backwards compatibility accept rename of nonexistent files.
case mx of Nothing -> return ()
Just x -> do rmThing o
makeThing n x
mRemoveDirectory = rmThing
mRemoveFile f = do x <- mReadFilePS f
when (lengthPS 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 PackedString
readhash h = do c <- gets cache
z <- lift $ unsafeInterleaveIO $ readHashFile c "pristine.hashed" h
let (_,out) = z
return out
readTediousHash :: String -> String -> HashedIO r p PackedString
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 "pristine.hashed" 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 opts h <- get
z <- lift $ unsafeInterleaveIO $ runStateT job
(HashDir { permissions = RO, cache = c, options = opts, 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 "pristine.hashed" z) c
peekroot :: HashedIO r p Bool
peekroot = do HashDir _ c _ h <- get
lift $ peekInCache c "pristine.hashed" 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, unpackPS h) : parsed rest
| t == file = (F, niceps2fn n, unpackPS h) : parsed rest
parsed _ = []
dir :: PackedString
dir = packString "directory:"
file :: PackedString
file = packString "file:"
writedir :: [(ObjType, FileName, String)] -> HashedIO r p String
writedir c = writeHashFile cps
where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,packString h]) c++[nilPS]
showO D = dir
showO F = file
writeHashFile :: PackedString -> HashedIO r p String
writeHashFile ps = do c <- gets cache
opts <- gets options
lift $ writeFileUsingCache c opts "pristine.hashed" ps
slurpHashed :: Cache -> [DarcsFlag] -> String -> IO Slurpy
slurpHashed c opts h = fst `fmap` runStateT slh
(HashDir { permissions = RO, cache = c,
options = opts, rootHash = h })
slh :: HashedIO r p Slurpy
slh = do c <- readroot
hroot <- gets rootHash
lift $ beginTedious k
safeInterleave $ SlurpDir rootdir (Just hroot) `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 $ SlurpFile n (Just h, t, len) ps
sl (D,n,h) = inh h $ do c <- readroot
lift $ tediousSize k (length c)
lift $ finishedOneIO k h
SlurpDir n (Just h) `fmap` mapM sl c
k = "Reading pristine"
rootdir :: FileName
rootdir = fp2fn "."
hashSlurped :: Cache -> [DarcsFlag] -> Slurpy -> IO String
hashSlurped c opts sl = do beginTedious k
h <- fst `fmap` runStateT (hsl sl)
(HashDir { permissions = RW, cache = c,
options = opts, rootHash = sha1PS nilPS })
endTedious k
return h
where hsl (SlurpDir _ (Just h) _) = return h
hsl (SlurpDir _ Nothing ss) = do lift $ tediousSize k (length ss)
mapM hs ss >>= writedir
hsl (SlurpFile _ (Just h,_,_) _) = return h
hsl (SlurpFile _ _ x) = writeHashFile x
hs (SlurpDir d (Just h) _) = progress k $ return (D, d, h)
hs s@(SlurpDir d Nothing _) = do h <- hsl s
lift $ finishedOneIO k h
return (D, d, h)
hs (SlurpFile f (Just h,_,_) _) = progress k $ return (F, f, h)
hs s@(SlurpFile f _ _) = do h <- hsl s
lift $ finishedOneIO k h
return (F, f, h)
k = "Writing pristine"
grab :: FileName -> Slurpy -> Maybe Slurpy
grab _ (SlurpFile _ _ _) = Nothing
grab fn (SlurpDir _ _ ss) = g ss where g [] = Nothing
g (s@(SlurpDir fn' _ _):_) | fn' == fn = Just s
g (s@(SlurpFile fn' _ _):_) | fn' == fn = Just s
g (_:x) = g x
syncHashed :: Cache -> Slurpy -> String -> IO ()
syncHashed c s r = do runStateT sh $ HashDir {permissions=RW, cache=c, options=[], 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 $ syncHashed c s' h
Nothing -> return ()
sh' (F,n,h) = case progress k $ grab n s of
Just (SlurpFile _ (_,t',l) x) ->
do t <- lift $ findFileMtimeUsingCache c "pristine.hashed" h
when (t' /= undefined_time && t' /= t) $
do ps <- readhash h
when (lengthPS ps == fromIntegral l && ps == x) $
lift $ setFileMtimeUsingCache c "pristine.hashed" h t'
_ -> return ()
k = "Synchronizing pristine"
copyHashed :: String -> Cache -> [DarcsFlag] -> String -> IO ()
copyHashed k c opts z = do runStateT cph $ HashDir { permissions = RO, cache = c,
options = opts, 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 opts h
copyPartialsHashed :: Cache -> [DarcsFlag] -> String -> [FilePath] -> IO ()
copyPartialsHashed c opts root = mapM_ (copyPartialHashed c opts root)
copyPartialHashed :: Cache -> [DarcsFlag] -> String -> FilePath -> IO ()
copyPartialHashed c opts root ff =
do createDirectoryIfMissing True (basename ff)
runStateT (cp $ fp2fn ff) $ HashDir { permissions = RO, cache = c,
options=opts, 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 opts h
Just (F,h) -> do ps <- readhash h
lift $ writeAtomicFilePS (fn2fp f) ps
Nothing -> return ()
listHashedContents :: String -> Cache -> [DarcsFlag] -> String -> IO [String]
listHashedContents k c opts root =
do beginTedious k
tediousSize k 1
x <- fst `fmap` runStateT (lhc (D,fp2fn ".",root)) (HashDir RO c opts 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]
\end{code}