module Darcs.Repository.Traverse
( cleanRepository
, cleanPristineDir
, listInventories
, listInventoriesRepoDir
, listPatchesLocalBucketed
, specialPatches
) where
import Darcs.Prelude
import Data.Maybe ( fromJust )
import qualified Data.ByteString.Char8 as BC ( unpack, pack )
import qualified Data.Set as Set
import System.Directory ( listDirectory, withCurrentDirectory )
import System.FilePath.Posix( (</>) )
import Darcs.Repository.Inventory
( Inventory(..)
, PristineHash
, emptyInventory
, encodeValidHash
, inventoryPatchNames
, parseInventory
, peekPristineHash
, skipPristineHash
)
import Darcs.Repository.InternalTypes
( Repository
, AccessType(..)
, repoCache
, withRepoDir
)
import Darcs.Repository.Paths
( tentativeHashedInventory
, tentativePristinePath
, inventoriesDir
, inventoriesDirPath
, patchesDirPath
, pristineDirPath
)
import Darcs.Repository.Prefs ( globalCacheDir )
import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Cache
( Cache
, HashedDir(HashedPristineDir)
, bucketFolder
, cleanCachesWithHint
)
import Darcs.Util.Exception ( ifDoesNotExistError )
import Darcs.Util.Global ( darcsdir, debugMessage )
import Darcs.Util.Lock ( removeFileMayNotExist )
import Darcs.Util.Tree.Hashed ( followPristineHashes )
cleanRepository :: Repository 'RW p wU wR -> IO ()
cleanRepository :: forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p wU wR
r = Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanPristine Repository 'RW p wU wR
r IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanInventories Repository 'RW p wU wR
r IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanPatches Repository 'RW p wU wR
r
data DirLayout = PlainLayout | BucketedLayout
cleanPristine :: Repository 'RW p wU wR -> IO ()
cleanPristine :: forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanPristine Repository 'RW p wU wR
r = Repository 'RW p wU wR -> IO () -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository 'RW p wU wR
r (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Char] -> IO ()
debugMessage [Char]
"Cleaning out the pristine cache..."
ByteString
i <- [Char] -> IO ByteString
gzReadFilePS [Char]
tentativePristinePath
Cache -> [PristineHash] -> IO ()
cleanPristineDir (Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
r) [ByteString -> PristineHash
peekPristineHash ByteString
i]
cleanPristineDir :: Cache -> [PristineHash] -> IO ()
cleanPristineDir :: Cache -> [PristineHash] -> IO ()
cleanPristineDir Cache
cache [PristineHash]
roots = do
Set ByteString
reachable <- [[Char]] -> Set ByteString
set ([[Char]] -> Set ByteString)
-> ([PristineHash] -> [[Char]]) -> [PristineHash] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PristineHash -> [Char]) -> [PristineHash] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PristineHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash ([PristineHash] -> Set ByteString)
-> IO [PristineHash] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache -> [PristineHash] -> IO [PristineHash]
followPristineHashes Cache
cache [PristineHash]
roots
Set ByteString
files <- [[Char]] -> Set ByteString
set ([[Char]] -> Set ByteString) -> IO [[Char]] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
listDirectory [Char]
pristineDirPath
let to_remove :: [[Char]]
to_remove = Set ByteString -> [[Char]]
unset (Set ByteString -> [[Char]]) -> Set ByteString -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set ByteString
files Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ByteString
reachable
[Char] -> IO () -> IO ()
forall a. [Char] -> IO a -> IO a
withCurrentDirectory [Char]
pristineDirPath (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist [[Char]]
to_remove
[Char] -> IO ()
debugMessage [Char]
"Cleaning out any global caches..."
Cache -> HashedDir -> [[Char]] -> IO ()
cleanCachesWithHint Cache
cache HashedDir
HashedPristineDir [[Char]]
to_remove
where
set :: [[Char]] -> Set ByteString
set = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString)
-> ([[Char]] -> [ByteString]) -> [[Char]] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ByteString) -> [[Char]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ByteString
BC.pack
unset :: Set ByteString -> [[Char]]
unset = (ByteString -> [Char]) -> [ByteString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Char]
BC.unpack ([ByteString] -> [[Char]])
-> (Set ByteString -> [ByteString]) -> Set ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ByteString -> [ByteString]
forall a. Set a -> [a]
Set.toList
diffHashLists :: [String] -> [String] -> [String]
diffHashLists :: [[Char]] -> [[Char]] -> [[Char]]
diffHashLists [[Char]]
xs [[Char]]
ys = Set ByteString -> [[Char]]
from_set (Set ByteString -> [[Char]]) -> Set ByteString -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> Set ByteString
to_set [[Char]]
xs) Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` ([[Char]] -> Set ByteString
to_set [[Char]]
ys)
where
to_set :: [[Char]] -> Set ByteString
to_set = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString)
-> ([[Char]] -> [ByteString]) -> [[Char]] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ByteString) -> [[Char]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ByteString
BC.pack
from_set :: Set ByteString -> [[Char]]
from_set = (ByteString -> [Char]) -> [ByteString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Char]
BC.unpack ([ByteString] -> [[Char]])
-> (Set ByteString -> [ByteString]) -> Set ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ByteString -> [ByteString]
forall a. Set a -> [a]
Set.toList
cleanInventories :: Repository 'RW p wU wR -> IO ()
cleanInventories :: forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanInventories Repository 'RW p wU wR
_ = do
[Char] -> IO ()
debugMessage [Char]
"Cleaning out inventories..."
[[Char]]
hs <- IO [[Char]]
listInventoriesLocal
[[Char]]
fs <- [[Char]] -> IO [[Char]] -> IO [[Char]]
forall a. a -> IO a -> IO a
ifDoesNotExistError [] (IO [[Char]] -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
listDirectory [Char]
inventoriesDirPath
([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
inventoriesDirPath [Char] -> [Char] -> [Char]
</>))
([[Char]] -> [[Char]] -> [[Char]]
diffHashLists [[Char]]
fs [[Char]]
hs)
specialPatches :: [FilePath]
specialPatches :: [[Char]]
specialPatches = [[Char]
"unrevert", [Char]
"pending", [Char]
"pending.tentative"]
cleanPatches :: Repository 'RW p wU wR -> IO ()
cleanPatches :: forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanPatches Repository 'RW p wU wR
_ = do
[Char] -> IO ()
debugMessage [Char]
"Cleaning out patches..."
[[Char]]
hs <- ([[Char]]
specialPatches [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DirLayout -> [Char] -> [Char] -> IO [[Char]]
listPatchesLocal DirLayout
PlainLayout [Char]
darcsdir [Char]
darcsdir
[[Char]]
fs <- [[Char]] -> IO [[Char]] -> IO [[Char]]
forall a. a -> IO a -> IO a
ifDoesNotExistError [] ([Char] -> IO [[Char]]
listDirectory [Char]
patchesDirPath)
([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
patchesDirPath [Char] -> [Char] -> [Char]
</>)) ([[Char]] -> [[Char]] -> [[Char]]
diffHashLists [[Char]]
fs [[Char]]
hs)
listInventoriesWith
:: (FilePath -> IO Inventory)
-> DirLayout
-> String -> String -> IO [String]
listInventoriesWith :: ([Char] -> IO Inventory)
-> DirLayout -> [Char] -> [Char] -> IO [[Char]]
listInventoriesWith [Char] -> IO Inventory
readInv DirLayout
dirformat [Char]
baseDir [Char]
startDir = do
Maybe InventoryHash
mbStartingWithInv <- [Char] -> [Char] -> IO (Maybe InventoryHash)
getStartingWithHash [Char]
startDir [Char]
tentativeHashedInventory
Maybe InventoryHash -> IO [[Char]]
followStartingWiths Maybe InventoryHash
mbStartingWithInv
where
getStartingWithHash :: [Char] -> [Char] -> IO (Maybe InventoryHash)
getStartingWithHash [Char]
dir [Char]
file = Inventory -> Maybe InventoryHash
inventoryParent (Inventory -> Maybe InventoryHash)
-> IO Inventory -> IO (Maybe InventoryHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Inventory
readInv ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
file)
invDir :: [Char]
invDir = [Char]
baseDir [Char] -> [Char] -> [Char]
</> [Char]
inventoriesDir
nextDir :: [Char] -> [Char]
nextDir [Char]
dir = case DirLayout
dirformat of
DirLayout
BucketedLayout -> [Char]
invDir [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
bucketFolder [Char]
dir
DirLayout
PlainLayout -> [Char]
invDir
followStartingWiths :: Maybe InventoryHash -> IO [[Char]]
followStartingWiths Maybe InventoryHash
Nothing = [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
followStartingWiths (Just InventoryHash
hash) = do
let startingWith :: [Char]
startingWith = InventoryHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash InventoryHash
hash
Maybe InventoryHash
mbNextInv <- [Char] -> [Char] -> IO (Maybe InventoryHash)
getStartingWithHash ([Char] -> [Char]
nextDir [Char]
startingWith) [Char]
startingWith
([Char]
startingWith [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InventoryHash -> IO [[Char]]
followStartingWiths Maybe InventoryHash
mbNextInv
listInventories :: IO [String]
listInventories :: IO [[Char]]
listInventories =
([Char] -> IO Inventory)
-> DirLayout -> [Char] -> [Char] -> IO [[Char]]
listInventoriesWith [Char] -> IO Inventory
readInventory DirLayout
PlainLayout [Char]
darcsdir [Char]
darcsdir
listInventoriesLocal :: IO [String]
listInventoriesLocal :: IO [[Char]]
listInventoriesLocal =
([Char] -> IO Inventory)
-> DirLayout -> [Char] -> [Char] -> IO [[Char]]
listInventoriesWith [Char] -> IO Inventory
readInventoryLocal DirLayout
PlainLayout [Char]
darcsdir [Char]
darcsdir
listInventoriesRepoDir :: String -> IO [String]
listInventoriesRepoDir :: [Char] -> IO [[Char]]
listInventoriesRepoDir [Char]
repoDir = do
Maybe [Char]
gCacheDir' <- IO (Maybe [Char])
globalCacheDir
let gCacheInvDir :: [Char]
gCacheInvDir = Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [Char]
gCacheDir'
([Char] -> IO Inventory)
-> DirLayout -> [Char] -> [Char] -> IO [[Char]]
listInventoriesWith
[Char] -> IO Inventory
readInventoryLocal
DirLayout
BucketedLayout
[Char]
gCacheInvDir
([Char]
repoDir [Char] -> [Char] -> [Char]
</> [Char]
darcsdir)
listPatchesLocal :: DirLayout -> String -> String -> IO [String]
listPatchesLocal :: DirLayout -> [Char] -> [Char] -> IO [[Char]]
listPatchesLocal DirLayout
dirformat [Char]
baseDir [Char]
startDir = do
Inventory
inventory <- [Char] -> IO Inventory
readInventory ([Char]
startDir [Char] -> [Char] -> [Char]
</> [Char]
tentativeHashedInventory)
Maybe InventoryHash -> [[Char]] -> IO [[Char]]
followStartingWiths
(Inventory -> Maybe InventoryHash
inventoryParent Inventory
inventory)
(Inventory -> [[Char]]
inventoryPatchNames Inventory
inventory)
where
invDir :: [Char]
invDir = [Char]
baseDir [Char] -> [Char] -> [Char]
</> [Char]
inventoriesDir
nextDir :: [Char] -> [Char]
nextDir [Char]
dir =
case DirLayout
dirformat of
DirLayout
BucketedLayout -> [Char]
invDir [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
bucketFolder [Char]
dir
DirLayout
PlainLayout -> [Char]
invDir
followStartingWiths :: Maybe InventoryHash -> [[Char]] -> IO [[Char]]
followStartingWiths Maybe InventoryHash
Nothing [[Char]]
patches = [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]]
patches
followStartingWiths (Just InventoryHash
hash) [[Char]]
patches = do
let startingWith :: [Char]
startingWith = InventoryHash -> [Char]
forall h. ValidHash h => h -> [Char]
encodeValidHash InventoryHash
hash
Inventory
inv <- [Char] -> IO Inventory
readInventoryLocal ([Char] -> [Char]
nextDir [Char]
startingWith [Char] -> [Char] -> [Char]
</> [Char]
startingWith)
([[Char]]
patches [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Maybe InventoryHash -> [[Char]] -> IO [[Char]]
followStartingWiths (Inventory -> Maybe InventoryHash
inventoryParent Inventory
inv) (Inventory -> [[Char]]
inventoryPatchNames Inventory
inv)
listPatchesLocalBucketed :: String -> String -> IO [String]
listPatchesLocalBucketed :: [Char] -> [Char] -> IO [[Char]]
listPatchesLocalBucketed = DirLayout -> [Char] -> [Char] -> IO [[Char]]
listPatchesLocal DirLayout
BucketedLayout
readInventoryLocal :: FilePath -> IO Inventory
readInventoryLocal :: [Char] -> IO Inventory
readInventoryLocal [Char]
path =
Inventory -> IO Inventory -> IO Inventory
forall a. a -> IO a -> IO a
ifDoesNotExistError Inventory
emptyInventory (IO Inventory -> IO Inventory) -> IO Inventory -> IO Inventory
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Inventory
readInventory [Char]
path
readInventory :: FilePath -> IO Inventory
readInventory :: [Char] -> IO Inventory
readInventory [Char]
path = do
ByteString
inv <- ByteString -> ByteString
skipPristineHash (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
gzReadFilePS [Char]
path
case ByteString -> Either [Char] Inventory
parseInventory ByteString
inv of
Right Inventory
r -> Inventory -> IO Inventory
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Inventory
r
Left [Char]
e -> [Char] -> IO Inventory
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO Inventory) -> [Char] -> IO Inventory
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[[Char]] -> [Char]
unwords [[Char]
"parse error in file", [Char]
path], [Char]
e]