module Darcs.Repository.Traverse
    ( cleanInventories
    , cleanPatches
    , cleanPristine
    , cleanRepository
    , diffHashLists
    , listInventories
    , listInventoriesLocal
    , 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 )
import System.FilePath.Posix( (</>) )

import Darcs.Repository.Cache ( HashedDir(..), bucketFolder )
import Darcs.Repository.HashedIO ( cleanHashdir )
import Darcs.Repository.Inventory
    ( Inventory(..)
    , emptyInventory
    , getValidHash
    , inventoryPatchNames
    , parseInventory
    , peekPristineHash
    , skipPristineHash
    )
import Darcs.Repository.InternalTypes
    ( Repository
    , repoCache
    , withRepoLocation
    )
import Darcs.Repository.Paths
    ( hashedInventory
    , hashedInventoryPath
    , inventoriesDir
    , inventoriesDirPath
    , patchesDirPath
    )
import Darcs.Repository.Prefs ( globalCacheDir )

import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Exception ( ifDoesNotExistError )
import Darcs.Util.Global ( darcsdir, debugMessage )
import Darcs.Util.Lock ( removeFileMayNotExist )


cleanRepository :: Repository rt p wR wU wT -> IO ()
cleanRepository :: Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wT
r = Repository rt p wR wU wT -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanPristine Repository rt p wR wU wT
r IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Repository rt p wR wU wT -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanInventories Repository rt p wR wU wT
r IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Repository rt p wR wU wT -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanPatches Repository rt p wR wU wT
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 rt p wR wU wT -> IO ()
cleanPristine :: Repository rt p wR wU wT -> IO ()
cleanPristine Repository rt p wR wU wT
r = Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
r (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
debugMessage String
"Cleaning out the pristine cache..."
    ByteString
i <- String -> IO ByteString
gzReadFilePS String
hashedInventoryPath
    Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir (Repository rt p wR wU wT -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r) HashedDir
HashedPristineDir [ByteString -> PristineHash
peekPristineHash ByteString
i]

-- | Set difference between two lists of hashes.
diffHashLists :: [String] -> [String] -> [String]
diffHashLists :: [String] -> [String] -> [String]
diffHashLists [String]
xs [String]
ys = Set ByteString -> [String]
from_set (Set ByteString -> [String]) -> Set ByteString -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> Set ByteString
to_set [String]
xs) Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` ([String] -> Set ByteString
to_set [String]
ys)
  where
    to_set :: [String] -> Set ByteString
to_set = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString)
-> ([String] -> [ByteString]) -> [String] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
BC.pack
    from_set :: Set ByteString -> [String]
from_set = (ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
BC.unpack ([ByteString] -> [String])
-> (Set ByteString -> [ByteString]) -> Set ByteString -> [String]
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 rt p wR wU wT -> IO ()
cleanInventories :: Repository rt p wR wU wT -> IO ()
cleanInventories Repository rt p wR wU wT
_ = do
    String -> IO ()
debugMessage String
"Cleaning out inventories..."
    [String]
hs <- IO [String]
listInventoriesLocal
    [String]
fs <- [String] -> IO [String] -> IO [String]
forall a. a -> IO a -> IO a
ifDoesNotExistError [] (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
listDirectory String
inventoriesDirPath
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
inventoriesDirPath String -> String -> String
</>))
        ([String] -> [String] -> [String]
diffHashLists [String]
fs [String]
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 :: [String]
specialPatches = [String
"unrevert", String
"pending", String
"pending.tentative"]

-- | Remove unreferenced files in the patches directory.
cleanPatches :: Repository rt p wR wU wT -> IO ()
cleanPatches :: Repository rt p wR wU wT -> IO ()
cleanPatches Repository rt p wR wU wT
_ = do
    String -> IO ()
debugMessage String
"Cleaning out patches..."
    [String]
hs <- ([String]
specialPatches [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DirLayout -> String -> String -> IO [String]
listPatchesLocal DirLayout
PlainLayout String
darcsdir String
darcsdir
    [String]
fs <- [String] -> IO [String] -> IO [String]
forall a. a -> IO a -> IO a
ifDoesNotExistError [] (String -> IO [String]
listDirectory String
patchesDirPath)
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
patchesDirPath String -> String -> String
</>)) ([String] -> [String] -> [String]
diffHashLists [String]
fs [String]
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 :: (String -> IO Inventory)
-> DirLayout -> String -> String -> IO [String]
listInventoriesWith String -> IO Inventory
readInv DirLayout
dirformat String
baseDir String
startDir = do
    Maybe InventoryHash
mbStartingWithInv <- String -> String -> IO (Maybe InventoryHash)
getStartingWithHash String
startDir String
hashedInventory
    Maybe InventoryHash -> IO [String]
followStartingWiths Maybe InventoryHash
mbStartingWithInv
  where
    getStartingWithHash :: String -> String -> IO (Maybe InventoryHash)
getStartingWithHash String
dir String
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
<$> String -> IO Inventory
readInv (String
dir String -> String -> String
</> String
file)

    invDir :: String
invDir = String
baseDir String -> String -> String
</> String
inventoriesDir
    nextDir :: String -> String
nextDir String
dir = case DirLayout
dirformat of
        DirLayout
BucketedLayout -> String
invDir String -> String -> String
</> String -> String
bucketFolder String
dir
        DirLayout
PlainLayout -> String
invDir

    followStartingWiths :: Maybe InventoryHash -> IO [String]
followStartingWiths Maybe InventoryHash
Nothing = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    followStartingWiths (Just InventoryHash
hash) = do
        let startingWith :: String
startingWith = InventoryHash -> String
forall a. ValidHash a => a -> String
getValidHash InventoryHash
hash
        Maybe InventoryHash
mbNextInv <- String -> String -> IO (Maybe InventoryHash)
getStartingWithHash (String -> String
nextDir String
startingWith) String
startingWith
        (String
startingWith String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InventoryHash -> IO [String]
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 [String]
listInventories =
    (String -> IO Inventory)
-> DirLayout -> String -> String -> IO [String]
listInventoriesWith String -> IO Inventory
readInventory DirLayout
PlainLayout String
darcsdir String
darcsdir

-- | Return inventories hashes by following the head inventory.
-- This function does not attempt to retrieve missing inventory files.
listInventoriesLocal :: IO [String]
listInventoriesLocal :: IO [String]
listInventoriesLocal =
    (String -> IO Inventory)
-> DirLayout -> String -> String -> IO [String]
listInventoriesWith String -> IO Inventory
readInventoryLocal DirLayout
PlainLayout String
darcsdir String
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 :: String -> IO [String]
listInventoriesRepoDir String
repoDir = do
    Maybe String
gCacheDir' <- IO (Maybe String)
globalCacheDir
    let gCacheInvDir :: String
gCacheInvDir = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
gCacheDir'
    (String -> IO Inventory)
-> DirLayout -> String -> String -> IO [String]
listInventoriesWith
        String -> IO Inventory
readInventoryLocal
        DirLayout
BucketedLayout
        String
gCacheInvDir
        (String
repoDir String -> String -> String
</> String
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 -> String -> String -> IO [String]
listPatchesLocal DirLayout
dirformat String
baseDir String
startDir = do
  Inventory
inventory <- String -> IO Inventory
readInventory (String
startDir String -> String -> String
</> String
hashedInventory)
  Maybe InventoryHash -> [String] -> IO [String]
followStartingWiths
    (Inventory -> Maybe InventoryHash
inventoryParent Inventory
inventory)
    (Inventory -> [String]
inventoryPatchNames Inventory
inventory)
  where
    invDir :: String
invDir = String
baseDir String -> String -> String
</> String
inventoriesDir
    nextDir :: String -> String
nextDir String
dir =
      case DirLayout
dirformat of
        DirLayout
BucketedLayout -> String
invDir String -> String -> String
</> String -> String
bucketFolder String
dir
        DirLayout
PlainLayout -> String
invDir
    followStartingWiths :: Maybe InventoryHash -> [String] -> IO [String]
followStartingWiths Maybe InventoryHash
Nothing [String]
patches = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
patches
    followStartingWiths (Just InventoryHash
hash) [String]
patches = do
      let startingWith :: String
startingWith = InventoryHash -> String
forall a. ValidHash a => a -> String
getValidHash InventoryHash
hash
      Inventory
inv <- String -> IO Inventory
readInventoryLocal (String -> String
nextDir String
startingWith String -> String -> String
</> String
startingWith)
      ([String]
patches [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Maybe InventoryHash -> [String] -> IO [String]
followStartingWiths (Inventory -> Maybe InventoryHash
inventoryParent Inventory
inv) (Inventory -> [String]
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 :: String -> String -> IO [String]
listPatchesLocalBucketed = DirLayout -> String -> String -> IO [String]
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 :: String -> IO Inventory
readInventoryLocal String
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
$ String -> IO Inventory
readInventory String
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 :: String -> IO Inventory
readInventory String
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
<$> String -> IO ByteString
gzReadFilePS String
path
  case ByteString -> Either String Inventory
parseInventory ByteString
inv of
    Right Inventory
r -> Inventory -> IO Inventory
forall (m :: * -> *) a. Monad m => a -> m a
return Inventory
r
    Left String
e -> String -> IO Inventory
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Inventory) -> String -> IO Inventory
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [[String] -> String
unwords [String
"parse error in file", String
path], String
e]