% 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. \darcsCommand{optimize} \begin{code} {-# OPTIONS_GHC -cpp #-} {-# LANGUAGE CPP #-} module Darcs.Commands.Optimize ( optimize ) where import Control.Monad ( when, unless ) import Data.Maybe ( isJust ) import Text.Regex ( mkRegex, matchRegex ) import System.Directory ( getDirectoryContents, doesDirectoryExist ) import Darcs.Hopefully ( hopefully, info ) import Darcs.Commands ( DarcsCommand(..), nodefaults ) import Darcs.Arguments ( DarcsFlag( Compress, UnCompress, NoCompress, Reorder, TagName, CheckPoint, Relink, RelinkPristine ), tagname, checkpoint, reorder_patches, uncompress_nocompress, relink, relink_pristine, sibling, flagsToSiblings, working_repo_dir, umask_option, ) import Darcs.Repository.Prefs ( get_preflist ) import Darcs.Repository ( Repository, PatchSet, withRepoLock, ($-), withGutsOf, read_repo, optimizeInventory, slurp_recorded, tentativelyReplacePatches, cleanRepository, amInRepository, finalizeRepositoryChanges ) import Darcs.Repository.Checkpoint ( write_checkpoint ) import Darcs.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL ) import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly ) import Darcs.Patch ( RepoPatch ) import ByteStringUtils ( gzReadFilePS ) import Darcs.Patch.Depends ( deep_optimize_patchset, slightly_optimize_patchset, get_patches_beyond_tag, get_patches_in_tag, ) import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS ) import Darcs.RepoPath ( toFilePath ) import Darcs.Utils ( withCurrentDirectory ) import Progress ( debugMessage ) import Printer ( putDocLn, text, ($$) ) import Darcs.SlurpDirectory ( slurp, list_slurpy_files ) import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory ) import Darcs.Sealed ( FlippedSeal(..), unsafeUnseal ) import Darcs.Global ( darcsdir ) #include "impossible.h" optimize_description :: String optimize_description = "Optimize the repository." optimize_help :: String optimize_help = "The `darcs optimize' command modifies the current repository in an\n" ++ "attempt to reduce its resource requirements. By default a single\n" ++ "fast, safe optimization is performed; additional optimization\n" ++ "techniques can be enabled by passing options to `darcs optimize'.\n" ++ "\n" ++ optimize_help_inventory ++ -- "\n" ++ optimize_help_reorder ++ "\n" ++ optimize_help_relink ++ -- checkpoints and uncompression are least useful, so they are last. "\n" ++ optimize_help_compression ++ "\n" ++ optimize_help_checkpoint ++ "\n" ++ "There is one more optimization which CAN NOT be performed by this\n" ++ "command. Every time your record a patch, a new inventory file is\n" ++ "written to _darcs/inventories/, and old inventories are never reaped.\n" ++ "\n" ++ "If _darcs/inventories/ is consuming a relatively large amount of\n" ++ "space, you can safely reclaim it by using `darcs get' to make a\n" ++ "complete copy of the repo. When doing so, don't forget to copy over\n" ++ "any unsaved changes you have made to the working tree or to\n" ++ "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n" optimize :: DarcsCommand optimize = DarcsCommand {command_name = "optimize", command_help = optimize_help, command_description = optimize_description, command_extra_args = 0, command_extra_arg_help = [], command_command = optimize_cmd, command_prereq = amInRepository, command_get_arg_possibilities = return [], command_argdefaults = nodefaults, command_advanced_options = [uncompress_nocompress, umask_option], command_basic_options = [checkpoint, tagname, working_repo_dir, reorder_patches, sibling, relink, relink_pristine]} optimize_cmd :: [DarcsFlag] -> [String] -> IO () optimize_cmd origopts _ = withRepoLock opts $- \repository -> do cleanRepository repository do_reorder opts repository do_optimize_inventory repository when (CheckPoint `elem` opts) $ do_checkpoint opts repository when (Compress `elem` opts || UnCompress `elem` opts) $ optimize_compression opts when (Relink `elem` opts || (RelinkPristine `elem` opts)) $ do_relink opts repository putStrLn "Done optimizing!" where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts is_tag :: PatchInfo -> Bool is_tag pinfo = take 4 (just_name pinfo) == "TAG " optimize_help_inventory :: String optimize_help_inventory = "The default optimization moves recent patches (those not included in\n" ++ "the latest tag) to the `front', reducing the amount that a typical\n" ++ "remote command needs to download. It should also reduce the CPU time\n" ++ "needed for some operations.\n" do_optimize_inventory :: RepoPatch p => Repository p -> IO () do_optimize_inventory repository = do debugMessage "Writing out a nice copy of the inventory." optimizeInventory repository debugMessage "Done writing out a nice copy of the inventory." optimize_help_checkpoint :: String optimize_help_checkpoint = "If the repository is in `old-fashioned-inventory' format, the `darcs\n" ++ "optimize --checkpoint' command creates a checkpoint of the latest tag.\n" ++ "This checkpoint is used by `darcs get --partial' to create partial\n" ++ "repositories. With the `--tag' option, checkpoints for older tags can\n" ++ "be created. In newer repository formats, this feature has been\n" ++ "replaced by `darcs get --lazy', which does not require checkpoints.\n" do_checkpoint :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () do_checkpoint opts repository = do mpi <- get_tag opts repository case mpi of Nothing -> return () Just pinfo -> do putDocLn $ text "Checkpointing tag:" $$ human_friendly pinfo write_checkpoint repository pinfo get_tag :: RepoPatch p => [DarcsFlag] -> Repository p -> IO (Maybe PatchInfo) get_tag [] r = do ps <- read_repo r case filter is_tag $ lasts $ mapRL (mapRL info) ps of [] -> do putStrLn "There is no tag to checkpoint!" return Nothing (pinfo:_) -> return $ Just pinfo get_tag (TagName t:_) r = do ps <- read_repo r case filter (match_tag t) $ lasts $ mapRL (mapRL info) ps of (pinfo:_) -> return $ Just pinfo _ -> case filter (match_tag t) $ lasts $ mapRL (mapRL info) $ deep_optimize_patchset ps of (pinfo:_) -> return $ Just pinfo _ -> do putStr "Cannot checkpoint any tag " putStr $ "matching '"++t++"'\n" return Nothing get_tag (_:fs) r = get_tag fs r lasts :: [[a]] -> [a] lasts [] = [] lasts (x@(_:_):ls) = last x : lasts ls lasts ([]:ls) = lasts ls mymatch :: String -> PatchInfo -> Bool mymatch r = match_name $ matchRegex (mkRegex r) match_name :: (String -> Maybe a) -> PatchInfo -> Bool match_name ch pinfo = isJust $ ch (just_name pinfo) match_tag :: String -> PatchInfo -> Bool match_tag ('^':n) = mymatch $ "^TAG "++n match_tag n = mymatch $ "^TAG .*"++n optimize_help_compression :: String optimize_help_compression = "By default patches are compressed with zlib (RFC 1951) to reduce\n" ++ "storage (and download) size. In exceptional circumstances, it may be\n" ++ "preferable to avoid compression. In this case the `--dont-compress'\n" ++ "option can be used (e.g. with `darcs record') to avoid compression.\n" ++ "\n" ++ "The `darcs optimize --uncompress' and `darcs optimize --compress'\n" ++ "commands can be used to ensure existing patches in the current\n" ++ "repository are respectively uncompressed or compressed. Note that\n" ++ "repositories in the legacy `old-fashioned-inventory' format have a .gz\n" ++ "extension on patch files even when uncompressed.\n" optimize_compression :: [DarcsFlag] -> IO () optimize_compression opts = do putStrLn "Optimizing (un)compression of patches..." do_compress (darcsdir++"/patches") putStrLn "Optimizing (un)compression of inventories..." do_compress (darcsdir++"/inventories") where do_compress f = do isd <- doesDirectoryExist f if isd then withCurrentDirectory f $ do fs <- filter notdot `fmap` getDirectoryContents "." mapM_ do_compress fs else if Compress `elem` opts then gzReadFilePS f >>= gzWriteAtomicFilePS f else gzReadFilePS f >>= writeAtomicFilePS f notdot ('.':_) = False notdot _ = True optimize_help_relink :: String optimize_help_relink = "The `darcs optimize --relink' command hard-links patches that the\n" ++ "current repository has in common with its peers. Peers are those\n" ++ "repositories listed in _darcs/prefs/sources, or defined with the\n" ++ "`--sibling' option (which can be used multiple times).\n" ++ "\n" ++ "Darcs uses hard-links automatically, so this command is rarely needed.\n" ++ "It is most useful if you used `cp -r' instead of `darcs get' to copy a\n" ++ "repository, or if you pulled the same patch from a remote repository\n" ++ "into multiple local repositories.\n" ++ "\n" ++ "A `darcs optimize --relink-pristine' command is also available, but\n" ++ "generally SHOULD NOT be used. It results in a relatively small space\n" ++ "saving at the cost of making many Darcs commands MUCH slower.\n" do_relink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () do_relink opts repository = do some_siblings <- return (flagsToSiblings opts) defrepolist <- get_preflist "defaultrepo" siblings <- return (map toFilePath some_siblings ++ defrepolist) if (siblings == []) then putStrLn "No siblings -- no relinking done." else do when (Relink `elem` opts) $ do debugMessage "Relinking patches..." patches <- (fmap list_slurpy_files) (slurp $ darcsdir++"/patches") maybeRelinkFiles siblings patches (darcsdir++"/patches") when (RelinkPristine `elem` opts) $ do pristine <- identifyPristine case (pristineDirectory pristine) of (Just d) -> do debugMessage "Relinking pristine tree..." c <- slurp_recorded repository maybeRelinkFiles siblings (list_slurpy_files c) d Nothing -> return () debugMessage "Done relinking." return () return () maybeRelinkFiles :: [String] -> [String] -> String -> IO () maybeRelinkFiles src dst dir = mapM_ (maybeRelinkFile src) (map ((dir ++ "/") ++) dst) maybeRelinkFile :: [String] -> String -> IO () maybeRelinkFile [] _ = return () maybeRelinkFile (h:t) f = do done <- maybeRelink (h ++ "/" ++ f) f unless done $ maybeRelinkFile t f return () \end{code} \begin{options} --reorder-patches \end{options} The \verb|--reorder-patches| option causes Darcs to create an optimal ordering of its internal patch inventory. This may help to produce shorter `context' lists when sending patches, and may improve performance for some other operations as well. You should not run \verb!--reorder-patches! on a repository from which someone may be simultaneously pulling or getting, as this could lead to repository corruption. \begin{code} -- FIXME: someone needs to grovel through the source and determine -- just how optimizeInventory differs from do_reorder. The following -- is purely speculation. --twb, 2009-04 -- optimize_help_reorder :: String -- optimize_help_reorder = -- "The `darcs optimize --reorder' command is a more comprehensive version\n" ++ -- "of the default optimization. It reorders patches with respect to ALL\n" ++ -- "tags, rather than just the latest tag.\n" do_reorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO () do_reorder opts _ | not (Reorder `elem` opts) = return () do_reorder opts repository = do debugMessage "Reordering the inventory." psnew <- choose_order `fmap` read_repo repository let ps = mapFL_FL hopefully $ reverseRL $ head $ unsafeUnRL psnew withGutsOf repository $ do tentativelyReplacePatches repository opts ps finalizeRepositoryChanges repository debugMessage "Done reordering the inventory." choose_order :: RepoPatch p => PatchSet p -> PatchSet p choose_order ps | isJust last_tag = case slightly_optimize_patchset $ unsafeUnseal $ get_patches_in_tag lt ps of ((t:<:NilRL):<:pps) -> case get_patches_beyond_tag lt ps of FlippedSeal (p :<: NilRL) -> (p+<+(t:<:NilRL)) :<: pps _ -> impossible _ -> impossible where last_tag = case filter is_tag $ mapRL info $ concatRL ps of (t:_) -> Just t _ -> Nothing lt = fromJust last_tag choose_order ps = ps \end{code}