{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Optimize ( optimize ) where
import Darcs.Prelude
import Control.Monad ( when, unless, forM_ )
import Data.List ( nub )
import Data.Maybe ( fromJust, isJust )
import System.Directory
( listDirectory
, doesDirectoryExist
, renameFile
, createDirectoryIfMissing
, removeFile
, getHomeDirectory
, removeDirectoryRecursive
)
import qualified Data.ByteString.Char8 as BC
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults
, amInHashedRepository, amInRepository, putInfo
, normalCommand, withStdOpts )
import Darcs.UI.Completion ( noArgs )
import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir )
import Darcs.Repository
( Repository
, repoLocation
, withRepoLock
, RepoJob(..)
, readRepo
, reorderInventory
, cleanRepository
, replacePristine
)
import Darcs.Repository.Job ( withOldRepoLock )
import Darcs.Repository.Identify ( findAllReposInDir )
import Darcs.Repository.Traverse
( diffHashLists
, listInventoriesRepoDir
, listPatchesLocalBucketed
, specialPatches
)
import Darcs.Repository.Inventory ( peekPristineHash )
import Darcs.Repository.Paths
( formatPath
, hashedInventoryPath
, inventoriesDir
, inventoriesDirPath
, oldCheckpointDirPath
, oldCurrentDirPath
, oldInventoryPath
, oldPristineDirPath
, oldTentativeInventoryPath
, patchesDir
, patchesDirPath
, pristineDir
, pristineDirPath
, tentativePristinePath
)
import Darcs.Repository.Packs ( createPacks )
import Darcs.Repository.HashedIO ( getHashedFiles )
import Darcs.Repository.Inventory ( getValidHash )
import Darcs.Patch.Witnesses.Ordered
( mapFL
, bunchFL
, lengthRL
)
import Darcs.Patch ( IsRepoType, RepoPatch )
import Darcs.Patch.Set
( patchSet2RL
, patchSet2FL
, progressPatchSet
)
import Darcs.Patch.Apply( ApplyState )
import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Printer ( Doc, formatWords, text, wrapText, ($+$) )
import Darcs.Util.Lock
( maybeRelink
, gzWriteAtomicFilePS
, writeAtomicFilePS
, removeFileMayNotExist
, writeBinFile
)
import Darcs.Util.File
( withCurrentDirectory
, getRecursiveContents
, doesDirectoryReallyExist
)
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Progress
( beginTedious
, endTedious
, tediousSize
, debugMessage
)
import Darcs.Util.Global ( darcsdir )
import System.FilePath.Posix
( takeExtension
, (</>)
, joinPath
)
import Text.Printf ( printf )
import Darcs.UI.Flags
( DarcsFlag, useCache, umask )
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck
, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags
( UpdatePending (..), DryRun ( NoDryRun ), UseCache (..), UMask (..)
, WithWorkingDir(WithWorkingDir), PatchFormat(PatchFormat1) )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Repository.Cache ( hashedDir, bucketFolder,
HashedDir(HashedPristineDir) )
import Darcs.Repository.Format
( identifyRepoFormat
, createRepoFormat
, writeRepoFormat
, formatHas
, RepoProperty ( HashedInventory )
)
import Darcs.Repository.PatchIndex
import Darcs.Repository.Hashed
( writeTentativeInventory
, finalizeTentativeChanges
)
import Darcs.Repository.Pristine
( ApplyDir(ApplyNormal)
, applyToTentativePristineCwd
)
import Darcs.Repository.State ( readRecorded )
import Darcs.Util.Tree
( Tree
, TreeItem(..)
, list
, expand
, emptyTree
)
import Darcs.Util.Path( realPath, toFilePath, AbsolutePath )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Tree.Hashed
( writeDarcsHashed
, decodeDarcsSize
)
optimizeDescription :: String
optimizeDescription :: FilePath
optimizeDescription = FilePath
"Optimize the repository."
optimizeHelp :: Doc
optimizeHelp :: Doc
optimizeHelp = [FilePath] -> Doc
formatWords
[ FilePath
"The `darcs optimize` command modifies internal data structures of"
, FilePath
"the current repository in an attempt to reduce its resource requirements."
]
Doc -> Doc -> Doc
$+$ Doc
"For further details see the descriptions of the subcommands."
optimize :: DarcsCommand
optimize :: DarcsCommand
optimize = SuperCommand {
commandProgramName :: FilePath
commandProgramName = FilePath
"darcs"
, commandName :: FilePath
commandName = FilePath
"optimize"
, commandHelp :: Doc
commandHelp = Doc
optimizeHelp
, commandDescription :: FilePath
commandDescription = FilePath
optimizeDescription
, commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq = [DarcsFlag] -> IO (Either FilePath ())
amInRepository
, commandSubCommands :: [CommandControl]
commandSubCommands = [ DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeClean,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeHttp,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeReorder,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeEnablePatchIndex,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeDisablePatchIndex,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeCompress,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeUncompress,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeRelink,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizePristine,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeUpgrade,
DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeGlobalCache
]
}
commonBasicOpts :: DarcsOption a (Maybe String -> a)
commonBasicOpts :: forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts = forall a. DarcsOption a (Maybe FilePath -> a)
O.repoDir
commonAdvancedOpts :: DarcsOption a (UMask -> a)
commonAdvancedOpts :: forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts = forall a. DarcsOption a (UMask -> a)
O.umask
common :: DarcsCommand
common :: DarcsCommand
common = DarcsCommand
{ commandProgramName :: FilePath
commandProgramName = FilePath
"darcs"
, commandExtraArgs :: Int
commandExtraArgs = Int
0
, commandExtraArgHelp :: [FilePath]
commandExtraArgHelp = []
, commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq = [DarcsFlag] -> IO (Either FilePath ())
amInHashedRepository
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [FilePath] -> IO [FilePath]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [FilePath] -> IO [FilePath]
nodefaults
, commandName :: FilePath
commandName = forall a. HasCallStack => a
undefined
, commandHelp :: Doc
commandHelp = forall a. HasCallStack => a
undefined
, commandDescription :: FilePath
commandDescription = forall a. HasCallStack => a
undefined
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = forall a. HasCallStack => a
undefined
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [FilePath] -> IO [FilePath]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [FilePath] -> IO [FilePath]
noArgs
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Maybe FilePath
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
commonOpts
, commandCheckOptions :: [DarcsFlag] -> [FilePath]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [FilePath]
ocheck forall {a}.
DarcsOption
a
(Maybe FilePath
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
commonOpts
}
where
commonOpts :: DarcsOption
a
(Maybe FilePath
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
commonOpts = forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts
optimizeClean :: DarcsCommand
optimizeClean :: DarcsCommand
optimizeClean = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"clean"
, commandDescription :: FilePath
commandDescription = FilePath
"garbage collect pristine, inventories and patches"
, commandHelp :: Doc
commandHelp = Doc
optimizeHelpClean
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCleanCmd
}
optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCleanCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done cleaning repository!"
optimizeUpgrade :: DarcsCommand
optimizeUpgrade :: DarcsCommand
optimizeUpgrade = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"upgrade"
, commandHelp :: Doc
commandHelp = Int -> FilePath -> Doc
wrapText Int
80
FilePath
"Convert old-fashioned repositories to the current default hashed format."
, commandDescription :: FilePath
commandDescription = FilePath
"upgrade repository to latest compatible format"
, commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq = [DarcsFlag] -> IO (Either FilePath ())
amInRepository
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUpgradeCmd
}
optimizeHttp :: DarcsCommand
optimizeHttp :: DarcsCommand
optimizeHttp = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"http"
, commandHelp :: Doc
commandHelp = Doc
optimizeHelpHttp
, commandDescription :: FilePath
commandDescription = FilePath
"optimize repository for getting over network"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeHttpCmd
}
optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeHttpCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO ()
createPacks Repository rt p wR wU wR
repository
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done creating packs!"
optimizePristine :: DarcsCommand
optimizePristine :: DarcsCommand
optimizePristine = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"pristine"
, commandHelp :: Doc
commandHelp = Int -> FilePath -> Doc
wrapText Int
80 forall a b. (a -> b) -> a -> b
$
FilePath
"This command updates the format of `"forall a. [a] -> [a] -> [a]
++FilePath
pristineDirPathforall a. [a] -> [a] -> [a]
++
FilePath
"`, which was different\nbefore darcs 2.3.1."
, commandDescription :: FilePath
commandDescription = FilePath
"optimize hashed pristine layout"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizePristineCmd
}
optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizePristineCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
[DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine [DarcsFlag]
opts Repository rt p wR wU wR
repository
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done optimizing pristine!"
optimizeCompress :: DarcsCommand
optimizeCompress :: DarcsCommand
optimizeCompress = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"compress"
, commandHelp :: Doc
commandHelp = Doc
optimizeHelpCompression
, commandDescription :: FilePath
commandDescription = FilePath
"compress patches and inventories"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCompressCmd
}
optimizeUncompress :: DarcsCommand
optimizeUncompress :: DarcsCommand
optimizeUncompress = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"uncompress"
, commandHelp :: Doc
commandHelp = Doc
optimizeHelpCompression
, commandDescription :: FilePath
commandDescription = FilePath
"uncompress patches and inventories"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUncompressCmd
}
optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeCompressCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
O.GzipCompression [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done optimizing by compression!"
optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUncompressCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
O.NoCompression [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done optimizing by uncompression!"
optimizeCompression :: O.Compression -> [DarcsFlag] -> IO ()
optimizeCompression :: Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
compression [DarcsFlag]
opts = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing (un)compression of patches..."
FilePath -> IO ()
do_compress FilePath
patchesDirPath
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing (un)compression of inventories..."
FilePath -> IO ()
do_compress FilePath
inventoriesDirPath
where
do_compress :: FilePath -> IO ()
do_compress FilePath
f = do
Bool
isd <- FilePath -> IO Bool
doesDirectoryExist FilePath
f
if Bool
isd
then forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory FilePath
f forall a b. (a -> b) -> a -> b
$ do
[FilePath]
fs <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath]
specialPatches) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
"."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
do_compress [FilePath]
fs
else FilePath -> IO ByteString
gzReadFilePS FilePath
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
case Compression
compression of
Compression
O.GzipCompression -> forall p. FilePathLike p => p -> ByteString -> IO ()
gzWriteAtomicFilePS FilePath
f
Compression
O.NoCompression -> forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS FilePath
f
optimizeEnablePatchIndex :: DarcsCommand
optimizeEnablePatchIndex :: DarcsCommand
optimizeEnablePatchIndex = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"enable-patch-index"
, commandHelp :: Doc
commandHelp = [FilePath] -> Doc
formatWords
[ FilePath
"Build the patch index, an internal data structure that accelerates"
, FilePath
"commands that need to know what patches touch a given file. Such as"
, FilePath
"annotate and log."
]
, commandDescription :: FilePath
commandDescription = FilePath
"Enable patch index"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeEnablePatchIndexCmd
}
optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"disable-patch-index"
, commandHelp :: Doc
commandHelp = Int -> FilePath -> Doc
wrapText Int
80
FilePath
"Delete and stop maintaining the patch index from the repository."
, commandDescription :: FilePath
commandDescription = FilePath
"Disable patch index"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeDisablePatchIndexCmd
}
optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeEnablePatchIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
PatchSet rt p Origin wR
ps <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO ()
createOrUpdatePatchIndexDisk Repository rt p wR wU wR
repository PatchSet rt p Origin wR
ps
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done enabling patch index!"
optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeDisablePatchIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repo -> do
FilePath -> IO ()
deletePatchIndex (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> FilePath
repoLocation Repository rt p wR wU wR
repo)
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done disabling patch index!"
optimizeReorder :: DarcsCommand
optimizeReorder :: DarcsCommand
optimizeReorder = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"reorder"
, commandHelp :: Doc
commandHelp = [FilePath] -> Doc
formatWords
[ FilePath
"This command moves recent patches (those not included in"
, FilePath
"the latest tag) to the \"front\", reducing the amount that a typical"
, FilePath
"remote command needs to download. It should also reduce the CPU time"
, FilePath
"needed for some operations."
]
, commandDescription :: FilePath
commandDescription = FilePath
"reorder the patches in the repository"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeReorderCmd
}
optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeReorderCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> Compression -> IO ()
reorderInventory Repository rt p wR wU wR
repository (PrimDarcsOption Compression
O.compress forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done reordering!"
optimizeRelink :: DarcsCommand
optimizeRelink :: DarcsCommand
optimizeRelink = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"relink"
, commandHelp :: Doc
commandHelp = Doc
optimizeHelpRelink
, commandDescription :: FilePath
commandDescription = FilePath
"relink random internal data to a sibling"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeRelinkCmd
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr DarcsFlag a (Maybe FilePath -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Maybe FilePath
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
optimizeRelinkOpts
, commandCheckOptions :: [DarcsFlag] -> [FilePath]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [FilePath]
ocheck forall {a}.
DarcsOption
a
(Maybe FilePath
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
optimizeRelinkOpts
}
where
optimizeRelinkBasicOpts :: OptSpec
DarcsOptDescr DarcsFlag a (Maybe FilePath -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts = forall a. DarcsOption a (Maybe FilePath -> a)
commonBasicOpts forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption [AbsolutePath]
O.siblings
optimizeRelinkOpts :: DarcsOption
a
(Maybe FilePath
-> [AbsolutePath]
-> Maybe StdCmdAction
-> Verbosity
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
optimizeRelinkOpts = forall {a}.
OptSpec
DarcsOptDescr DarcsFlag a (Maybe FilePath -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts
optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeRelinkCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (forall a. DarcsOption a (UMask -> a)
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wR
repository
[DarcsFlag] -> IO ()
doRelink [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done relinking!"
optimizeHelpHttp :: Doc
optimizeHelpHttp :: Doc
optimizeHelpHttp = [FilePath] -> Doc
formatWords
[ FilePath
"Using this option creates 'repository packs' that can dramatically"
, FilePath
"speed up performance when a user does a `darcs clone` of the repository"
, FilePath
"over HTTP. To make use of packs, the clients must have a darcs of at"
, FilePath
"least version 2.10."
]
optimizeHelpClean :: Doc
optimizeHelpClean :: Doc
optimizeHelpClean = [FilePath] -> Doc
formatWords
[ FilePath
"Darcs normally does not delete hashed files that are no longer"
, FilePath
"referenced by the current repository state. This command can be"
, FilePath
"use to get rid of these files to save some disk space."
]
optimizeHelpCompression :: Doc
optimizeHelpCompression :: Doc
optimizeHelpCompression =
[FilePath] -> Doc
formatWords
[ FilePath
"By default patches are compressed with zlib (RFC 1951) to reduce"
, FilePath
"storage (and download) size. In exceptional circumstances, it may be"
, FilePath
"preferable to avoid compression. In this case the `--dont-compress`"
, FilePath
"option can be used (e.g. with `darcs record`) to avoid compression."
]
Doc -> Doc -> Doc
$+$ [FilePath] -> Doc
formatWords
[ FilePath
"The `darcs optimize uncompress` and `darcs optimize compress`"
, FilePath
"commands can be used to ensure existing patches in the current"
, FilePath
"repository are respectively uncompressed or compressed."
]
optimizeHelpRelink :: Doc
optimizeHelpRelink :: Doc
optimizeHelpRelink =
[FilePath] -> Doc
formatWords
[ FilePath
"The `darcs optimize relink` command hard-links patches that the"
, FilePath
"current repository has in common with its peers. Peers are those"
, FilePath
"repositories listed in `_darcs/prefs/sources`, or defined with the"
, FilePath
"`--sibling` option (which can be used multiple times)."
]
Doc -> Doc -> Doc
$+$ [FilePath] -> Doc
formatWords
[ FilePath
"Darcs uses hard-links automatically, so this command is rarely needed."
, FilePath
"It is most useful if you used `cp -r` instead of `darcs clone` to copy a"
, FilePath
"repository, or if you pulled the same patch from a remote repository"
, FilePath
"into multiple local repositories."
]
doOptimizePristine :: [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
[DarcsFlag] -> Repository rt p wR wU wT -> IO ()
doOptimizePristine [DarcsFlag]
opts Repository rt p wR wU wT
repo = do
ByteString
inv <- FilePath -> IO ByteString
BC.readFile FilePath
hashedInventoryPath
let linesInv :: [ByteString]
linesInv = Char -> ByteString -> [ByteString]
BC.split Char
'\n' ByteString
inv
case [ByteString]
linesInv of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(ByteString
pris_line:[ByteString]
_) ->
let size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BC.drop Int
9 ByteString
pris_line
in forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Int
size) forall a b. (a -> b) -> a -> b
$ do [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing hashed pristine..."
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Tree IO -> IO ()
replacePristine Repository rt p wR wU wT
repo
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p wR wU wT
repo
doRelink :: [DarcsFlag] -> IO ()
doRelink :: [DarcsFlag] -> IO ()
doRelink [DarcsFlag]
opts =
do let some_siblings :: [AbsolutePath]
some_siblings = forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption [AbsolutePath]
O.siblings [DarcsFlag]
opts
[FilePath]
defrepolist <- FilePath -> IO [FilePath]
getPreflist FilePath
"defaultrepo"
let siblings :: [FilePath]
siblings = forall a b. (a -> b) -> [a] -> [b]
map forall a. FilePathLike a => a -> FilePath
toFilePath [AbsolutePath]
some_siblings forall a. [a] -> [a] -> [a]
++ [FilePath]
defrepolist
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
siblings
then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No siblings -- no relinking done."
else do FilePath -> IO ()
debugMessage FilePath
"Relinking patches..."
Tree IO
patch_tree <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (Tree IO)
readPlainTree FilePath
patchesDirPath
let patches :: [FilePath]
patches = [ AnchoredPath -> FilePath
realPath AnchoredPath
p | (AnchoredPath
p, File Blob IO
_) <- forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
patch_tree ]
[FilePath] -> [FilePath] -> FilePath -> IO ()
maybeRelinkFiles [FilePath]
siblings [FilePath]
patches FilePath
patchesDirPath
FilePath -> IO ()
debugMessage FilePath
"Done relinking."
maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles :: [FilePath] -> [FilePath] -> FilePath -> IO ()
maybeRelinkFiles [FilePath]
src [FilePath]
dst FilePath
dir =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([FilePath] -> FilePath -> IO ()
maybeRelinkFile [FilePath]
src forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
dir forall a. [a] -> [a] -> [a]
++ FilePath
"/") forall a. [a] -> [a] -> [a]
++)) [FilePath]
dst
maybeRelinkFile :: [String] -> String -> IO ()
maybeRelinkFile :: [FilePath] -> FilePath -> IO ()
maybeRelinkFile [] FilePath
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeRelinkFile (FilePath
h:[FilePath]
t) FilePath
f =
do Bool
done <- FilePath -> FilePath -> IO Bool
maybeRelink (FilePath
h forall a. [a] -> [a] -> [a]
++ FilePath
"/" forall a. [a] -> [a] -> [a]
++ FilePath
f) FilePath
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done forall a b. (a -> b) -> a -> b
$
[FilePath] -> FilePath -> IO ()
maybeRelinkFile [FilePath]
t FilePath
f
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeUpgradeCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
_ = do
RepoFormat
rf <- FilePath -> IO RepoFormat
identifyRepoFormat FilePath
"."
FilePath -> IO ()
debugMessage FilePath
"Found our format"
if RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf
then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No action taken because this repository already is hashed."
else do [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Upgrading to hashed..."
forall a. RepoJob a -> IO a
withOldRepoLock forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO ()
actuallyUpgradeFormat
actuallyUpgradeFormat
:: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> IO ()
actuallyUpgradeFormat :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO ()
actuallyUpgradeFormat Repository rt p wR wU wT
repository = do
PatchSet rt p Origin wR
patches <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repository
let k :: FilePath
k = FilePath
"Hashing patch"
FilePath -> IO ()
beginTedious FilePath
k
FilePath -> Int -> IO ()
tediousSize FilePath
k (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
patches)
let patches' :: PatchSet rt p Origin wR
patches' = forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
FilePath -> PatchSet rt p wStart wX -> PatchSet rt p wStart wX
progressPatchSet FilePath
k PatchSet rt p Origin wR
patches
Cache
cache <- UseCache -> FilePath -> IO Cache
getCaches UseCache
YesUseCache FilePath
"."
let compressDefault :: Compression
compressDefault = PrimDarcsOption Compression
O.compress forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? []
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
Cache -> Compression -> PatchSet rt p Origin wX -> IO ()
writeTentativeInventory Cache
cache Compression
compressDefault PatchSet rt p Origin wR
patches'
FilePath -> IO ()
endTedious FilePath
k
let patchesToApply :: FL (PatchInfoAnd rt p) Origin wR
patchesToApply = forall (a :: * -> * -> *) wX wY.
FilePath -> FL a wX wY -> FL a wX wY
progressFL FilePath
"Applying patch" forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
patches'
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> HashedDir -> FilePath
hashedDir HashedDir
HashedPristineDir
Hash
_ <- Tree IO -> FilePath -> IO Hash
writeDarcsHashed forall (m :: * -> *). Tree m
emptyTree forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> HashedDir -> FilePath
hashedDir HashedDir
HashedPristineDir
forall p. FilePathLike p => p -> ByteString -> IO ()
writeBinFile FilePath
tentativePristinePath ByteString
""
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (forall (p :: * -> * -> *) wX wY.
(ApplyState p ~ Tree, Apply p) =>
ApplyDir -> p wX wY -> IO ()
applyToTentativePristineCwd ApplyDir
ApplyNormal) forall a b. (a -> b) -> a -> b
$
forall (a :: * -> * -> *) wX wY.
Int -> FL a wX wY -> FL (FL a) wX wY
bunchFL Int
100 FL (PatchInfoAnd rt p) Origin wR
patchesToApply
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> Compression -> IO ()
finalizeTentativeChanges Repository rt p wR wU wT
repository Compression
compressDefault
RepoFormat -> FilePath -> IO ()
writeRepoFormat (PatchFormat -> WithWorkingDir -> RepoFormat
createRepoFormat PatchFormat
PatchFormat1 WithWorkingDir
WithWorkingDir) FilePath
formatPath
FilePath -> IO ()
debugMessage FilePath
"Cleaning out old-fashioned repository files..."
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
oldInventoryPath
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
oldTentativeInventoryPath
FilePath -> IO ()
removeDirectoryRecursive FilePath
oldPristineDirPath
forall a. IO a -> IO a -> IO a
`catchall` FilePath -> IO ()
removeDirectoryRecursive FilePath
oldCurrentDirPath
forall p. FilePathLike p => p -> IO ()
rmGzsIn FilePath
patchesDirPath
forall p. FilePathLike p => p -> IO ()
rmGzsIn FilePath
inventoriesDirPath
Bool
hasCheckPoints <- FilePath -> IO Bool
doesDirectoryExist FilePath
oldCheckpointDirPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasCheckPoints forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
oldCheckpointDirPath
where
rmGzsIn :: p -> IO ()
rmGzsIn p
dir =
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory p
dir forall a b. (a -> b) -> a -> b
$ do
[FilePath]
gzs <- forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== FilePath
".gz") forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO [FilePath]
listDirectory FilePath
"."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
removeFile [FilePath]
gzs
optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed [DarcsFlag]
opts = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Migrating global cache to bucketed format."
Maybe FilePath
gCacheDir <- IO (Maybe FilePath)
globalCacheDir
case Maybe FilePath
gCacheDir of
Maybe FilePath
Nothing -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"New global cache doesn't exist."
Just FilePath
gCacheDir' -> do
let gCachePristineDir :: FilePath
gCachePristineDir = [FilePath] -> FilePath
joinPath [FilePath
gCacheDir', FilePath
pristineDir]
gCacheInventoriesDir :: FilePath
gCacheInventoriesDir = [FilePath] -> FilePath
joinPath [FilePath
gCacheDir', FilePath
inventoriesDir]
gCachePatchesDir :: FilePath
gCachePatchesDir = [FilePath] -> FilePath
joinPath [FilePath
gCacheDir', FilePath
patchesDir]
FilePath -> IO ()
debugMessage FilePath
"Making bucketed cache from new cache."
FilePath -> FilePath -> IO ()
toBucketed FilePath
gCachePristineDir FilePath
gCachePristineDir
FilePath -> FilePath -> IO ()
toBucketed FilePath
gCacheInventoriesDir FilePath
gCacheInventoriesDir
FilePath -> FilePath -> IO ()
toBucketed FilePath
gCachePatchesDir FilePath
gCachePatchesDir
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done making bucketed cache!"
where
toBucketed :: FilePath -> FilePath -> IO ()
toBucketed :: FilePath -> FilePath -> IO ()
toBucketed FilePath
src FilePath
dest = do
Bool
srcExist <- FilePath -> IO Bool
doesDirectoryExist FilePath
src
if Bool
srcExist
then do
FilePath -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ FilePath
"Making " forall a. [a] -> [a] -> [a]
++ FilePath
src forall a. [a] -> [a] -> [a]
++ FilePath
" bucketed in " forall a. [a] -> [a] -> [a]
++ FilePath
dest
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
subDirSet forall a b. (a -> b) -> a -> b
$ \FilePath
subDir ->
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath
subDir)
[FilePath]
fileNames <- FilePath -> IO [FilePath]
listDirectory FilePath
src
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
fileNames forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
Bool
exists <- FilePath -> IO Bool
doesDirectoryReallyExist (FilePath
src FilePath -> FilePath -> FilePath
</> FilePath
file)
if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Bool
exists
then FilePath -> FilePath -> FilePath -> IO ()
renameFile' FilePath
src FilePath
dest FilePath
file
else forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
FilePath -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show FilePath
src forall a. [a] -> [a] -> [a]
++ FilePath
" didn't exist, doing nothing."
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renameFile' :: FilePath -> FilePath -> FilePath -> IO ()
renameFile' :: FilePath -> FilePath -> FilePath -> IO ()
renameFile' FilePath
s FilePath
d FilePath
f = FilePath -> FilePath -> IO ()
renameFile (FilePath
s FilePath -> FilePath -> FilePath
</> FilePath
f) ([FilePath] -> FilePath
joinPath [FilePath
d, FilePath -> FilePath
bucketFolder FilePath
f, FilePath
f])
subDirSet :: [String]
subDirSet :: [FilePath]
subDirSet = forall a b. (a -> b) -> [a] -> [b]
map Int -> FilePath
toStrHex [Int
0..Int
255]
toStrHex :: Int -> String
toStrHex :: Int -> FilePath
toStrHex = forall r. PrintfType r => FilePath -> r
printf FilePath
"%02x"
optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache = DarcsCommand
common
{ commandName :: FilePath
commandName = FilePath
"cache"
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [FilePath]
commandExtraArgHelp = [ FilePath
"<DIRECTORY> ..." ]
, commandHelp :: Doc
commandHelp = Doc
optimizeHelpGlobalCache
, commandDescription :: FilePath
commandDescription = FilePath
"garbage collect global cache"
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeGlobalCacheCmd
, commandPrereq :: [DarcsFlag] -> IO (Either FilePath ())
commandPrereq = \[DarcsFlag]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
}
optimizeHelpGlobalCache :: Doc
optimizeHelpGlobalCache :: Doc
optimizeHelpGlobalCache = [FilePath] -> Doc
formatWords
[ FilePath
"This command deletes obsolete files within the global cache."
, FilePath
"It takes one or more directories as arguments, and recursively"
, FilePath
"searches all repositories within these directories. Then it deletes"
, FilePath
"all files in the global cache not belonging to these repositories."
, FilePath
"When no directory is given, it searches repositories in the user's"
, FilePath
"home directory."
]
Doc -> Doc -> Doc
$+$ [FilePath] -> Doc
formatWords
[ FilePath
"It also automatically migrates the global cache to the (default)"
, FilePath
"bucketed format."
]
optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [FilePath] -> IO ()
optimizeGlobalCacheCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [FilePath]
args = do
[DarcsFlag] -> IO ()
optimizeBucketed [DarcsFlag]
opts
FilePath
home <- IO FilePath
getHomeDirectory
let args' :: [FilePath]
args' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
args then [FilePath
home] else [FilePath]
args
[FilePath] -> [DarcsFlag] -> IO ()
cleanGlobalCache [FilePath]
args' [DarcsFlag]
opts
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done cleaning global cache!"
cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()
cleanGlobalCache :: [FilePath] -> [DarcsFlag] -> IO ()
cleanGlobalCache [FilePath]
dirs [DarcsFlag]
opts = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"\nLooking for repositories in the following directories:"
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
dirs
Maybe FilePath
gCacheDir' <- IO (Maybe FilePath)
globalCacheDir
[[FilePath]]
repoPaths' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [FilePath]
findAllReposInDir [FilePath]
dirs
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Finished listing repositories."
let repoPaths :: [FilePath]
repoPaths = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
repoPaths'
gCache :: FilePath
gCache = forall a. HasCallStack => Maybe a -> a
fromJust Maybe FilePath
gCacheDir'
gCacheInvDir :: FilePath
gCacheInvDir = FilePath
gCache FilePath -> FilePath -> FilePath
</> FilePath
inventoriesDir
gCachePatchesDir :: FilePath
gCachePatchesDir = FilePath
gCache FilePath -> FilePath -> FilePath
</> FilePath
patchesDir
gCachePristineDir :: FilePath
gCachePristineDir = FilePath
gCache FilePath -> FilePath -> FilePath
</> FilePath
pristineDir
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
gCacheInvDir
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
gCachePatchesDir
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
gCachePristineDir
forall {t :: * -> *} {a}.
Traversable t =>
(a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove FilePath -> IO [FilePath]
listInventoriesRepoDir FilePath
gCacheInvDir [FilePath]
repoPaths
forall {t :: * -> *} {a}.
Traversable t =>
(a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove (FilePath -> FilePath -> IO [FilePath]
listPatchesLocalBucketed FilePath
gCache forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
</> FilePath
darcsdir)) FilePath
gCachePatchesDir [FilePath]
repoPaths
forall {t :: * -> *} {a}.
Traversable t =>
(a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove FilePath -> IO [FilePath]
getPristine FilePath
gCachePristineDir [FilePath]
repoPaths
where
remove :: (a -> IO [FilePath]) -> FilePath -> t a -> IO ()
remove a -> IO [FilePath]
fGetFiles FilePath
cacheSubDir t a
repoPaths = do
t [FilePath]
s1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> IO [FilePath]
fGetFiles t a
repoPaths
[FilePath]
s2 <- FilePath -> IO [FilePath]
getRecursiveContents FilePath
cacheSubDir
FilePath -> [FilePath] -> [FilePath] -> IO ()
remove' FilePath
cacheSubDir [FilePath]
s2 (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [FilePath]
s1)
remove' :: String -> [String] -> [String] -> IO ()
remove' :: FilePath -> [FilePath] -> [FilePath] -> IO ()
remove' FilePath
dir [FilePath]
s1 [FilePath]
s2 =
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
. (\FilePath
hashedFile ->
FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
bucketFolder FilePath
hashedFile FilePath -> FilePath -> FilePath
</> FilePath
hashedFile))
([FilePath] -> [FilePath] -> [FilePath]
diffHashLists [FilePath]
s1 [FilePath]
s2)
getPristine :: String -> IO [String]
getPristine :: FilePath -> IO [FilePath]
getPristine FilePath
repoDir = do
ByteString
i <- FilePath -> IO ByteString
gzReadFilePS (FilePath
repoDir FilePath -> FilePath -> FilePath
</> FilePath
hashedInventoryPath)
FilePath -> [FilePath] -> IO [FilePath]
getHashedFiles (FilePath
repoDir FilePath -> FilePath -> FilePath
</> FilePath
pristineDirPath) [forall a. ValidHash a => a -> FilePath
getValidHash forall a b. (a -> b) -> a -> b
$ ByteString -> PristineHash
peekPristineHash ByteString
i]