2012-01-06 19:40:04 +00:00
|
|
|
{- git-annex command
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
2012-01-06 19:40:04 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2015-05-10 18:45:55 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2012-01-06 19:40:04 +00:00
|
|
|
module Command.Log where
|
|
|
|
|
|
|
|
import qualified Data.Set as S
|
2012-01-07 22:13:12 +00:00
|
|
|
import qualified Data.Map as M
|
2012-01-06 19:40:04 +00:00
|
|
|
import qualified Data.ByteString.Lazy.Char8 as L
|
2015-05-10 18:45:55 +00:00
|
|
|
import Data.Char
|
2012-01-06 19:40:04 +00:00
|
|
|
import Data.Time.Clock.POSIX
|
|
|
|
import Data.Time
|
2015-05-10 18:45:55 +00:00
|
|
|
#if ! MIN_VERSION_time(1,5,0)
|
2012-01-06 19:40:04 +00:00
|
|
|
import System.Locale
|
2015-05-10 18:45:55 +00:00
|
|
|
#endif
|
2012-01-06 19:40:04 +00:00
|
|
|
|
|
|
|
import Common.Annex
|
|
|
|
import Command
|
2013-08-29 22:51:22 +00:00
|
|
|
import Logs
|
2012-01-06 19:40:04 +00:00
|
|
|
import qualified Logs.Presence
|
|
|
|
import Annex.CatFile
|
|
|
|
import qualified Annex.Branch
|
|
|
|
import qualified Git
|
|
|
|
import Git.Command
|
|
|
|
import qualified Remote
|
2012-01-07 01:27:42 +00:00
|
|
|
import qualified Annex
|
2012-01-06 19:40:04 +00:00
|
|
|
|
2012-01-06 22:54:48 +00:00
|
|
|
data RefChange = RefChange
|
|
|
|
{ changetime :: POSIXTime
|
|
|
|
, oldref :: Git.Ref
|
|
|
|
, newref :: Git.Ref
|
|
|
|
}
|
|
|
|
|
2012-01-07 22:13:12 +00:00
|
|
|
type Outputter = Bool -> POSIXTime -> [UUID] -> Annex ()
|
|
|
|
|
2015-07-08 16:33:27 +00:00
|
|
|
cmd :: Command
|
2015-07-13 14:44:51 +00:00
|
|
|
cmd = withGlobalOptions annexedMatchingOptions $
|
2015-07-08 19:08:02 +00:00
|
|
|
command "log" SectionQuery "shows location log"
|
2015-07-13 14:44:51 +00:00
|
|
|
paramPaths (seek <$$> optParser)
|
2012-01-06 21:24:03 +00:00
|
|
|
|
2015-07-13 14:44:51 +00:00
|
|
|
data LogOptions = LogOptions
|
|
|
|
{ logFiles :: CmdParams
|
|
|
|
, gourceOption :: Bool
|
|
|
|
, passthruOptions :: [CommandParam]
|
|
|
|
}
|
2012-01-07 22:13:12 +00:00
|
|
|
|
2015-07-13 14:44:51 +00:00
|
|
|
optParser :: CmdParamsDesc -> Parser LogOptions
|
|
|
|
optParser desc = LogOptions
|
|
|
|
<$> cmdParams desc
|
|
|
|
<*> switch
|
|
|
|
( long "gource"
|
|
|
|
<> help "format output for gource"
|
|
|
|
)
|
|
|
|
<*> (concat <$> many passthru)
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
2015-07-13 14:44:51 +00:00
|
|
|
passthru :: Parser [CommandParam]
|
|
|
|
passthru = datepassthru "since"
|
|
|
|
<|> datepassthru "after"
|
|
|
|
<|> datepassthru "until"
|
|
|
|
<|> datepassthru "before"
|
|
|
|
<|> (mkpassthru "max-count" <$> strOption
|
|
|
|
( long "max-count" <> metavar paramNumber
|
|
|
|
<> help "limit number of logs displayed"
|
|
|
|
))
|
|
|
|
datepassthru n = mkpassthru n <$> strOption
|
|
|
|
( long n <> metavar paramDate
|
|
|
|
<> help ("show log " ++ n ++ " date")
|
|
|
|
)
|
|
|
|
mkpassthru n v = [Param ("--" ++ n), Param v]
|
2012-01-07 22:13:12 +00:00
|
|
|
|
2015-07-13 14:44:51 +00:00
|
|
|
seek :: LogOptions -> CommandSeek
|
|
|
|
seek o = do
|
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
|
|
|
m <- Remote.uuidDescriptions
|
|
|
|
zone <- liftIO getCurrentTimeZone
|
2015-07-13 14:44:51 +00:00
|
|
|
withFilesInGit (whenAnnexed $ start m zone o) (logFiles o)
|
2012-01-06 19:40:04 +00:00
|
|
|
|
2014-04-17 22:03:39 +00:00
|
|
|
start
|
|
|
|
:: M.Map UUID String
|
|
|
|
-> TimeZone
|
2015-07-13 14:44:51 +00:00
|
|
|
-> LogOptions
|
2014-04-17 22:03:39 +00:00
|
|
|
-> FilePath
|
|
|
|
-> Key
|
|
|
|
-> CommandStart
|
2015-07-13 14:44:51 +00:00
|
|
|
start m zone o file key = do
|
|
|
|
showLog output =<< readLog <$> getLog key (passthruOptions o)
|
2012-10-04 22:57:53 +00:00
|
|
|
-- getLog produces a zombie; reap it
|
2012-10-17 04:39:45 +00:00
|
|
|
liftIO reapZombies
|
2012-01-06 19:40:04 +00:00
|
|
|
stop
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
output
|
2015-07-13 14:44:51 +00:00
|
|
|
| (gourceOption o) = gourceOutput lookupdescription file
|
2012-11-12 05:05:04 +00:00
|
|
|
| otherwise = normalOutput lookupdescription file zone
|
|
|
|
lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m
|
2012-01-06 19:40:04 +00:00
|
|
|
|
2012-01-07 22:13:12 +00:00
|
|
|
showLog :: Outputter -> [RefChange] -> Annex ()
|
|
|
|
showLog outputter ps = do
|
2012-01-06 22:54:48 +00:00
|
|
|
sets <- mapM (getset newref) ps
|
|
|
|
previous <- maybe (return genesis) (getset oldref) (lastMaybe ps)
|
2012-01-07 22:13:12 +00:00
|
|
|
sequence_ $ compareChanges outputter $ sets ++ [previous]
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
genesis = (0, S.empty)
|
|
|
|
getset select change = do
|
|
|
|
s <- S.fromList <$> get (select change)
|
|
|
|
return (changetime change, s)
|
|
|
|
get ref = map toUUID . Logs.Presence.getLog . L.unpack <$>
|
|
|
|
catObject ref
|
2012-01-07 22:13:12 +00:00
|
|
|
|
|
|
|
normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter
|
2012-02-16 04:41:30 +00:00
|
|
|
normalOutput lookupdescription file zone present ts us =
|
2012-01-07 22:13:12 +00:00
|
|
|
liftIO $ mapM_ (putStrLn . format) us
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
time = showTimeStamp zone ts
|
|
|
|
addel = if present then "+" else "-"
|
|
|
|
format u = unwords [ addel, time, file, "|",
|
|
|
|
fromUUID u ++ " -- " ++ lookupdescription u ]
|
2012-01-07 22:13:12 +00:00
|
|
|
|
|
|
|
gourceOutput :: (UUID -> String) -> FilePath -> Outputter
|
2012-02-16 04:41:30 +00:00
|
|
|
gourceOutput lookupdescription file present ts us =
|
2012-01-07 22:13:12 +00:00
|
|
|
liftIO $ mapM_ (putStrLn . intercalate "|" . format) us
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
time = takeWhile isDigit $ show ts
|
|
|
|
addel = if present then "A" else "M"
|
|
|
|
format u = [ time, lookupdescription u, addel, file ]
|
2012-01-06 19:40:04 +00:00
|
|
|
|
2012-01-07 04:11:15 +00:00
|
|
|
{- Generates a display of the changes (which are ordered with newest first),
|
|
|
|
- by comparing each change with the previous change.
|
2012-01-07 04:45:01 +00:00
|
|
|
- Uses a formatter to generate a display of items that are added and
|
2012-01-07 04:11:15 +00:00
|
|
|
- removed. -}
|
2012-01-07 22:13:12 +00:00
|
|
|
compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b]
|
2012-01-07 04:11:15 +00:00
|
|
|
compareChanges format changes = concatMap diff $ zip changes (drop 1 changes)
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
diff ((ts, new), (_, old)) =
|
|
|
|
[format True ts added, format False ts removed]
|
|
|
|
where
|
|
|
|
added = S.toList $ S.difference new old
|
|
|
|
removed = S.toList $ S.difference old new
|
2012-01-07 04:11:15 +00:00
|
|
|
|
2012-01-07 04:15:01 +00:00
|
|
|
{- Gets the git log for a given location log file.
|
|
|
|
-
|
|
|
|
- This is complicated by git log using paths relative to the current
|
|
|
|
- directory, even when looking at files in a different branch. A wacky
|
|
|
|
- relative path to the log file has to be used.
|
|
|
|
-
|
|
|
|
- The --remove-empty is a significant optimisation. It relies on location
|
|
|
|
- log files never being deleted in normal operation. Letting git stop
|
|
|
|
- once the location log file is gone avoids it checking all the way back
|
|
|
|
- to commit 0 to see if it used to exist, so generally speeds things up a
|
|
|
|
- *lot* for newish files. -}
|
2012-01-06 21:24:03 +00:00
|
|
|
getLog :: Key -> [CommandParam] -> Annex [String]
|
2012-01-07 01:27:42 +00:00
|
|
|
getLog key os = do
|
Clean up handling of git directory and git worktree.
Baked into the code was an assumption that a repository's git directory
could be determined by adding ".git" to its work tree (or nothing for bare
repos). That fails when core.worktree, or GIT_DIR and GIT_WORK_TREE are
used to separate the two.
This was attacked at the type level, by storing the gitdir and worktree
separately, so Nothing for the worktree means a bare repo.
A complication arose because we don't learn where a repository is bare
until its configuration is read. So another Location type handles
repositories that have not had their config read yet. I am not entirely
happy with this being a Location type, rather than representing them
entirely separate from the Git type. The new code is not worse than the
old, but better types could enforce more safety.
Added support for core.worktree. Overriding it with -c isn't supported
because it's not really clear what to do if a git repo's config is read, is
not bare, and is then overridden to bare. What is the right git directory
in this case? I will worry about this if/when someone has a use case for
overriding core.worktree with -c. (See Git.Config.updateLocation)
Also removed and renamed some functions like gitDir and workTree that
misused git's terminology.
One minor regression is known: git annex add in a bare repository does not
print a nice error message, but runs git ls-files in a way that fails
earlier with a less nice error message. This is because before --work-tree
was always passed to git commands, even in a bare repo, while now it's not.
2012-05-18 20:38:26 +00:00
|
|
|
top <- fromRepo Git.repoPath
|
2012-01-06 19:40:04 +00:00
|
|
|
p <- liftIO $ relPathCwdToFile top
|
2015-01-28 21:17:26 +00:00
|
|
|
config <- Annex.getGitConfig
|
|
|
|
let logfile = p </> locationLogFile config key
|
2012-10-04 22:47:31 +00:00
|
|
|
inRepo $ pipeNullSplitZombie $
|
2015-06-01 17:52:23 +00:00
|
|
|
[ Param "log"
|
|
|
|
, Param "-z"
|
|
|
|
, Param "--pretty=format:%ct"
|
2015-07-02 16:53:38 +00:00
|
|
|
, Param "--raw"
|
2015-06-01 17:52:23 +00:00
|
|
|
, Param "--abbrev=40"
|
2012-01-07 04:15:01 +00:00
|
|
|
, Param "--remove-empty"
|
2012-01-07 01:27:42 +00:00
|
|
|
] ++ os ++
|
2014-02-19 05:09:17 +00:00
|
|
|
[ Param $ Git.fromRef Annex.Branch.fullname
|
2012-01-06 19:40:04 +00:00
|
|
|
, Param "--"
|
|
|
|
, Param logfile
|
|
|
|
]
|
|
|
|
|
2012-01-06 22:54:48 +00:00
|
|
|
readLog :: [String] -> [RefChange]
|
2012-01-06 21:24:03 +00:00
|
|
|
readLog = mapMaybe (parse . lines)
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
parse (ts:raw:[]) = let (old, new) = parseRaw raw in
|
|
|
|
Just RefChange
|
|
|
|
{ changetime = parseTimeStamp ts
|
|
|
|
, oldref = old
|
|
|
|
, newref = new
|
|
|
|
}
|
|
|
|
parse _ = Nothing
|
2012-01-06 19:40:04 +00:00
|
|
|
|
|
|
|
-- Parses something like ":100644 100644 oldsha newsha M"
|
2012-01-06 21:24:03 +00:00
|
|
|
parseRaw :: String -> (Git.Ref, Git.Ref)
|
2012-10-18 04:45:22 +00:00
|
|
|
parseRaw l = go $ words l
|
2012-11-12 05:05:04 +00:00
|
|
|
where
|
|
|
|
go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha)
|
|
|
|
go _ = error $ "unable to parse git log output: " ++ l
|
2012-01-06 19:40:04 +00:00
|
|
|
|
|
|
|
parseTimeStamp :: String -> POSIXTime
|
|
|
|
parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .
|
2015-05-10 19:54:58 +00:00
|
|
|
#if MIN_VERSION_time(1,5,0)
|
|
|
|
parseTimeM True defaultTimeLocale "%s"
|
|
|
|
#else
|
2012-01-06 19:40:04 +00:00
|
|
|
parseTime defaultTimeLocale "%s"
|
2015-05-10 19:54:58 +00:00
|
|
|
#endif
|
2012-01-07 03:43:18 +00:00
|
|
|
|
|
|
|
showTimeStamp :: TimeZone -> POSIXTime -> String
|
|
|
|
showTimeStamp zone = show . utcToLocalTime zone . posixSecondsToUTCTime
|