2010-11-15 20:35:06 +00:00
|
|
|
{- git-annex command
|
|
|
|
-
|
2016-01-07 02:11:21 +00:00
|
|
|
- Copyright 2010-2016 Joey Hess <id@joeyh.name>
|
2010-11-15 20:35:06 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2011-08-31 23:13:02 +00:00
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
|
2010-11-15 20:35:06 +00:00
|
|
|
module Command.Unused where
|
|
|
|
|
2013-07-03 19:26:59 +00:00
|
|
|
import qualified Data.Map as M
|
2010-11-15 20:35:06 +00:00
|
|
|
|
|
|
|
import Command
|
2012-05-02 18:59:05 +00:00
|
|
|
import Logs.Unused
|
2011-10-04 04:40:47 +00:00
|
|
|
import Annex.Content
|
2011-10-15 20:21:08 +00:00
|
|
|
import Logs.Location
|
2010-11-15 22:04:19 +00:00
|
|
|
import qualified Annex
|
2011-06-30 17:16:57 +00:00
|
|
|
import qualified Git
|
2011-12-14 19:56:11 +00:00
|
|
|
import qualified Git.Command
|
2011-12-12 22:23:24 +00:00
|
|
|
import qualified Git.Ref
|
2013-08-26 17:01:48 +00:00
|
|
|
import qualified Git.Branch
|
2015-07-07 21:13:50 +00:00
|
|
|
import qualified Git.RefLog
|
2011-06-30 17:16:57 +00:00
|
|
|
import qualified Git.LsFiles as LsFiles
|
2013-08-26 00:47:49 +00:00
|
|
|
import qualified Git.DiffTree as DiffTree
|
2011-04-03 00:59:41 +00:00
|
|
|
import qualified Remote
|
2011-10-04 04:40:47 +00:00
|
|
|
import qualified Annex.Branch
|
|
|
|
import Annex.CatFile
|
2016-03-14 17:13:56 +00:00
|
|
|
import Annex.WorkTree
|
2015-05-14 19:31:38 +00:00
|
|
|
import Types.RefSpec
|
2015-07-10 20:05:56 +00:00
|
|
|
import Git.Types
|
2016-01-07 00:38:02 +00:00
|
|
|
import Git.Sha
|
2016-01-07 02:11:21 +00:00
|
|
|
import Git.FilePath
|
2016-06-02 20:59:15 +00:00
|
|
|
import Config
|
2014-06-04 18:03:41 +00:00
|
|
|
import Logs.View (is_branchView)
|
2015-06-16 21:58:15 +00:00
|
|
|
import Annex.BloomFilter
|
2016-01-07 02:11:21 +00:00
|
|
|
import qualified Database.Keys
|
|
|
|
import Annex.InodeSentinal
|
2010-11-15 20:35:06 +00:00
|
|
|
|
2015-07-08 16:33:27 +00:00
|
|
|
cmd :: Command
|
2016-01-07 00:41:25 +00:00
|
|
|
cmd = command "unused" SectionMaintenance "look for unused file content"
|
|
|
|
paramNothing (seek <$$> optParser)
|
2010-12-30 19:06:26 +00:00
|
|
|
|
2015-07-10 20:05:56 +00:00
|
|
|
data UnusedOptions = UnusedOptions
|
|
|
|
{ fromRemote :: Maybe RemoteName
|
|
|
|
, refSpecOption :: Maybe RefSpec
|
|
|
|
}
|
more command-specific options
Made --from and --to command-specific options.
Added generic storage for values of command-specific options,
which allows removing some of the special case fields in AnnexState.
(Also added generic storage for command-specific flags, although there are
not yet any.)
Note that this storage uses a Map, so repeatedly looking up the same value
is slightly more expensive than looking up an AnnexState field. But, the
value can be looked up once in the seek stage, transformed as necessary,
and passed in a closure to the start stage, and this avoids that overhead.
Still, I'm hesitant to use this for things like force or fast flags.
It's probably best to reserve it for flags that are only used by a few
commands, or options like --from and --to that it's important only be
allowed to be used with commands that implement them, to avoid user
confusion.
2012-01-06 07:06:25 +00:00
|
|
|
|
2015-07-10 20:05:56 +00:00
|
|
|
optParser :: CmdParamsDesc -> Parser UnusedOptions
|
|
|
|
optParser _ = UnusedOptions
|
|
|
|
<$> optional (strOption
|
|
|
|
( long "from" <> short 'f' <> metavar paramRemote
|
|
|
|
<> help "remote to check for unused content"
|
|
|
|
))
|
|
|
|
<*> optional (option (eitherReader parseRefSpec)
|
2015-09-08 12:29:25 +00:00
|
|
|
( long "used-refspec" <> metavar paramRefSpec
|
2015-07-10 20:05:56 +00:00
|
|
|
<> help "refs to consider used (default: all branches)"
|
|
|
|
))
|
2015-05-14 19:31:38 +00:00
|
|
|
|
2015-07-10 20:05:56 +00:00
|
|
|
seek :: UnusedOptions -> CommandSeek
|
|
|
|
seek = commandAction . start
|
2010-11-15 20:35:06 +00:00
|
|
|
|
2015-07-10 20:05:56 +00:00
|
|
|
start :: UnusedOptions -> CommandStart
|
|
|
|
start o = do
|
2015-05-14 19:44:08 +00:00
|
|
|
cfgrefspec <- fromMaybe allRefSpec . annexUsedRefSpec
|
|
|
|
<$> Annex.getGitConfig
|
2015-07-10 20:05:56 +00:00
|
|
|
let refspec = fromMaybe cfgrefspec (refSpecOption o)
|
|
|
|
let (name, perform) = case fromRemote o of
|
2015-05-14 19:31:38 +00:00
|
|
|
Nothing -> (".", checkUnused refspec)
|
|
|
|
Just "." -> (".", checkUnused refspec)
|
|
|
|
Just "here" -> (".", checkUnused refspec)
|
|
|
|
Just n -> (n, checkRemoteUnused n refspec)
|
2011-05-29 02:37:17 +00:00
|
|
|
showStart "unused" name
|
2015-07-09 23:03:21 +00:00
|
|
|
next perform
|
2010-11-15 20:35:06 +00:00
|
|
|
|
2015-05-14 19:31:38 +00:00
|
|
|
checkUnused :: RefSpec -> CommandPerform
|
|
|
|
checkUnused refspec = chain 0
|
2012-03-12 01:08:48 +00:00
|
|
|
[ check "" unusedMsg $ findunused =<< Annex.getState Annex.fast
|
2013-07-25 23:51:08 +00:00
|
|
|
, check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir False
|
2014-02-26 20:52:56 +00:00
|
|
|
, check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpObjectDir True
|
2012-03-12 01:08:48 +00:00
|
|
|
]
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
findunused True = do
|
|
|
|
showNote "fast mode enabled; only finding stale files"
|
|
|
|
return []
|
|
|
|
findunused False = do
|
|
|
|
showAction "checking for unused data"
|
2014-03-07 16:43:56 +00:00
|
|
|
-- InAnnex, not InRepository because if a direct mode
|
|
|
|
-- file exists, it is obviously not unused.
|
2015-05-14 19:31:38 +00:00
|
|
|
excludeReferenced refspec =<< getKeysPresent InAnnex
|
2012-11-12 05:05:04 +00:00
|
|
|
chain _ [] = next $ return True
|
|
|
|
chain v (a:as) = do
|
|
|
|
v' <- a v
|
|
|
|
chain v' as
|
2011-01-28 18:10:50 +00:00
|
|
|
|
2015-05-14 19:31:38 +00:00
|
|
|
checkRemoteUnused :: String -> RefSpec -> CommandPerform
|
|
|
|
checkRemoteUnused name refspec = go =<< fromJust <$> Remote.byNameWithUUID (Just name)
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
go r = do
|
|
|
|
showAction "checking for unused data"
|
|
|
|
_ <- check "" (remoteUnusedMsg r) (remoteunused r) 0
|
|
|
|
next $ return True
|
2015-05-14 19:31:38 +00:00
|
|
|
remoteunused r = excludeReferenced refspec <=< loggedKeysFor $ Remote.uuid r
|
2012-03-12 01:08:48 +00:00
|
|
|
|
|
|
|
check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int
|
|
|
|
check file msg a c = do
|
|
|
|
l <- a
|
|
|
|
let unusedlist = number c l
|
|
|
|
unless (null l) $ showLongNote $ msg unusedlist
|
2014-01-22 19:33:02 +00:00
|
|
|
updateUnusedLog file $ M.fromList unusedlist
|
2012-03-12 01:08:48 +00:00
|
|
|
return $ c + length l
|
2011-05-15 06:49:43 +00:00
|
|
|
|
2012-03-12 01:08:48 +00:00
|
|
|
number :: Int -> [a] -> [(Int, a)]
|
|
|
|
number _ [] = []
|
|
|
|
number n (x:xs) = (n+1, x) : number (n+1) xs
|
2011-04-03 00:59:41 +00:00
|
|
|
|
|
|
|
table :: [(Int, Key)] -> [String]
|
2011-07-15 16:47:14 +00:00
|
|
|
table l = " NUMBER KEY" : map cols l
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k
|
|
|
|
pad n s = s ++ replicate (n - length s) ' '
|
2010-11-15 22:04:19 +00:00
|
|
|
|
2011-04-03 00:59:41 +00:00
|
|
|
staleTmpMsg :: [(Int, Key)] -> String
|
|
|
|
staleTmpMsg t = unlines $
|
|
|
|
["Some partially transferred data exists in temporary files:"]
|
|
|
|
++ table t ++ [dropMsg Nothing]
|
2011-04-29 17:59:00 +00:00
|
|
|
|
|
|
|
staleBadMsg :: [(Int, Key)] -> String
|
|
|
|
staleBadMsg t = unlines $
|
|
|
|
["Some corrupted files have been preserved by fsck, just in case:"]
|
|
|
|
++ table t ++ [dropMsg Nothing]
|
|
|
|
|
2011-04-03 00:59:41 +00:00
|
|
|
unusedMsg :: [(Int, Key)] -> String
|
|
|
|
unusedMsg u = unusedMsg' u
|
2011-09-23 22:04:38 +00:00
|
|
|
["Some annexed data is no longer used by any files:"]
|
|
|
|
[dropMsg Nothing]
|
2011-04-03 00:59:41 +00:00
|
|
|
unusedMsg' :: [(Int, Key)] -> [String] -> [String] -> String
|
2015-07-09 23:03:21 +00:00
|
|
|
unusedMsg' u mheader mtrailer = unlines $
|
|
|
|
mheader ++
|
2011-04-03 00:59:41 +00:00
|
|
|
table u ++
|
|
|
|
["(To see where data was previously used, try: git log --stat -S'KEY')"] ++
|
2015-07-09 23:03:21 +00:00
|
|
|
mtrailer
|
2011-04-03 00:59:41 +00:00
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
|
2011-09-23 22:04:38 +00:00
|
|
|
remoteUnusedMsg r u = unusedMsg' u
|
|
|
|
["Some annexed data on " ++ name ++ " is not used by any files:"]
|
|
|
|
[dropMsg $ Just r]
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
name = Remote.name r
|
2011-09-23 22:04:38 +00:00
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
dropMsg :: Maybe Remote -> String
|
2011-04-03 00:59:41 +00:00
|
|
|
dropMsg Nothing = dropMsg' ""
|
|
|
|
dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r
|
|
|
|
dropMsg' :: String -> String
|
2011-06-23 16:23:25 +00:00
|
|
|
dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\n"
|
2011-04-03 00:59:41 +00:00
|
|
|
|
2012-03-12 19:21:20 +00:00
|
|
|
{- Finds keys in the list that are not referenced in the git repository.
|
|
|
|
-
|
|
|
|
- Strategy:
|
|
|
|
-
|
2016-01-07 02:11:21 +00:00
|
|
|
- Pass keys through these filters in order, only creating each bloom
|
2016-01-07 00:38:02 +00:00
|
|
|
- filter on demand if the previous one didn't filter out all keys.
|
|
|
|
-
|
2016-01-07 02:11:21 +00:00
|
|
|
- 1. Bloom filter containing all keys referenced by files in the work tree.
|
2016-01-07 00:38:02 +00:00
|
|
|
- This is the fastest one to build and will filter out most keys.
|
2016-01-07 02:11:21 +00:00
|
|
|
- 2. Bloom filter containing all keys in the diff from the work tree to
|
|
|
|
- the index.
|
|
|
|
- 3. Associated files filter. A v6 unlocked file may have had its content
|
|
|
|
- added to the annex (by eg, git diff running the smudge filter),
|
|
|
|
- but the new key is not yet staged in the index. But if so, it will
|
|
|
|
- have an associated file.
|
|
|
|
- 4. Bloom filter containing all keys in the diffs between the index and
|
|
|
|
- branches matching the RefSpec. (This can take quite a while to build).
|
2012-03-12 19:21:20 +00:00
|
|
|
-}
|
2015-05-14 19:31:38 +00:00
|
|
|
excludeReferenced :: RefSpec -> [Key] -> Annex [Key]
|
2016-01-07 02:11:21 +00:00
|
|
|
excludeReferenced refspec ks = runbloomfilter withKeysReferencedM ks
|
|
|
|
>>= runbloomfilter withKeysReferencedDiffIndex
|
|
|
|
>>= runfilter associatedFilesFilter
|
|
|
|
>>= runbloomfilter (withKeysReferencedDiffGitRefs refspec)
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
runfilter _ [] = return [] -- optimisation
|
2016-01-07 02:11:21 +00:00
|
|
|
runfilter a l = a l
|
|
|
|
runbloomfilter a = runfilter $ \l -> bloomFilter l <$> genBloomFilter a
|
2011-09-28 21:35:47 +00:00
|
|
|
|
2012-03-12 19:21:20 +00:00
|
|
|
{- Given an initial value, folds it with each key referenced by
|
2016-01-06 21:46:46 +00:00
|
|
|
- files in the working tree. -}
|
2012-03-11 19:19:07 +00:00
|
|
|
withKeysReferenced :: v -> (Key -> v -> v) -> Annex v
|
2013-03-11 05:22:56 +00:00
|
|
|
withKeysReferenced initial a = withKeysReferenced' Nothing initial folda
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2013-03-11 05:22:56 +00:00
|
|
|
folda k _ v = return $ a k v
|
2012-03-12 19:21:20 +00:00
|
|
|
|
2016-01-06 21:46:46 +00:00
|
|
|
{- Runs an action on each referenced key in the working tree. -}
|
2012-03-12 19:21:20 +00:00
|
|
|
withKeysReferencedM :: (Key -> Annex ()) -> Annex ()
|
2013-03-11 05:22:56 +00:00
|
|
|
withKeysReferencedM a = withKeysReferenced' Nothing () calla
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2013-03-11 05:22:56 +00:00
|
|
|
calla k _ _ = a k
|
2012-03-12 19:21:20 +00:00
|
|
|
|
2013-03-11 05:22:56 +00:00
|
|
|
{- Folds an action over keys and files referenced in a particular directory. -}
|
|
|
|
withKeysFilesReferencedIn :: FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v
|
|
|
|
withKeysFilesReferencedIn = withKeysReferenced' . Just
|
|
|
|
|
|
|
|
withKeysReferenced' :: Maybe FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v
|
|
|
|
withKeysReferenced' mdir initial a = do
|
2012-10-04 23:56:32 +00:00
|
|
|
(files, clean) <- getfiles
|
|
|
|
r <- go initial files
|
|
|
|
liftIO $ void clean
|
|
|
|
return r
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2013-03-11 05:22:56 +00:00
|
|
|
getfiles = case mdir of
|
|
|
|
Nothing -> ifM isBareRepo
|
|
|
|
( return ([], return True)
|
|
|
|
, do
|
|
|
|
top <- fromRepo Git.repoPath
|
2013-08-22 14:20:03 +00:00
|
|
|
inRepo $ LsFiles.allFiles [top]
|
2013-03-11 05:22:56 +00:00
|
|
|
)
|
|
|
|
Just dir -> inRepo $ LsFiles.inRepo [dir]
|
2012-11-12 05:05:04 +00:00
|
|
|
go v [] = return v
|
|
|
|
go v (f:fs) = do
|
2016-03-14 17:13:56 +00:00
|
|
|
mk <- lookupFile f
|
2016-01-06 20:30:49 +00:00
|
|
|
case mk of
|
2012-11-12 05:05:04 +00:00
|
|
|
Nothing -> go v fs
|
2014-04-17 22:03:39 +00:00
|
|
|
Just k -> do
|
2013-03-11 05:22:56 +00:00
|
|
|
!v' <- a k f v
|
2012-11-12 05:05:04 +00:00
|
|
|
go v' fs
|
2012-03-12 19:21:20 +00:00
|
|
|
|
2016-01-07 00:38:02 +00:00
|
|
|
withKeysReferencedDiffGitRefs :: RefSpec -> (Key -> Annex ()) -> Annex ()
|
|
|
|
withKeysReferencedDiffGitRefs refspec a = do
|
|
|
|
rs <- relevantrefs <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"])
|
|
|
|
shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha)
|
|
|
|
=<< inRepo Git.Branch.currentUnsafe
|
|
|
|
let haveHead = any (\(shaRef, _) -> Just shaRef == shaHead) rs
|
|
|
|
let rs' = map snd (nubRefs rs)
|
|
|
|
usedrefs <- applyRefSpec refspec rs' (getreflog rs')
|
|
|
|
forM_ (if haveHead then usedrefs else Git.Ref.headRef : usedrefs) $
|
|
|
|
withKeysReferencedDiffGitRef a
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2016-01-07 00:38:02 +00:00
|
|
|
relevantrefs = map (\(r, h) -> (Git.Ref r, Git.Ref h)) .
|
2012-11-12 05:05:04 +00:00
|
|
|
filter ourbranches .
|
2013-08-26 00:47:49 +00:00
|
|
|
map (separate (== ' ')) .
|
|
|
|
lines
|
2016-01-07 00:38:02 +00:00
|
|
|
nubRefs = nubBy (\(x, _) (y, _) -> x == y)
|
2014-02-19 05:09:17 +00:00
|
|
|
ourbranchend = '/' : Git.fromRef Annex.Branch.name
|
2012-11-12 05:05:04 +00:00
|
|
|
ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
|
|
|
|
&& not ("refs/synced/" `isPrefixOf` b)
|
2014-06-04 18:03:41 +00:00
|
|
|
&& not (is_branchView (Git.Ref b))
|
2015-07-07 21:31:30 +00:00
|
|
|
getreflog rs = inRepo $ Git.RefLog.getMulti rs
|
2012-03-12 19:21:20 +00:00
|
|
|
|
2013-08-26 00:47:49 +00:00
|
|
|
{- Runs an action on keys referenced in the given Git reference which
|
2016-01-07 00:38:02 +00:00
|
|
|
- differ from those referenced in the index. -}
|
|
|
|
withKeysReferencedDiffGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
|
|
|
|
withKeysReferencedDiffGitRef a ref = do
|
2011-12-12 22:23:24 +00:00
|
|
|
showAction $ "checking " ++ Git.Ref.describe ref
|
2016-01-07 00:38:02 +00:00
|
|
|
withKeysReferencedDiff a
|
|
|
|
(inRepo $ DiffTree.diffIndex ref)
|
|
|
|
DiffTree.srcsha
|
|
|
|
|
|
|
|
{- Runs an action on keys referenced in the index which differ from the
|
|
|
|
- work tree. -}
|
|
|
|
withKeysReferencedDiffIndex :: (Key -> Annex ()) -> Annex ()
|
|
|
|
withKeysReferencedDiffIndex a = unlessM (isBareRepo) $
|
|
|
|
withKeysReferencedDiff a
|
|
|
|
(inRepo $ DiffTree.diffFiles [])
|
|
|
|
DiffTree.srcsha
|
|
|
|
|
|
|
|
withKeysReferencedDiff :: (Key -> Annex ()) -> (Annex ([DiffTree.DiffTreeItem], IO Bool)) -> (DiffTree.DiffTreeItem -> Sha) -> Annex ()
|
|
|
|
withKeysReferencedDiff a getdiff extractsha = do
|
|
|
|
(ds, clean) <- getdiff
|
|
|
|
forM_ ds go
|
2013-08-26 00:47:49 +00:00
|
|
|
liftIO $ void clean
|
2013-08-26 04:14:19 +00:00
|
|
|
where
|
2017-01-31 22:40:42 +00:00
|
|
|
go d = do
|
2016-01-07 00:38:02 +00:00
|
|
|
let sha = extractsha d
|
|
|
|
unless (sha == nullSha) $
|
2017-01-31 23:07:24 +00:00
|
|
|
catKey sha >>= maybe noop a
|
2011-01-28 18:10:50 +00:00
|
|
|
|
2016-01-07 02:11:21 +00:00
|
|
|
{- Filters out keys that have an associated file that's not modified. -}
|
|
|
|
associatedFilesFilter :: [Key] -> Annex [Key]
|
|
|
|
associatedFilesFilter = filterM go
|
|
|
|
where
|
|
|
|
go k = do
|
|
|
|
cs <- Database.Keys.getInodeCaches k
|
|
|
|
if null cs
|
|
|
|
then return True
|
|
|
|
else checkunmodified cs
|
|
|
|
=<< Database.Keys.getAssociatedFiles k
|
|
|
|
checkunmodified _ [] = return True
|
|
|
|
checkunmodified cs (f:fs) = do
|
|
|
|
relf <- fromRepo $ fromTopFilePath f
|
|
|
|
ifM (sameInodeCache relf cs)
|
|
|
|
( return False
|
|
|
|
, checkunmodified cs fs
|
|
|
|
)
|
|
|
|
|
2013-07-03 19:26:59 +00:00
|
|
|
data UnusedMaps = UnusedMaps
|
|
|
|
{ unusedMap :: UnusedMap
|
|
|
|
, unusedBadMap :: UnusedMap
|
|
|
|
, unusedTmpMap :: UnusedMap
|
|
|
|
}
|
|
|
|
|
2015-07-08 19:08:02 +00:00
|
|
|
withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CmdParams -> CommandSeek
|
2013-07-03 19:26:59 +00:00
|
|
|
withUnusedMaps a params = do
|
2014-01-22 19:33:02 +00:00
|
|
|
unused <- readUnusedMap ""
|
|
|
|
unusedbad <- readUnusedMap "bad"
|
|
|
|
unusedtmp <- readUnusedMap "tmp"
|
2013-11-18 21:24:18 +00:00
|
|
|
let m = unused `M.union` unusedbad `M.union` unusedtmp
|
fix inversion of control in CommandSeek (no behavior changes)
I've been disliking how the command seek actions were written for some
time, with their inversion of control and ugly workarounds.
The last straw to fix it was sync --content, which didn't fit the
Annex [CommandStart] interface well at all. I have not yet made it take
advantage of the changed interface though.
The crucial change, and probably why I didn't do it this way from the
beginning, is to make each CommandStart action be run with exceptions
caught, and if it fails, increment a failure counter in annex state.
So I finally remove the very first code I wrote for git-annex, which
was before I had exception handling in the Annex monad, and so ran outside
that monad, passing state explicitly as it ran each CommandStart action.
This was a real slog from 1 to 5 am.
Test suite passes.
Memory usage is lower than before, sometimes by a couple of megabytes, and
remains constant, even when running in a large repo, and even when
repeatedly failing and incrementing the error counter. So no accidental
laziness space leaks.
Wall clock speed is identical, even in large repos.
This commit was sponsored by an anonymous bitcoiner.
2014-01-20 08:11:42 +00:00
|
|
|
let unusedmaps = UnusedMaps unused unusedbad unusedtmp
|
|
|
|
seekActions $ return $ map (a unusedmaps) $
|
2013-11-18 21:24:18 +00:00
|
|
|
concatMap (unusedSpec m) params
|
2013-07-03 19:26:59 +00:00
|
|
|
|
2013-11-18 21:24:18 +00:00
|
|
|
unusedSpec :: UnusedMap -> String -> [Int]
|
|
|
|
unusedSpec m spec
|
2014-01-18 15:38:01 +00:00
|
|
|
| spec == "all" = if M.null m
|
|
|
|
then []
|
|
|
|
else [fst (M.findMin m)..fst (M.findMax m)]
|
2013-07-03 19:26:59 +00:00
|
|
|
| "-" `isInfixOf` spec = range $ separate (== '-') spec
|
|
|
|
| otherwise = maybe badspec (: []) (readish spec)
|
|
|
|
where
|
|
|
|
range (a, b) = case (readish a, readish b) of
|
|
|
|
(Just x, Just y) -> [x..y]
|
|
|
|
_ -> badspec
|
2016-11-16 01:29:54 +00:00
|
|
|
badspec = giveup $ "Expected number or range, not \"" ++ spec ++ "\""
|
2013-07-03 19:26:59 +00:00
|
|
|
|
fix inversion of control in CommandSeek (no behavior changes)
I've been disliking how the command seek actions were written for some
time, with their inversion of control and ugly workarounds.
The last straw to fix it was sync --content, which didn't fit the
Annex [CommandStart] interface well at all. I have not yet made it take
advantage of the changed interface though.
The crucial change, and probably why I didn't do it this way from the
beginning, is to make each CommandStart action be run with exceptions
caught, and if it fails, increment a failure counter in annex state.
So I finally remove the very first code I wrote for git-annex, which
was before I had exception handling in the Annex monad, and so ran outside
that monad, passing state explicitly as it ran each CommandStart action.
This was a real slog from 1 to 5 am.
Test suite passes.
Memory usage is lower than before, sometimes by a couple of megabytes, and
remains constant, even when running in a large repo, and even when
repeatedly failing and incrementing the error counter. So no accidental
laziness space leaks.
Wall clock speed is identical, even in large repos.
This commit was sponsored by an anonymous bitcoiner.
2014-01-20 08:11:42 +00:00
|
|
|
{- Seek action for unused content. Finds the number in the maps, and
|
|
|
|
- calls one of 3 actions, depending on the type of unused file. -}
|
2013-07-03 19:26:59 +00:00
|
|
|
startUnused :: String
|
|
|
|
-> (Key -> CommandPerform)
|
|
|
|
-> (Key -> CommandPerform)
|
|
|
|
-> (Key -> CommandPerform)
|
|
|
|
-> UnusedMaps -> Int -> CommandStart
|
|
|
|
startUnused message unused badunused tmpunused maps n = search
|
|
|
|
[ (unusedMap maps, unused)
|
|
|
|
, (unusedBadMap maps, badunused)
|
|
|
|
, (unusedTmpMap maps, tmpunused)
|
|
|
|
]
|
|
|
|
where
|
2016-11-16 01:29:54 +00:00
|
|
|
search [] = giveup $ show n ++ " not valid (run git annex unused for list)"
|
2013-07-03 19:26:59 +00:00
|
|
|
search ((m, a):rest) =
|
|
|
|
case M.lookup n m of
|
|
|
|
Nothing -> search rest
|
|
|
|
Just key -> do
|
|
|
|
showStart message (show n)
|
|
|
|
next $ a key
|