{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,
cleanHashdir, getHashedFiles,
pathsAndContents
) where
import Darcs.Prelude
import Darcs.Util.Global ( darcsdir )
import qualified Data.Set as Set
import System.Directory ( getDirectoryContents, createDirectoryIfMissing )
import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift, evalStateT )
import Control.Monad ( when, void, unless, guard )
import Data.Maybe ( isJust )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,
peekInCache, speculateFileUsingCache,
okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )
import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )
import Darcs.Repository.Flags ( Compression( .. ), WithWorkingDir (..) )
import Darcs.Repository.Inventory ( PristineHash, getValidHash, mkValidHash )
import Darcs.Util.Lock ( writeAtomicFilePS, removeFileMayNotExist )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Progress ( debugMessage, tediousSize, finishedOneIO )
import Darcs.Util.Path
( AnchoredPath
, anchorPath
, anchoredRoot
, parent
, breakOnDir
, Name
, name2fp
, decodeWhiteName
, encodeWhiteName
, isMaliciousSubPath
)
import Darcs.Util.ByteString ( linesPS, unlinesPS )
import qualified Data.ByteString as B (ByteString, length, empty)
import qualified Data.ByteString.Char8 as BC (unpack, pack)
import Darcs.Util.Tree.Hashed( readDarcsHashedDir, darcsLocation,
decodeDarcsHash, decodeDarcsSize )
import Darcs.Util.Tree( ItemType(..), Tree )
ap2fp :: AnchoredPath -> FilePath
ap2fp :: AnchoredPath -> [Char]
ap2fp = [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
""
readHashFile :: Cache -> HashedDir -> PristineHash -> IO (FilePath,B.ByteString)
readHashFile :: Cache -> HashedDir -> PristineHash -> IO ([Char], ByteString)
readHashFile Cache
c HashedDir
subdir PristineHash
hash =
do [Char] -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [Char]
"Reading hash file "forall a. [a] -> [a] -> [a]
++forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
hashforall a. [a] -> [a] -> [a]
++[Char]
" from "forall a. [a] -> [a] -> [a]
++HashedDir -> [Char]
hashedDir HashedDir
subdirforall a. [a] -> [a] -> [a]
++[Char]
"/"
([Char], ByteString)
r <- Cache -> HashedDir -> [Char] -> IO ([Char], ByteString)
fetchFileUsingCache Cache
c HashedDir
subdir (forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
hash)
[Char] -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [Char]
"Result of reading hash file: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([Char], ByteString)
r
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char], ByteString)
r
data HashDir = HashDir { HashDir -> Cache
cache :: !Cache,
HashDir -> PristineHash
cwdHash :: !PristineHash }
type HashedIO = StateT HashDir IO
mWithSubDirectory :: Name -> HashedIO a -> HashedIO a
mWithSubDirectory :: forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
dir HashedIO a
j = do
[DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
D Name
dir [DirEntry]
cwd of
Maybe PristineHash
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"dir doesn't exist in mWithSubDirectory..."
Just PristineHash
h -> do
(PristineHash
h', a
x) <- forall a. PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
withh PristineHash
h HashedIO a
j
[DirEntry] -> HashedIO ()
writecwd forall a b. (a -> b) -> a -> b
$ ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
D Name
dir PristineHash
h' [DirEntry]
cwd
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
mInSubDirectory :: Name -> HashedIO a -> HashedIO a
mInSubDirectory :: forall a. Name -> HashedIO a -> HashedIO a
mInSubDirectory Name
dir HashedIO a
j = do
[DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
D Name
dir [DirEntry]
cwd of
Maybe PristineHash
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"dir doesn't exist..."
Just PristineHash
h -> forall a. PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h HashedIO a
j
instance ApplyMonad Tree HashedIO where
type ApplyMonadBase HashedIO = IO
instance ApplyMonadTree HashedIO where
mDoesDirectoryExist :: AnchoredPath -> HashedIO Bool
mDoesDirectoryExist AnchoredPath
path = do
Maybe (ObjType, PristineHash)
thing <- AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
case Maybe (ObjType, PristineHash)
thing of
Just (ObjType
D, PristineHash
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Maybe (ObjType, PristineHash)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
mReadFilePS :: AnchoredPath -> HashedIO ByteString
mReadFilePS = AnchoredPath -> HashedIO ByteString
readFileObject
mCreateDirectory :: AnchoredPath -> HashedIO ()
mCreateDirectory AnchoredPath
path = do
PristineHash
h <- ByteString -> HashedIO PristineHash
writeHashFile ByteString
B.empty
Bool
exists <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"can't mCreateDirectory over an existing object."
AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
path (ObjType
D, PristineHash
h)
mRename :: AnchoredPath -> AnchoredPath -> HashedIO ()
mRename AnchoredPath
o AnchoredPath
n = do
Bool
nexists <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nexists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"mRename failed..."
Maybe (ObjType, PristineHash)
mx <- AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
o
case Maybe (ObjType, PristineHash)
mx of
Maybe (ObjType, PristineHash)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (ObjType, PristineHash)
x -> do
AnchoredPath -> HashedIO ()
rmThing AnchoredPath
o
AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
n (ObjType, PristineHash)
x
mRemoveDirectory :: AnchoredPath -> HashedIO ()
mRemoveDirectory = AnchoredPath -> HashedIO ()
rmThing
mRemoveFile :: AnchoredPath -> HashedIO ()
mRemoveFile AnchoredPath
f = do
ByteString
x <- forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
x forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot remove non-empty file " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> [Char]
ap2fp AnchoredPath
f
AnchoredPath -> HashedIO ()
rmThing AnchoredPath
f
readFileObject :: AnchoredPath -> HashedIO B.ByteString
readFileObject :: AnchoredPath -> HashedIO ByteString
readFileObject AnchoredPath
path
| AnchoredPath
path forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"root dir is not a file..."
| Bool
otherwise =
case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
Left Name
file -> do
[DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
F Name
file [DirEntry]
cwd of
Maybe PristineHash
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"file doesn't exist..." forall a. [a] -> [a] -> [a]
++ AnchoredPath -> [Char]
ap2fp AnchoredPath
path
Just PristineHash
h -> PristineHash -> HashedIO ByteString
readhash PristineHash
h
Right (Name
name, AnchoredPath
path') -> do
forall a. Name -> HashedIO a -> HashedIO a
mInSubDirectory Name
name forall a b. (a -> b) -> a -> b
$ AnchoredPath -> HashedIO ByteString
readFileObject AnchoredPath
path'
identifyThing :: AnchoredPath -> HashedIO (Maybe (ObjType,PristineHash))
identifyThing :: AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
| AnchoredPath
path forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = do
PristineHash
h <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ObjType
D, PristineHash
h)
| Bool
otherwise =
case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
Left Name
name -> Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [DirEntry]
readcwd
Right (Name
dir, AnchoredPath
path') -> do
[DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
D Name
dir [DirEntry]
cwd of
Maybe PristineHash
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just PristineHash
h -> forall a. PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h forall a b. (a -> b) -> a -> b
$ AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path'
addThing :: AnchoredPath -> (ObjType,PristineHash) -> HashedIO ()
addThing :: AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
path (ObjType
o, PristineHash
h) =
case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
Left Name
name -> ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
o Name
name PristineHash
h forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [DirEntry]
readcwd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [DirEntry] -> HashedIO ()
writecwd
Right (Name
name,AnchoredPath
path') -> forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
name forall a b. (a -> b) -> a -> b
$ AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
path' (ObjType
o,PristineHash
h)
rmThing :: AnchoredPath -> HashedIO ()
rmThing :: AnchoredPath -> HashedIO ()
rmThing AnchoredPath
path =
case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
Left Name
name -> do
[DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
let cwd' :: [DirEntry]
cwd' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(ObjType
_,Name
x,PristineHash
_)->Name
xforall a. Eq a => a -> a -> Bool
/= Name
name) [DirEntry]
cwd
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd' forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd forall a. Num a => a -> a -> a
- Int
1
then [DirEntry] -> HashedIO ()
writecwd [DirEntry]
cwd'
else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"obj doesn't exist in rmThing"
Right (Name
name,AnchoredPath
path') -> forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
name forall a b. (a -> b) -> a -> b
$ AnchoredPath -> HashedIO ()
rmThing AnchoredPath
path'
readhash :: PristineHash -> HashedIO B.ByteString
readhash :: PristineHash -> HashedIO ByteString
readhash PristineHash
h = do Cache
c <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
([Char], ByteString)
z <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> PristineHash -> IO ([Char], ByteString)
readHashFile Cache
c HashedDir
HashedPristineDir PristineHash
h
let ([Char]
_,ByteString
out) = ([Char], ByteString)
z
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
withh :: PristineHash -> HashedIO a -> HashedIO (PristineHash,a)
withh :: forall a. PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
withh PristineHash
h HashedIO a
j = do HashDir
hd <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ HashDir
hd { cwdHash :: PristineHash
cwdHash = PristineHash
h }
a
x <- HashedIO a
j
PristineHash
h' <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash
forall s (m :: * -> *). MonadState s m => s -> m ()
put HashDir
hd
forall (m :: * -> *) a. Monad m => a -> m a
return (PristineHash
h',a
x)
inh :: PristineHash -> HashedIO a -> HashedIO a
inh :: forall a. PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h HashedIO a
j = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
withh PristineHash
h HashedIO a
j
type DirEntry = (ObjType, Name, PristineHash)
readcwd :: HashedIO [DirEntry]
readcwd :: HashedIO [DirEntry]
readcwd = do Bool
haveitalready <- HashedIO Bool
peekroot
[DirEntry]
cwd <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PristineHash -> HashedIO [DirEntry]
readdir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
haveitalready forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b, PristineHash)] -> HashedIO ()
speculate [DirEntry]
cwd
forall (m :: * -> *) a. Monad m => a -> m a
return [DirEntry]
cwd
where speculate :: [(a,b,PristineHash)] -> HashedIO ()
speculate :: forall a b. [(a, b, PristineHash)] -> HashedIO ()
speculate [(a, b, PristineHash)]
c = do Cache
cac <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(a
_,b
_,PristineHash
z) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> [Char] -> IO ()
speculateFileUsingCache Cache
cac HashedDir
HashedPristineDir (forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
z)) [(a, b, PristineHash)]
c
peekroot :: HashedIO Bool
peekroot :: HashedIO Bool
peekroot = do HashDir Cache
c PristineHash
h <- forall s (m :: * -> *). MonadState s m => m s
get
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> [Char] -> IO Bool
peekInCache Cache
c HashedDir
HashedPristineDir (forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
h)
writecwd :: [DirEntry] -> HashedIO ()
writecwd :: [DirEntry] -> HashedIO ()
writecwd [DirEntry]
c = do
PristineHash
h <- [DirEntry] -> HashedIO PristineHash
writedir [DirEntry]
c
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \HashDir
hd -> HashDir
hd { cwdHash :: PristineHash
cwdHash = PristineHash
h }
data ObjType = F | D deriving ObjType -> ObjType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjType -> ObjType -> Bool
$c/= :: ObjType -> ObjType -> Bool
== :: ObjType -> ObjType -> Bool
$c== :: ObjType -> ObjType -> Bool
Eq
geta :: ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta :: ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
o Name
f [DirEntry]
c = do
(ObjType
o', PristineHash
h) <- Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
f [DirEntry]
c
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ObjType
o forall a. Eq a => a -> a -> Bool
== ObjType
o')
forall (m :: * -> *) a. Monad m => a -> m a
return PristineHash
h
getany :: Name -> [DirEntry] -> Maybe (ObjType,PristineHash)
getany :: Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
_ [] = forall a. Maybe a
Nothing
getany Name
f ((ObjType
o,Name
f',PristineHash
h):[DirEntry]
_) | Name
f forall a. Eq a => a -> a -> Bool
== Name
f' = forall a. a -> Maybe a
Just (ObjType
o,PristineHash
h)
getany Name
f (DirEntry
_:[DirEntry]
r) = Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
f [DirEntry]
r
seta :: ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta :: ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
o Name
f PristineHash
h [] = [(ObjType
o,Name
f,PristineHash
h)]
seta ObjType
o Name
f PristineHash
h ((ObjType
_,Name
f',PristineHash
_):[DirEntry]
r) | Name
f forall a. Eq a => a -> a -> Bool
== Name
f' = (ObjType
o,Name
f,PristineHash
h)forall a. a -> [a] -> [a]
:[DirEntry]
r
seta ObjType
o Name
f PristineHash
h (DirEntry
x:[DirEntry]
xs) = DirEntry
x forall a. a -> [a] -> [a]
: ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
o Name
f PristineHash
h [DirEntry]
xs
readdir :: PristineHash -> HashedIO [DirEntry]
readdir :: PristineHash -> HashedIO [DirEntry]
readdir PristineHash
hash = do
ByteString
content <- PristineHash -> HashedIO ByteString
readhash PristineHash
hash
let r :: [DirEntry]
r = (forall {c}. ValidHash c => [ByteString] -> [(ObjType, Name, c)]
parseLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
linesPS) ByteString
content
forall (m :: * -> *) a. Monad m => a -> m a
return [DirEntry]
r
where
parseLines :: [ByteString] -> [(ObjType, Name, c)]
parseLines (ByteString
t:ByteString
n:ByteString
h:[ByteString]
rest)
| ByteString
t forall a. Eq a => a -> a -> Bool
== ByteString
dirType = (ObjType
D, ByteString -> Name
decodeWhiteName ByteString
n, forall a. ValidHash a => [Char] -> a
mkValidHash forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
BC.unpack ByteString
h) forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, Name, c)]
parseLines [ByteString]
rest
| ByteString
t forall a. Eq a => a -> a -> Bool
== ByteString
fileType = (ObjType
F, ByteString -> Name
decodeWhiteName ByteString
n, forall a. ValidHash a => [Char] -> a
mkValidHash forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
BC.unpack ByteString
h) forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, Name, c)]
parseLines [ByteString]
rest
parseLines [ByteString]
_ = []
dirType :: B.ByteString
dirType :: ByteString
dirType = [Char] -> ByteString
BC.pack [Char]
"directory:"
fileType :: B.ByteString
fileType :: ByteString
fileType = [Char] -> ByteString
BC.pack [Char]
"file:"
writedir :: [DirEntry] -> HashedIO PristineHash
writedir :: [DirEntry] -> HashedIO PristineHash
writedir [DirEntry]
c = do
ByteString -> HashedIO PristineHash
writeHashFile ByteString
cps
where
cps :: ByteString
cps = [ByteString] -> ByteString
unlinesPS forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. ValidHash a => (ObjType, Name, a) -> [ByteString]
wr [DirEntry]
c forall a. [a] -> [a] -> [a]
++ [ByteString
B.empty]
wr :: (ObjType, Name, a) -> [ByteString]
wr (ObjType
o,Name
d,a
h) = [ObjType -> ByteString
showO ObjType
o, Name -> ByteString
encodeWhiteName Name
d, [Char] -> ByteString
BC.pack (forall a. ValidHash a => a -> [Char]
getValidHash a
h)]
showO :: ObjType -> ByteString
showO ObjType
D = ByteString
dirType
showO ObjType
F = ByteString
fileType
writeHashFile :: B.ByteString -> HashedIO PristineHash
writeHashFile :: ByteString -> HashedIO PristineHash
writeHashFile ByteString
ps = do
Cache
c <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ValidHash a => [Char] -> a
mkValidHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache -> Compression -> HashedDir -> ByteString -> IO [Char]
writeFileUsingCache Cache
c Compression
GzipCompression HashedDir
HashedPristineDir ByteString
ps
type ProgressKey = String
copyHashed :: ProgressKey -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed :: [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
k Cache
c WithWorkingDir
wwd PristineHash
z = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HashedIO ()
cph forall a b. (a -> b) -> a -> b
$ HashDir { cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
z }
where cph :: HashedIO ()
cph = do [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> IO ()
tediousSize [Char]
k (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DirEntry -> HashedIO ()
cp [DirEntry]
cwd
cp :: DirEntry -> HashedIO ()
cp (ObjType
F,Name
n,PristineHash
h) = do
ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k forall a b. (a -> b) -> a -> b
$ Name -> [Char]
name2fp Name
n
case WithWorkingDir
wwd of
WithWorkingDir
WithWorkingDir -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (Name -> [Char]
name2fp Name
n) ByteString
ps
WithWorkingDir
NoWorkingDir -> ByteString
ps seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()
cp (ObjType
D,Name
n,PristineHash
h) =
if [Char] -> Bool
isMaliciousSubPath (Name -> [Char]
name2fp Name
n)
then forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Caught malicious path: " forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n)
else do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k (Name -> [Char]
name2fp Name
n)
case WithWorkingDir
wwd of
WithWorkingDir
WithWorkingDir -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
False (Name -> [Char]
name2fp Name
n)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Name -> [Char]
name2fp Name
n) forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
k Cache
c WithWorkingDir
WithWorkingDir PristineHash
h
WithWorkingDir
NoWorkingDir ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
k Cache
c WithWorkingDir
NoWorkingDir PristineHash
h
pathsAndContents :: FilePath -> Cache -> PristineHash -> IO [(FilePath,B.ByteString)]
pathsAndContents :: [Char] -> Cache -> PristineHash -> IO [([Char], ByteString)]
pathsAndContents [Char]
path Cache
c PristineHash
root = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT HashDir IO [([Char], ByteString)]
cph HashDir { cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
root }
where cph :: StateT HashDir IO [([Char], ByteString)]
cph = do [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
[([Char], ByteString)]
pacs <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DirEntry -> StateT HashDir IO [([Char], ByteString)]
cp [DirEntry]
cwd
let current :: [([Char], ByteString)]
current = if [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"." then [] else [([Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
"/" , ByteString
B.empty)]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [([Char], ByteString)]
current forall a. [a] -> [a] -> [a]
++ [([Char], ByteString)]
pacs
cp :: DirEntry -> StateT HashDir IO [([Char], ByteString)]
cp (ObjType
F,Name
n,PristineHash
h) = do
ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
let p :: [Char]
p = (if [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"." then [Char]
"" else [Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
"/") forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n
forall (m :: * -> *) a. Monad m => a -> m a
return [([Char]
p,ByteString
ps)]
cp (ObjType
D,Name
n,PristineHash
h) = do
let p :: [Char]
p = (if [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"." then [Char]
"" else [Char]
path) forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n forall a. [a] -> [a] -> [a]
++ [Char]
"/"
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> PristineHash -> IO [([Char], ByteString)]
pathsAndContents [Char]
p Cache
c PristineHash
h
copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO ()
copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO ()
copyPartialsHashed Cache
c PristineHash
root = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Cache -> PristineHash -> AnchoredPath -> IO ()
copyPartialHashed Cache
c PristineHash
root)
copyPartialHashed :: Cache -> PristineHash -> AnchoredPath -> IO ()
copyPartialHashed :: Cache -> PristineHash -> AnchoredPath -> IO ()
copyPartialHashed Cache
c PristineHash
root AnchoredPath
path = do
case AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
path of
Maybe AnchoredPath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just AnchoredPath
super ->
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> [Char]
ap2fp AnchoredPath
super)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HashedIO ()
copy HashDir {cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
root}
where
copy :: HashedIO ()
copy = do
Maybe (ObjType, PristineHash)
mt <- AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
case Maybe (ObjType, PristineHash)
mt of
Just (ObjType
D, PristineHash
h) -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> [Char]
ap2fp AnchoredPath
path)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (AnchoredPath -> [Char]
ap2fp AnchoredPath
path) forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
"" Cache
c WithWorkingDir
WithWorkingDir PristineHash
h
Just (ObjType
F, PristineHash
h) -> do
ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (AnchoredPath -> [Char]
ap2fp AnchoredPath
path) ByteString
ps
Maybe (ObjType, PristineHash)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
cleanHashdir :: Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir :: Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir Cache
c HashedDir
dir [PristineHash]
hashroots =
do
[Char] -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [Char]
"Cleaning out " forall a. [a] -> [a] -> [a]
++ HashedDir -> [Char]
hashedDir HashedDir
dir forall a. [a] -> [a] -> [a]
++ [Char]
"..."
let hashdir :: [Char]
hashdir = [Char]
darcsdir forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ HashedDir -> [Char]
hashedDir HashedDir
dir forall a. [a] -> [a] -> [a]
++ [Char]
"/"
Set ByteString
hs <- [[Char]] -> Set ByteString
set forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> IO [[Char]]
getHashedFiles [Char]
hashdir (forall a b. (a -> b) -> [a] -> [b]
map forall a. ValidHash a => a -> [Char]
getValidHash [PristineHash]
hashroots)
Set ByteString
fs <- [[Char]] -> Set ByteString
set forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
okayHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
getDirectoryContents [Char]
hashdir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
hashdirforall a. [a] -> [a] -> [a]
++)) (Set ByteString -> [[Char]]
unset forall a b. (a -> b) -> a -> b
$ Set ByteString
fs forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ByteString
hs)
[Char] -> IO ()
debugMessage [Char]
"Cleaning out any global caches..."
Cache -> HashedDir -> [[Char]] -> IO ()
cleanCachesWithHint Cache
c HashedDir
dir (Set ByteString -> [[Char]]
unset forall a b. (a -> b) -> a -> b
$ Set ByteString
fs forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ByteString
hs)
where set :: [[Char]] -> Set ByteString
set = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ByteString
BC.pack
unset :: Set ByteString -> [[Char]]
unset = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Char]
BC.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList
getHashedFiles :: FilePath -> [String] -> IO [String]
getHashedFiles :: [Char] -> [[Char]] -> IO [[Char]]
getHashedFiles [Char]
hashdir [[Char]]
hashroots = do
let listone :: [Char] -> IO [[Char]]
listone [Char]
h = do
let size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
h
hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
h
[(ItemType, Name, Maybe Int, Hash)]
x <- [Char]
-> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir [Char]
hashdir (Maybe Int
size, Hash
hash)
let subs :: [[Char]]
subs = [forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ [Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
"" (Maybe Int
s, Hash
h') | (ItemType
TreeType, Name
_, Maybe Int
s, Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x]
hashes :: [[Char]]
hashes = [Char]
h forall a. a -> [a] -> [a]
: [forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ [Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
"" (Maybe Int
s, Hash
h') | (ItemType
_, Name
_, Maybe Int
s, Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x]
([[Char]]
hashes forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO [[Char]]
listone [[Char]]
subs
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO [[Char]]
listone [[Char]]
hashroots