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

-- | The way patchfiles, inventories, and pristine trees are stored.
-- 'PlainLayout' means all files are in the same directory. 'BucketedLayout'
-- means we create a second level of subdirectories, such that all files whose
-- hash starts with the same two letters are in the same directory.
-- Currently, only the global cache uses 'BucketedLayout' while repositories
-- use the 'PlainLayout'.
data DirLayout = PlainLayout | BucketedLayout

-- | Remove unreferenced entries in the pristine cache.
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
    -- and also clean out any global caches
    [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

-- | Set difference between two lists of hashes.
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

-- | Remove unreferenced files in the inventories directory.
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)

-- FIXME this is ugly, these files should be directly under _darcs
-- since they are not hashed. And 'unrevert' isn't even a real patch but
-- a patch bundle.

-- | List of special patch files that may exist in the directory
-- _darcs/patches/. We must not clean those.
specialPatches :: [FilePath]
specialPatches :: [[Char]]
specialPatches = [[Char]
"unrevert", [Char]
"pending", [Char]
"pending.tentative"]

-- | Remove unreferenced files in the patches directory.
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)

-- | Return a list of the inventories hashes.
-- The first argument can be readInventory or readInventoryLocal.
-- The second argument specifies whether the files are expected
-- to be stored in plain or in bucketed format.
-- The third argument is the directory of the parent inventory files.
-- The fourth argument is the directory of the head inventory file.
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

-- | Return a list of the inventories hashes.
-- This function attempts to retrieve missing inventory files from the cache.
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

-- | Return inventories hashes by following the head inventory.
-- This function does not attempt to retrieve missing inventory files.
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

-- | Return a list of the inventories hashes.
-- The argument @repoDir@ is the directory of the repository from which
-- we are going to read the head inventory file.
-- The rest of hashed files are read from the global cache.
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)

-- | Return a list of the patch filenames, extracted from inventory
-- files, by starting with the head inventory and then following the
-- chain of parent inventories.
--
-- This function does not attempt to download missing inventory files.
--
-- * The first argument specifies whether the files are expected
--   to be stored in plain or in bucketed format.
-- * The second argument is the directory of the parent inventory.
-- * The third argument is the directory of the head inventory.
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 is similar to listPatchesLocal, but
-- it read the inventory directory under @darcsDir@ in bucketed format.
listPatchesLocalBucketed :: String -> String -> IO [String]
listPatchesLocalBucketed :: [Char] -> [Char] -> IO [[Char]]
listPatchesLocalBucketed = DirLayout -> [Char] -> [Char] -> IO [[Char]]
listPatchesLocal DirLayout
BucketedLayout

-- | Read the given inventory file if it exist, otherwise return an empty
-- inventory. Used when we expect that some inventory files may be missing.
-- Still fails with an error message if file cannot be parsed.
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

-- | Read an inventory from a file. Fails with an error message if
-- file is not there or cannot be parsed.
readInventory :: FilePath -> IO Inventory
readInventory :: [Char] -> IO Inventory
readInventory [Char]
path = do
  -- FIXME we should check the hash (if this is a hashed file)
  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]