--  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
        Bool
isd <- String -> IO Bool
doesDirectoryExist String
f
        if Bool
isd
          then String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
f (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                 [String]
fs <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
specialPatches) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
"."
                 (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
do_compress [String]
fs
          else String -> IO ByteString
gzReadFilePS String
f IO ByteString -> (ByteString -> 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 Compression
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
      PatchSet p Origin wR
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
      Repository 'RW p wU wR -> PatchSet p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
createOrUpdatePatchIndexDisk Repository 'RW p wU wR
repository PatchSet 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] -> [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
       [String]
defrepolist <- Pref -> IO [String]
getPreflist Pref
Defaultrepo
       let siblings :: [String]
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 [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
siblings
          then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No siblings -- no relinking done."
          else do String -> IO ()
debugMessage String
"Relinking patches..."
                  Tree IO
patch_tree <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Tree IO)
readPlainTree String
patchesDirPath
                  let patches :: [String]
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 ]
                  [String] -> [String] -> String -> IO ()
maybeRelinkFiles [String]
siblings [String]
patches String
patchesDirPath
                  String -> IO ()
debugMessage String
"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 Bool
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
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           [String] -> String -> IO ()
maybeRelinkFile [String]
t String
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
  RepoFormat
rf <- String -> IO RepoFormat
identifyRepoFormat String
"."
  String -> IO ()
debugMessage String
"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..."
             RepoJob 'RW () -> IO ()
forall a. RepoJob 'RW a -> IO a
withOldRepoLock (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
$ [DarcsFlag] -> Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag] -> Repository 'RW p wU wR -> IO ()
actuallyUpgradeFormat [DarcsFlag]
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
  PatchSet p Origin wR
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
k = String
"Hashing patch"
  String -> IO ()
beginTedious String
k
  String -> Int -> IO ()
tediousSize String
k (RL (PatchInfoAnd p) Origin wR -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL (RL (PatchInfoAnd p) Origin wR -> Int)
-> RL (PatchInfoAnd p) Origin wR -> Int
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL PatchSet p Origin wR
patches)
  let patches' :: PatchSet p Origin wR
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
  Repository 'RW p wU wR -> PatchSet p Origin wR -> IO ()
forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR -> PatchSet p Origin wX -> IO ()
writeTentativeInventory Repository 'RW p wU wR
_repository PatchSet p Origin wR
patches'
  String -> IO ()
endTedious String
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 :: FL (PatchInfoAnd p) Origin wR
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'
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
pristineDirPath
  -- We ignore the returned root hash, we don't use it.
  PristineHash
_ <- Tree IO -> Cache -> IO PristineHash
writeDarcsHashed Tree IO
forall (m :: * -> *). Tree m
emptyTree (Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
_repository)
  String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeBinFile String
tentativePristinePath ByteString
""
  -- we must coerce here because we just emptied out pristine
  Repository 'RW p wU Origin
-> Invertible (FL (PatchInfoAnd p)) Origin wR -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wY -> IO ()
applyToTentativePristine (Repository 'RW p wU wR -> Repository 'RW p wU Origin
forall (rt :: AccessType) (p :: * -> * -> *) wU wR wR'.
Repository rt p wU wR -> Repository rt p wU wR'
unsafeCoerceR Repository 'RW p wU wR
_repository) (FL (PatchInfoAnd p) Origin wR
-> Invertible (FL (PatchInfoAnd p)) Origin wR
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
mkInvertible FL (PatchInfoAnd p) Origin wR
patchesToApply)
  -- now make it official
  Repository 'RW p wU wR -> IO ()
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO ()
finalizeTentativeChanges Repository 'RW p wU wR
_repository
  RepoFormat -> String -> IO ()
unsafeWriteRepoFormat (PatchFormat -> WithWorkingDir -> RepoFormat
createRepoFormat PatchFormat
PatchFormat1 WithWorkingDir
WithWorkingDir) String
formatPath
  -- clean out old-fashioned junk
  String -> IO ()
debugMessage String
"Cleaning out old-fashioned repository files..."
  String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
oldInventoryPath
  String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
oldTentativeInventoryPath
  String -> IO ()
removeDirectoryRecursive String
oldPristineDirPath
    IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` String -> IO ()
removeDirectoryRecursive String
oldCurrentDirPath
  String -> IO ()
rmGzsIn String
patchesDirPath
  String -> IO ()
rmGzsIn String
inventoriesDirPath
  Bool
hasCheckPoints <- String -> IO Bool
doesDirectoryExist String
oldCheckpointDirPath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasCheckPoints (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
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
      [String]
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
"."
      (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
removeFile [String]
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 String
gCacheDir <- IO (Maybe String)
globalCacheDir

  case Maybe String
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
      Bool
srcExist <- String -> IO Bool
doesDirectoryExist String
src
      if Bool
srcExist
        then  do
                String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Making " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bucketed in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest
                [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
subDirSet ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
subDir ->
                  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
dest String -> String -> String
</> String
subDir)
                [String]
fileNames <- String -> IO [String]
listDirectory String
src
                [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
fileNames ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
file -> do
                  Bool
exists <- String -> IO Bool
doesDirectoryReallyExist (String
src String -> String -> String
</> String
file)
                  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
exists
                    then String -> String -> String -> IO ()
renameFile' String
src String
dest String
file
                    else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" didn't exist, doing nothing."
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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!"