--  Copyright (C) 2003-2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module Darcs.UI.Commands.Optimize ( optimize ) where

import Darcs.Prelude

import Control.Monad ( when, unless, forM_ )
import System.Directory
    ( listDirectory
    , doesDirectoryExist
    , renameFile
    , createDirectoryIfMissing
    , removeFile
    , removeDirectoryRecursive
    , withCurrentDirectory
    )
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults
                         , amInHashedRepository, amInRepository, putInfo
                         , normalCommand, withStdOpts )
import Darcs.UI.Completion ( noArgs )
import Darcs.Repository.Prefs ( Pref(Defaultrepo), getPreflist, globalCacheDir )
import Darcs.Repository
    ( Repository
    , AccessType(RW)
    , repoLocation
    , withRepoLock
    , RepoJob(..)
    , readPatches
    , reorderInventory
    , cleanRepository
    )
import Darcs.Repository.Job ( withOldRepoLock )
import Darcs.Repository.Traverse ( specialPatches )
import Darcs.Repository.Paths
    ( formatPath
    , inventoriesDir
    , inventoriesDirPath
    , oldCheckpointDirPath
    , oldCurrentDirPath
    , oldInventoryPath
    , oldPristineDirPath
    , oldTentativeInventoryPath
    , patchesDir
    , patchesDirPath
    , pristineDir
    , pristineDirPath
    , tentativePristinePath
    )
import Darcs.Repository.Packs ( createPacks )
import Darcs.Patch.Witnesses.Ordered ( lengthRL )
import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Invertible ( mkInvertible )
import Darcs.Patch.Set
    ( patchSet2RL
    , patchSet2FL
    , progressPatchSet
    )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Printer ( Doc, formatWords, wrapText, ($+$) )
import Darcs.Util.Lock
    ( maybeRelink
    , gzWriteAtomicFilePS
    , writeAtomicFilePS
    , removeFileMayNotExist
    , writeBinFile
    )
import Darcs.Util.File ( doesDirectoryReallyExist )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Progress
    ( beginTedious
    , endTedious
    , tediousSize
    , debugMessage
    )

import System.FilePath.Posix
    ( takeExtension
    , (</>)
    , joinPath
    )
import Text.Printf ( printf )
import Darcs.UI.Flags
    (  DarcsFlag, useCache, umask )
import Darcs.UI.Options ( DarcsOption, (?), (^) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags
    ( PatchFormat(PatchFormat1)
    , UMask(..)
    , WithWorkingDir(WithWorkingDir)
    )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Util.Cache ( allHashedDirs, bucketFolder, cleanCaches, mkDirCache )
import Darcs.Repository.Format
    ( identifyRepoFormat
    , createRepoFormat
    , unsafeWriteRepoFormat
    , formatHas
    , RepoProperty ( HashedInventory )
    )
import Darcs.Repository.PatchIndex
import Darcs.Repository.Hashed
    ( writeTentativeInventory
    , finalizeTentativeChanges
    )
import Darcs.Repository.InternalTypes ( repoCache, unsafeCoerceR )
import Darcs.Repository.Pristine
    ( applyToTentativePristine
    )

import Darcs.Util.Tree
    ( Tree
    , TreeItem(..)
    , list
    , expand
    , emptyTree
    )
import Darcs.Util.Path ( AbsolutePath, realPath, toFilePath )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Tree.Hashed ( writeDarcsHashed )

optimizeDescription :: String
optimizeDescription :: String
optimizeDescription = String
"Optimize the repository."

optimizeHelp :: Doc
optimizeHelp :: Doc
optimizeHelp = [String] -> Doc
formatWords
  [ String
"The `darcs optimize` command modifies internal data structures of"
  , String
"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 :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"optimize"
    , commandHelp :: Doc
commandHelp = Doc
optimizeHelp
    , commandDescription :: String
commandDescription = String
optimizeDescription
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
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
optimizeUpgrade,
                              DarcsCommand -> CommandControl
normalCommand DarcsCommand
optimizeGlobalCache
                           ]
    }

commonBasicOpts :: DarcsOption a (Maybe String -> a)
commonBasicOpts :: forall a. DarcsOption a (Maybe String -> a)
commonBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
forall a. DarcsOption a (Maybe String -> a)
O.repoDir

commonAdvancedOpts :: DarcsOption a (UMask -> a)
commonAdvancedOpts :: forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
O.umask

common :: DarcsCommand
common :: DarcsCommand
common = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq =  [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandName :: String
commandName = String
forall a. HasCallStack => a
undefined
    , commandHelp :: Doc
commandHelp = Doc
forall a. HasCallStack => a
undefined
    , commandDescription :: String
commandDescription = String
forall a. HasCallStack => a
undefined
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand =  (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
forall a. HasCallStack => a
undefined
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
commonOpts
    }
  where
    commonOpts :: CommandOptions
commonOpts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a. DarcsOption a (Maybe String -> a)
commonBasicOpts DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UMask
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts


optimizeClean :: DarcsCommand
optimizeClean :: DarcsCommand
optimizeClean = DarcsCommand
common
    { commandName = "clean"
    , commandDescription = "Garbage collect pristine, inventories and patches"
    , commandHelp = optimizeHelpClean
    , commandCommand = optimizeCleanCmd
    }

optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCleanCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
      Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p wU wR
repository
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done cleaning repository!"

optimizeUpgrade :: DarcsCommand
optimizeUpgrade :: DarcsCommand
optimizeUpgrade = DarcsCommand
common
    { commandName = "upgrade"
    , commandHelp = wrapText 80
        "Convert old-fashioned repositories to the current default hashed format."
    , commandDescription = "Upgrade repository to latest compatible format"
    , commandPrereq = amInRepository
    , commandCommand = optimizeUpgradeCmd
    , commandOptions =
        withStdOpts commonBasicOpts commonAdvancedOpts
    }

optimizeHttp :: DarcsCommand
optimizeHttp :: DarcsCommand
optimizeHttp = DarcsCommand
common
    { commandName = "http"
    , commandHelp = optimizeHelpHttp
    , commandDescription = "Optimize repository for getting over network"
    , commandCommand = optimizeHttpCmd
    }

optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeHttpCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
      Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p wU wR
repository
      Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO ()
createPacks Repository 'RW p wU wR
repository
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done creating packs!"

optimizeCompress :: DarcsCommand
optimizeCompress :: DarcsCommand
optimizeCompress = DarcsCommand
common
    { commandName = "compress"
    , commandHelp = optimizeHelpCompression
    , commandDescription = "Compress hashed files"
    , commandCommand = optimizeCompressCmd
    }

optimizeUncompress :: DarcsCommand
optimizeUncompress :: DarcsCommand
optimizeUncompress = DarcsCommand
common
    { commandName = "uncompress"
    , commandHelp = optimizeHelpCompression
    , commandDescription = "Uncompress hashed files (for debugging)"
    , commandCommand = optimizeUncompressCmd
    }

optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeCompressCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
      Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p 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] -> [String] -> IO ()
optimizeUncompressCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
      Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p wU wR
repository
      Compression -> [DarcsFlag] -> IO ()
optimizeCompression Compression
O.NoCompression [DarcsFlag]
opts
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done uncompressing hashed files."

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..."
    String -> IO ()
do_compress String
patchesDirPath
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing (un)compression of inventories..."
    String -> IO ()
do_compress String
inventoriesDirPath
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Optimizing (un)compression of pristine..."
    String -> IO ()
do_compress String
pristineDirPath
    where
      do_compress :: String -> IO ()
do_compress String
f = do
        isd <- String -> IO Bool
doesDirectoryExist String
f
        if isd
          then withCurrentDirectory f $ do
                 fs <- filter (`notElem` specialPatches) <$> listDirectory "."
                 mapM_ do_compress fs
          else gzReadFilePS f >>=
               case compression of
                 Compression
O.GzipCompression -> String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
gzWriteAtomicFilePS String
f
                 Compression
O.NoCompression -> String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS String
f

optimizeEnablePatchIndex :: DarcsCommand
optimizeEnablePatchIndex :: DarcsCommand
optimizeEnablePatchIndex = DarcsCommand
common
    { commandName = "enable-patch-index"
    , commandHelp = formatWords
        [ "Build the patch index, an internal data structure that accelerates"
        , "commands that need to know what patches touch a given file. Such as"
        , "annotate and log."
        ]
    , commandDescription = "Enable patch index"
    , commandCommand = optimizeEnablePatchIndexCmd
    }

optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex :: DarcsCommand
optimizeDisablePatchIndex = DarcsCommand
common
    { commandName = "disable-patch-index"
    , commandHelp = wrapText 80
        "Delete and stop maintaining the patch index from the repository."
    , commandDescription = "Disable patch index"
    , commandCommand = optimizeDisablePatchIndexCmd
    }

optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeEnablePatchIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
      ps <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
repository
      createOrUpdatePatchIndexDisk repository ps
      putInfo opts "Done enabling patch index!"

optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeDisablePatchIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repo -> do
      String -> IO ()
deletePatchIndex (Repository 'RW p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RW p wU wR
repo)
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done disabling patch index!"

optimizeReorder :: DarcsCommand
optimizeReorder :: DarcsCommand
optimizeReorder = DarcsCommand
common
    { commandName = "reorder"
    , commandHelp = formatWords
        [ "This command moves recent patches (those not included in"
        , "the latest tag) to the \"front\", reducing the amount that a typical"
        , "remote command needs to download. It should also reduce the CPU time"
        , "needed for some operations. This is the behavior with --shallow"
        , "which is the default."
        ]
        $+$ formatWords
        [ "With the --deep option it tries to optimize all tags in the whole"
        , "repository. This breaks the history of patches into smaller"
        , "bunches, which can further improve efficiency, but requires all"
        , "patches to be present. It is therefore less suitable for lazy clones."
        ]
    , commandDescription = "Reorder the patches in the repository"
    , commandCommand = optimizeReorderCmd
    , commandOptions =
        withStdOpts basicOpts commonAdvancedOpts
    }
  where
    basicOpts :: OptSpec
  DarcsOptDescr DarcsFlag a (Maybe String -> OptimizeDeep -> a)
basicOpts = DarcsOption (OptimizeDeep -> a) (Maybe String -> OptimizeDeep -> a)
forall a. DarcsOption a (Maybe String -> a)
commonBasicOpts DarcsOption (OptimizeDeep -> a) (Maybe String -> OptimizeDeep -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (OptimizeDeep -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a (Maybe String -> OptimizeDeep -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (OptimizeDeep -> a)
PrimDarcsOption OptimizeDeep
O.optimizeDeep

optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeReorderCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
      Repository 'RW p wU wR -> OptimizeDeep -> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> OptimizeDeep -> IO ()
reorderInventory Repository 'RW p wU wR
repository (PrimOptSpec DarcsOptDescr DarcsFlag a OptimizeDeep
PrimDarcsOption OptimizeDeep
O.optimizeDeep PrimDarcsOption OptimizeDeep -> [DarcsFlag] -> OptimizeDeep
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 = "relink"
    , commandHelp = optimizeHelpRelink 
    , commandDescription = "Replace copies of hashed files with hard links"
    , commandCommand = optimizeRelinkCmd
    , commandOptions = optimizeRelinkOpts
    }
  where
    optimizeRelinkBasicOpts :: OptSpec
  DarcsOptDescr DarcsFlag a (Maybe String -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts = DarcsOption
  ([AbsolutePath] -> a) (Maybe String -> [AbsolutePath] -> a)
forall a. DarcsOption a (Maybe String -> a)
commonBasicOpts DarcsOption
  ([AbsolutePath] -> a) (Maybe String -> [AbsolutePath] -> a)
-> OptSpec DarcsOptDescr DarcsFlag a ([AbsolutePath] -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a (Maybe String -> [AbsolutePath] -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a ([AbsolutePath] -> a)
PrimDarcsOption [AbsolutePath]
O.siblings
    optimizeRelinkOpts :: CommandOptions
optimizeRelinkOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr DarcsFlag a (Maybe String -> [AbsolutePath] -> a)
optimizeRelinkBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> [AbsolutePath]
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UMask
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a. DarcsOption a (UMask -> a)
commonAdvancedOpts

optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeRelinkCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. DarcsOption a (UMask -> a)
umask (forall a. DarcsOption a (UMask -> a)) -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repository -> do
      Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p wU wR
repository
      [DarcsFlag] -> IO ()
doRelink [DarcsFlag]
opts
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done relinking!"

optimizeHelpHttp :: Doc
optimizeHelpHttp :: Doc
optimizeHelpHttp = [String] -> Doc
formatWords
  [ String
"Using this option creates 'repository packs' that can dramatically"
  , String
"speed up performance when a user does a `darcs clone` of the repository"
  , String
"over HTTP. To make use of packs, the clients must have a darcs of at"
  , String
"least version 2.10."
  ]

optimizeHelpClean :: Doc
optimizeHelpClean :: Doc
optimizeHelpClean = [String] -> Doc
formatWords
  [ String
"Darcs normally does not delete hashed files that are no longer"
  , String
"referenced by the current repository state. This command can be"
  , String
"use to get rid of these files to save some disk space."
  ]

optimizeHelpCompression :: Doc
optimizeHelpCompression :: Doc
optimizeHelpCompression =
  [String] -> Doc
formatWords
  [ String
"Patches, inventories, and pristine files are compressed with zlib"
  , String
"(RFC 1951) to reduce storage (and download) size."
  , String
"Older darcs versions allowed to store them"
  , String
"uncompressed, and darcs is still able to"
  , String
"read those files if they are not compressed."
  ]
  Doc -> Doc -> Doc
$+$ [String] -> Doc
formatWords
  [ String
"The `darcs optimize uncompress` and `darcs optimize compress`"
  , String
"commands can be used to ensure existing patches in the current"
  , String
"repository are respectively uncompressed or compressed."
  ]

optimizeHelpRelink :: Doc
optimizeHelpRelink :: Doc
optimizeHelpRelink = 
  [String] -> Doc
formatWords
  [ String
"The `darcs optimize relink` command hard-links patches that the"
  , String
"current repository has in common with its peers.  Peers are those"
  , String
"repositories listed in `_darcs/prefs/sources`, or defined with the"
  , String
"`--sibling` option (which can be used multiple times)."
  ]
  Doc -> Doc -> Doc
$+$ [String] -> Doc
formatWords
  [ String
"Darcs uses hard-links automatically, so this command is rarely needed."
  , String
"It is most useful if you used `cp -r` instead of `darcs clone` to copy a"
  , String
"repository, or if you pulled the same patch from a remote repository"
  , String
"into multiple local repositories."
  ]

doRelink :: [DarcsFlag] -> IO ()
doRelink :: [DarcsFlag] -> IO ()
doRelink [DarcsFlag]
opts =
    do let some_siblings :: [AbsolutePath]
some_siblings = PrimOptSpec DarcsOptDescr DarcsFlag a [AbsolutePath]
PrimDarcsOption [AbsolutePath]
O.siblings PrimDarcsOption [AbsolutePath] -> [DarcsFlag] -> [AbsolutePath]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
       defrepolist <- Pref -> IO [String]
getPreflist Pref
Defaultrepo
       let siblings = (AbsolutePath -> String) -> [AbsolutePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath [AbsolutePath]
some_siblings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
defrepolist
       if null siblings
          then putInfo opts "No siblings -- no relinking done."
          else do debugMessage "Relinking patches..."
                  patch_tree <- expand =<< readPlainTree patchesDirPath
                  let patches = [ AnchoredPath -> String
realPath AnchoredPath
p | (AnchoredPath
p, File Blob IO
_) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
patch_tree ]
                  maybeRelinkFiles siblings patches patchesDirPath
                  debugMessage "Done relinking."

maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles :: [String] -> [String] -> String -> IO ()
maybeRelinkFiles [String]
src [String]
dst String
dir =
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([String] -> String -> IO ()
maybeRelinkFile [String]
src (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [String]
dst

maybeRelinkFile :: [String] -> String -> IO ()
maybeRelinkFile :: [String] -> String -> IO ()
maybeRelinkFile [] String
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeRelinkFile (String
h:[String]
t) String
f =
    do done <- String -> String -> IO Bool
maybeRelink (String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f) String
f
       unless done $
           maybeRelinkFile t f

-- Only 'optimize' commands that works on old-fashionned repositories
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeUpgradeCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = do
  rf <- String -> IO RepoFormat
identifyRepoFormat String
"."
  debugMessage "Found our format"
  if formatHas HashedInventory rf
     then putInfo opts "No action taken because this repository already is hashed."
     else do putInfo opts "Upgrading to hashed..."
             withOldRepoLock $ RepoJob $ actuallyUpgradeFormat opts

actuallyUpgradeFormat
  :: (RepoPatch p, ApplyState p ~ Tree)
  => [DarcsFlag] -> Repository 'RW p wU wR -> IO ()
actuallyUpgradeFormat :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag] -> Repository 'RW p wU wR -> IO ()
actuallyUpgradeFormat [DarcsFlag]
_opts Repository 'RW p wU wR
_repository = do
  -- convert patches/inventory
  patches <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
_repository
  let k = String
"Hashing patch"
  beginTedious k
  tediousSize k (lengthRL $ patchSet2RL patches)
  let patches' = String -> PatchSet p Origin wR -> PatchSet p Origin wR
forall (p :: * -> * -> *) wStart wX.
String -> PatchSet p wStart wX -> PatchSet p wStart wX
progressPatchSet String
k PatchSet p Origin wR
patches
  writeTentativeInventory _repository patches'
  endTedious k
  -- convert pristine by applying patches
  -- the faster alternative would be to copy pristine, but the apply method
  -- is more reliable
  -- TODO we should do both and then comapre them
  let patchesToApply = String
-> FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Applying patch" (FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR)
-> FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin wR
patches'
  createDirectoryIfMissing False pristineDirPath
  -- We ignore the returned root hash, we don't use it.
  _ <- writeDarcsHashed emptyTree (repoCache _repository)
  writeBinFile tentativePristinePath ""
  -- we must coerce here because we just emptied out pristine
  applyToTentativePristine (unsafeCoerceR _repository) (mkInvertible patchesToApply)
  -- now make it official
  finalizeTentativeChanges _repository
  unsafeWriteRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) formatPath
  -- clean out old-fashioned junk
  debugMessage "Cleaning out old-fashioned repository files..."
  removeFileMayNotExist oldInventoryPath
  removeFileMayNotExist oldTentativeInventoryPath
  removeDirectoryRecursive oldPristineDirPath
    `catchall` removeDirectoryRecursive oldCurrentDirPath
  rmGzsIn patchesDirPath
  rmGzsIn inventoriesDirPath
  hasCheckPoints <- doesDirectoryExist oldCheckpointDirPath
  when hasCheckPoints $ removeDirectoryRecursive oldCheckpointDirPath
 where
  rmGzsIn :: String -> IO ()
rmGzsIn String
dir =
    String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
dir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      gzs <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gz") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) ([String] -> [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
listDirectory String
"."
      mapM_ removeFile gzs

optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed :: [DarcsFlag] -> IO ()
optimizeBucketed [DarcsFlag]
opts = do
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Migrating global cache to bucketed format."
  gCacheDir <- IO (Maybe String)
globalCacheDir

  case gCacheDir of
    Maybe String
Nothing -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"New global cache doesn't exist."
    Just String
gCacheDir' -> do
      let gCachePristineDir :: String
gCachePristineDir = [String] -> String
joinPath [String
gCacheDir', String
pristineDir]
          gCacheInventoriesDir :: String
gCacheInventoriesDir = [String] -> String
joinPath [String
gCacheDir', String
inventoriesDir]
          gCachePatchesDir :: String
gCachePatchesDir = [String] -> String
joinPath [String
gCacheDir', String
patchesDir]
      String -> IO ()
debugMessage String
"Making bucketed cache from new cache."
      String -> String -> IO ()
toBucketed String
gCachePristineDir String
gCachePristineDir
      String -> String -> IO ()
toBucketed String
gCacheInventoriesDir String
gCacheInventoriesDir
      String -> String -> IO ()
toBucketed String
gCachePatchesDir String
gCachePatchesDir
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done making bucketed cache!"
  where
    toBucketed :: FilePath -> FilePath -> IO ()
    toBucketed :: String -> String -> IO ()
toBucketed String
src String
dest = do
      srcExist <- String -> IO Bool
doesDirectoryExist String
src
      if srcExist
        then  do
                debugMessage $ "Making " ++ src ++ " bucketed in " ++ dest
                forM_ subDirSet $ \String
subDir ->
                  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
dest String -> String -> String
</> String
subDir)
                fileNames <- listDirectory src
                forM_ fileNames $ \String
file -> do
                  exists <- String -> IO Bool
doesDirectoryReallyExist (String
src String -> String -> String
</> String
file)
                  if not $ exists
                    then renameFile' src dest file
                    else return ()
        else do
          debugMessage $ show src ++ " didn't exist, doing nothing."
          return ()

    renameFile' :: FilePath -> FilePath -> FilePath -> IO ()
    renameFile' :: String -> String -> String -> IO ()
renameFile' String
s String
d String
f = String -> String -> IO ()
renameFile (String
s String -> String -> String
</> String
f) ([String] -> String
joinPath [String
d, String -> String
bucketFolder String
f, String
f])

    subDirSet :: [String]
    subDirSet :: [String]
subDirSet = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
toStrHex [Int
0..Int
255]

    toStrHex :: Int -> String
    toStrHex :: Int -> String
toStrHex = String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02x"


optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache :: DarcsCommand
optimizeGlobalCache = DarcsCommand
common
    { commandName = "cache"
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandHelp = optimizeHelpGlobalCache
    , commandDescription = "Garbage collect global cache"
    , commandCommand = optimizeGlobalCacheCmd
    , commandPrereq = \[DarcsFlag]
_ -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()
    }

optimizeHelpGlobalCache :: Doc
optimizeHelpGlobalCache :: Doc
optimizeHelpGlobalCache = [String] -> Doc
formatWords
  [ String
"This command deletes obsolete files within the global cache."
  ]
  Doc -> Doc -> Doc
$+$ [String] -> Doc
formatWords
  [ String
"It also automatically migrates the global cache to the (default)"
  , String
"bucketed format."
  ]

optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
optimizeGlobalCacheCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = do
  [DarcsFlag] -> IO ()
optimizeBucketed [DarcsFlag]
opts
  IO (Maybe String)
globalCacheDir IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
dir -> (HashedDir -> IO ()) -> [HashedDir] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Cache -> HashedDir -> IO ()
cleanCaches (String -> Cache
mkDirCache String
dir)) [HashedDir]
allHashedDirs
    Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Done cleaning global cache!"