diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -30,6 +30,7 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.Bits.Utils +import Data.Function import Control.Concurrent (threadDelay) import Annex.Common @@ -81,9 +82,9 @@ hasSibling :: Annex Bool hasSibling = not . null <$> siblingBranches -{- List of git-annex (refs, branches), including the main one and any - - from remotes. Duplicate refs are filtered out. -} -siblingBranches :: Annex [(Git.Ref, Git.Branch)] +{- List of git-annex (shas, branches), including the main one and any + - from remotes. Duplicates are filtered out. -} +siblingBranches :: Annex [(Git.Sha, Git.Branch)] siblingBranches = inRepo $ Git.Ref.matchingUniq [name] {- Creates the branch, if it does not already exist. -} @@ -133,40 +134,50 @@ - - Returns True if any refs were merged in, False otherwise. -} -updateTo :: [(Git.Ref, Git.Branch)] -> Annex Bool +updateTo :: [(Git.Sha, Git.Branch)] -> Annex Bool updateTo pairs = do -- ensure branch exists, and get its current ref branchref <- getBranch dirty <- journalDirty ignoredrefs <- getIgnoredRefs - (refs, branches) <- unzip <$> filterM (isnewer ignoredrefs) pairs - if null refs + let unignoredrefs = excludeset ignoredrefs pairs + tomerge <- if null unignoredrefs + then return [] + else do + mergedrefs <- getMergedRefs + filterM isnewer (excludeset mergedrefs unignoredrefs) + if null tomerge {- Even when no refs need to be merged, the index - may still be updated if the branch has gotten ahead - of the index. -} - then whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do - forceUpdateIndex jl branchref - {- When there are journalled changes - - as well as the branch being updated, - - a commit needs to be done. -} - when dirty $ - go branchref True [] [] jl - else lockJournal $ go branchref dirty refs branches - return $ not $ null refs + then do + whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do + forceUpdateIndex jl branchref + {- When there are journalled changes + - as well as the branch being updated, + - a commit needs to be done. -} + when dirty $ + go branchref True [] jl + {- Only needed for a while, to populate the + - newly added merged refs cache with already + - merged refs. Can be safely removed at any time. -} + addMergedRefs unignoredrefs + else lockJournal $ go branchref dirty tomerge + return $ not $ null tomerge where - isnewer ignoredrefs (r, _) - | S.member r ignoredrefs = return False - | otherwise = inRepo $ Git.Branch.changed fullname r - go branchref dirty refs branches jl = withIndex $ do + excludeset s = filter (\(r, _) -> S.notMember r s) + isnewer (r, _) = inRepo $ Git.Branch.changed fullname r + go branchref dirty tomerge jl = withIndex $ do + let (refs, branches) = unzip tomerge cleanjournal <- if dirty then stageJournal jl else return noop - let merge_desc = if null branches + let merge_desc = if null tomerge then "update" else "merging " ++ unwords (map Git.Ref.describe branches) ++ " into " ++ fromRef name localtransitions <- parseTransitionsStrictly "local" <$> getLocal transitionsLog - unless (null branches) $ do + unless (null tomerge) $ do showSideAction merge_desc mapM_ checkBranchDifferences refs mergeIndex jl refs @@ -181,6 +192,7 @@ then updateIndex jl branchref else commitIndex jl branchref merge_desc commitrefs ) + addMergedRefs tomerge liftIO cleanjournal {- Gets the content of a file, which may be in the journal, or in the index @@ -493,21 +505,6 @@ <$> catFile ref transitionsLog return (ref, ts) -ignoreRefs :: [Git.Ref] -> Annex () -ignoreRefs rs = do - old <- getIgnoredRefs - let s = S.unions [old, S.fromList rs] - f <- fromRepo gitAnnexIgnoredRefs - replaceFile f $ \tmp -> liftIO $ writeFile tmp $ - unlines $ map fromRef $ S.elems s - -getIgnoredRefs :: Annex (S.Set Git.Ref) -getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content - where - content = do - f <- fromRepo gitAnnexIgnoredRefs - liftIO $ catchDefaultIO "" $ readFile f - {- Performs the specified transitions on the contents of the index file, - commits it to the branch, or creates a new branch. -} @@ -578,3 +575,41 @@ mydiffs <- annexDifferences <$> Annex.getGitConfig when (theirdiffs /= mydiffs) $ error "Remote repository is tuned in incompatable way; cannot be merged with local repository." + +ignoreRefs :: [Git.Sha] -> Annex () +ignoreRefs rs = do + old <- getIgnoredRefs + let s = S.unions [old, S.fromList rs] + f <- fromRepo gitAnnexIgnoredRefs + replaceFile f $ \tmp -> liftIO $ writeFile tmp $ + unlines $ map fromRef $ S.elems s + +getIgnoredRefs :: Annex (S.Set Git.Sha) +getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content + where + content = do + f <- fromRepo gitAnnexIgnoredRefs + liftIO $ catchDefaultIO "" $ readFile f + +addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex () +addMergedRefs [] = return () +addMergedRefs new = do + old <- getMergedRefs' + -- Keep only the newest sha for each branch. + let l = nubBy ((==) `on` snd) (new ++ old) + f <- fromRepo gitAnnexMergedRefs + replaceFile f $ \tmp -> liftIO $ writeFile tmp $ + unlines $ map (\(s, b) -> fromRef s ++ '\t' : fromRef b) l + +getMergedRefs :: Annex (S.Set Git.Sha) +getMergedRefs = S.fromList . map fst <$> getMergedRefs' + +getMergedRefs' :: Annex [(Git.Sha, Git.Branch)] +getMergedRefs' = do + f <- fromRepo gitAnnexMergedRefs + s <- liftIO $ catchDefaultIO "" $ readFile f + return $ map parse $ lines s + where + parse l = + let (s, b) = separate (== '\t') l + in (Ref s, Ref b) diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -52,6 +52,7 @@ gitAnnexIndexStatus, gitAnnexViewIndex, gitAnnexViewLog, + gitAnnexMergedRefs, gitAnnexIgnoredRefs, gitAnnexPidFile, gitAnnexPidLockFile, @@ -356,6 +357,10 @@ {- File containing a log of recently accessed views. -} gitAnnexViewLog :: Git.Repo -> FilePath gitAnnexViewLog r = gitAnnexDir r "viewlog" + +{- List of refs that have already been merged into the git-annex branch. -} +gitAnnexMergedRefs :: Git.Repo -> FilePath +gitAnnexMergedRefs r = gitAnnexDir r "mergedrefs" {- List of refs that should not be merged into the git-annex branch. -} gitAnnexIgnoredRefs :: Git.Repo -> FilePath diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} +{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-} module Annex.NumCopies ( module Types.NumCopies, @@ -163,6 +163,9 @@ cont v `catchNonAsync` (throw . DropException) a `M.catches` [ M.Handler (\ (e :: AsyncException) -> throwM e) +#if MIN_VERSION_base(4,7,0) + , M.Handler (\ (e :: SomeAsyncException) -> throwM e) +#endif , M.Handler (\ (DropException e') -> throwM e') , M.Handler (\ (_e :: SomeException) -> fallback) ] diff --git a/Annex/Version.hs b/Annex/Version.hs --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -55,6 +55,9 @@ versionSupportsAdjustedBranch :: Annex Bool versionSupportsAdjustedBranch = versionSupportsUnlockedPointers +versionUsesKeysDatabase :: Annex Bool +versionUsesKeysDatabase = versionSupportsUnlockedPointers + setVersion :: Version -> Annex () setVersion = setConfig versionField diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -341,15 +341,31 @@ {- This hostname is specific to a given repository on the ssh host, - so it is based on the real hostname, the username, and the directory. - - - The mangled hostname has the form "git-annex-realhostname-username-port_dir". - - The only use of "-" is to separate the parts shown; this is necessary - - to allow unMangleSshHostName to work. Any unusual characters in the - - username or directory are url encoded, except using "." rather than "%" + - The mangled hostname has the form: + - "git-annex-realhostname-username_port_dir" + - Note that "-" is only used in the realhostname and as a separator; + - this is necessary to allow unMangleSshHostName to work. + - + - Unusual characters are url encoded, but using "." rather than "%" - (the latter has special meaning to ssh). + - + - In the username and directory, unusual characters are any + - non-alphanumerics, other than "_" + - + - The real hostname is not normally encoded at all. This is done for + - backwards compatability and to avoid unnecessary ugliness in the + - filename. However, when it contains special characters + - (notably ":" which cannot be used on some filesystems), it is url + - encoded. To indicate it was encoded, the mangled hostname + - has the form + - "git-annex-.encodedhostname-username_port_dir" -} mangleSshHostName :: SshData -> String -mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata) - ++ "-" ++ escape extra +mangleSshHostName sshdata = intercalate "-" + [ "git-annex" + , escapehostname (T.unpack (sshHostName sshdata)) + , escape extra + ] where extra = intercalate "_" $ map T.unpack $ catMaybes [ sshUserName sshdata @@ -361,12 +377,18 @@ | c == '_' = True | otherwise = False escape s = replace "%" "." $ escapeURIString safe s + escapehostname s + | all (\c -> c == '.' || safe c) s = s + | otherwise = '.' : escape s {- Extracts the real hostname from a mangled ssh hostname. -} unMangleSshHostName :: String -> String unMangleSshHostName h = case split "-" h of - ("git":"annex":rest) -> intercalate "-" (beginning rest) + ("git":"annex":rest) -> unescape (intercalate "-" (beginning rest)) _ -> h + where + unescape ('.':s) = unEscapeString (replace "." "%" s) + unescape s = s {- Does ssh have known_hosts data for a hostname? -} knownHost :: Text -> IO Bool diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -17,17 +17,15 @@ import qualified Remote import qualified Git import Config.Files -import Utility.FileMode import Logs.Trust import Logs.Remote import Logs.PreferredContent import Types.StandardGroups import Annex.UUID +import Command.Uninit (prepareRemoveAnnexDir) -import System.IO.HVFS (SystemFS(..)) import qualified Data.Text as T import qualified Data.Map as M -import System.Path notCurrentRepo :: UUID -> Handler Html -> Handler Html notCurrentRepo uuid a = do @@ -99,12 +97,8 @@ rs <- syncRemotes <$> getDaemonStatus mapM_ (\r -> changeSyncable (Just r) False) rs - {- Make all directories writable and files writable - - so all annexed content can be deleted. -} - liftIO $ do - recurseDir SystemFS dir - >>= mapM_ (void . tryIO . allowWrite) - removeDirectoryRecursive =<< absPath dir + liftAnnex $ prepareRemoveAnnexDir dir + liftIO $ removeDirectoryRecursive =<< absPath dir redirect ShutdownConfirmedR _ -> $(widgetFile "configurators/delete/currentrepository") diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -79,9 +79,6 @@ #ifdef WITH_MAGICMIME , "MagicMime" #endif -#ifdef WITH_EKG - , "EKG" -#endif -- Always enabled now, but users may be used to seeing these flags -- listed. , "Feeds" diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,38 @@ +git-annex (6.20160619) unstable; urgency=medium + + * get, drop: Add --batch and --json options. + * testremote: Fix crash when testing a freshly made external special remote. + * Remove unnecessary rpaths in the git-annex binary, but only when + it's built using make, not cabal. + This speeds up git-annex startup time by around 50%. + * Speed up startup time by caching the refs that have been merged into + the git-annex branch. + This can speed up git-annex commands by as much as a second, + depending on the number of remotes. + * fsck: Fix a reversion in direct mode fsck of a file that is + present when the location log thinks it is not. Reversion introduced + in version 5.20151208. + * uninit: Fix crash due to trying to write to deleted keys db. + Reversion introduced by v6 mode support, affects v5 too. + * Fix a similar crash when the webapp is used to delete a repository. + * Support checking presence of content at a http url that redirects to + a ftp url. + * log: Added --all option. + * New url for git-remote-gcrypt, now maintained by spwhitton. + * webapp: Don't allow deleting a remote that has syncing disabled, + as such a deletion will never finish. + Thanks, Farhan Kathawala. + * webapp: Escape unusual characters in ssh hostnames when generating + mangled hostnames. This allows IPv6 addresses to be used on filesystems + not supporting : in filenames. + * Avoid any access to keys database in v5 mode repositories, which + are not supposed to use that database. + * Remove the EKG build flag, since Gentoo for some reason decided to + enable this flag, depsite it not being intended for production use and + so disabled by default. + + -- Joey Hess Tue, 19 Jul 2016 14:17:54 -0400 + git-annex (6.20160613) unstable; urgency=medium * Improve SHA*E extension extraction code. diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -32,7 +32,7 @@ Copyright: 2007 Henrik Nyh 2010 Joey Hess 2013 John Lawrence -License: other +License: icon-license Free to modify and redistribute with due credit, and obviously free to use. Files: Annex/DirHashes.hs @@ -97,7 +97,7 @@ Files: Logs/Line.hs Copyright: 2001, The University Court of the University of Glasgow. -License: other +License: ghc-license All rights reserved. . Redistribution and use in source and binary forms, with or without diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -119,9 +119,6 @@ #ifdef WITH_BENCHMARK import qualified Command.Benchmark #endif -#ifdef WITH_EKG -import System.Remote.Monitoring -#endif cmds :: Parser TestOptions -> Maybe TestRunner -> [Command] cmds testoptparser testrunner = @@ -232,11 +229,7 @@ ] run :: Parser TestOptions -> Maybe TestRunner -> [String] -> IO () -run testoptparser testrunner args = do -#ifdef WITH_EKG - _ <- forkServer "localhost" 4242 -#endif - go envmodes +run testoptparser testrunner args = go envmodes where go [] = dispatch True args (cmds testoptparser testrunner) diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -23,7 +23,7 @@ import qualified Data.Set as S cmd :: Command -cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ +cmd = withGlobalOptions (jobsOption : jsonOption : annexedMatchingOptions) $ command "drop" SectionCommon "remove content of files from repository" paramPaths (seek <$$> optParser) @@ -33,6 +33,7 @@ , dropFrom :: Maybe (DeferredParse Remote) , autoMode :: Bool , keyOptions :: Maybe KeyOptions + , batchOption :: BatchMode } optParser :: CmdParamsDesc -> Parser DropOptions @@ -41,6 +42,7 @@ <*> optional parseDropFromOption <*> parseAutoOption <*> optional (parseKeyOptions False) + <*> parseBatchOption parseDropFromOption :: Parser (DeferredParse Remote) parseDropFromOption = parseRemoteOption $ strOption @@ -51,10 +53,14 @@ seek :: DropOptions -> CommandSeek seek o = allowConcurrentOutput $ - withKeyOptions (keyOptions o) (autoMode o) - (startKeys o) - (withFilesInGit $ whenAnnexed $ start o) - (dropFiles o) + case batchOption o of + Batch -> batchInput Right (batchCommandAction . go) + NoBatch -> withKeyOptions (keyOptions o) (autoMode o) + (startKeys o) + (withFilesInGit go) + (dropFiles o) + where + go = whenAnnexed $ start o start :: DropOptions -> FilePath -> Key -> CommandStart start o file key = start' o key (Just file) diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -214,11 +214,11 @@ - in this repository only. -} verifyLocationLog :: Key -> KeyStatus -> String -> Annex Bool verifyLocationLog key keystatus desc = do + direct <- isDirect obj <- calcRepo $ gitAnnexLocation key - present <- if isKeyUnlocked keystatus + present <- if not direct && isKeyUnlocked keystatus then liftIO (doesFileExist obj) else inAnnex key - direct <- isDirect u <- getUUID {- Since we're checking that a key's object file is present, throw diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -16,7 +16,7 @@ import qualified Command.Move cmd :: Command -cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ +cmd = withGlobalOptions (jobsOption : jsonOption : annexedMatchingOptions) $ command "get" SectionCommon "make content of annexed files available" paramPaths (seek <$$> optParser) @@ -26,6 +26,7 @@ , getFrom :: Maybe (DeferredParse Remote) , autoMode :: Bool , keyOptions :: Maybe KeyOptions + , batchOption :: BatchMode } optParser :: CmdParamsDesc -> Parser GetOptions @@ -34,14 +35,18 @@ <*> optional parseFromOption <*> parseAutoOption <*> optional (parseKeyOptions True) + <*> parseBatchOption seek :: GetOptions -> CommandSeek seek o = allowConcurrentOutput $ do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) - withKeyOptions (keyOptions o) (autoMode o) - (startKeys from) - (withFilesInGit $ whenAnnexed $ start o from) - (getFiles o) + let go = whenAnnexed $ start o from + case batchOption o of + Batch -> batchInput Right (batchCommandAction . go) + NoBatch -> withKeyOptions (keyOptions o) (autoMode o) + (startKeys from) + (withFilesInGit go) + (getFiles o) start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart start o from file key = start' expensivecheck from key (Just file) diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2012 Joey Hess + - Copyright 2012, 2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,7 +11,6 @@ import qualified Data.Set as S import qualified Data.Map as M -import qualified Data.ByteString.Lazy.Char8 as L import Data.Char import Data.Time.Clock.POSIX import Data.Time @@ -21,8 +20,7 @@ import Command import Logs -import qualified Logs.Presence -import Annex.CatFile +import Logs.Location import qualified Annex.Branch import qualified Git import Git.Command @@ -33,10 +31,14 @@ { changetime :: POSIXTime , oldref :: Git.Ref , newref :: Git.Ref + , changekey :: Key } + deriving (Show) -type Outputter = Bool -> POSIXTime -> [UUID] -> Annex () +data LogChange = Added | Removed +type Outputter = LogChange -> POSIXTime -> [UUID] -> Annex () + cmd :: Command cmd = withGlobalOptions annexedMatchingOptions $ command "log" SectionQuery "shows location log" @@ -44,6 +46,7 @@ data LogOptions = LogOptions { logFiles :: CmdParams + , allOption :: Bool , rawDateOption :: Bool , gourceOption :: Bool , passthruOptions :: [CommandParam] @@ -53,6 +56,11 @@ optParser desc = LogOptions <$> cmdParams desc <*> switch + ( long "all" + <> short 'A' + <> help "display location log changes to all files" + ) + <*> switch ( long "raw-date" <> help "display seconds from unix epoch" ) @@ -81,71 +89,106 @@ seek o = do m <- Remote.uuidDescriptions zone <- liftIO getCurrentTimeZone - withFilesInGit (whenAnnexed $ start m zone o) (logFiles o) + let outputter = mkOutputter m zone o + case (logFiles o, allOption o) of + (fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) fs + ([], True) -> commandAction (startAll o outputter) + (_, True) -> error "Cannot specify both files and --all" -start - :: M.Map UUID String - -> TimeZone - -> LogOptions - -> FilePath - -> Key - -> CommandStart -start m zone o file key = do - (ls, cleanup) <- getLog key (passthruOptions o) - showLog output (readLog ls) +start :: LogOptions -> (FilePath -> Outputter) -> FilePath -> Key -> CommandStart +start o outputter file key = do + (changes, cleanup) <- getKeyLog key (passthruOptions o) + showLogIncremental (outputter file) changes void $ liftIO cleanup stop - where - output - | rawDateOption o = normalOutput lookupdescription file show - | gourceOption o = gourceOutput lookupdescription file - | otherwise = normalOutput lookupdescription file (showTimeStamp zone) - lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m -showLog :: Outputter -> [RefChange] -> Annex () -showLog outputter ps = do +startAll :: LogOptions -> (String -> Outputter) -> CommandStart +startAll o outputter = do + (changes, cleanup) <- getAllLog (passthruOptions o) + showLog outputter changes + void $ liftIO cleanup + stop + +{- Displays changes made. Only works when all the RefChanges are for the + - same key. The method is to compare each value with the value + - after it in the list, which is the old version of the value. + - + - This ncessarily buffers the whole list, so does not stream. + - But, the number of location log changes for a single key tends to be + - fairly small. + - + - This minimizes the number of reads from git; each logged value is read + - only once. + - + - This also generates subtly better output when the git-annex branch + - got diverged. + -} +showLogIncremental :: Outputter -> [RefChange] -> Annex () +showLogIncremental outputter ps = do sets <- mapM (getset newref) ps previous <- maybe (return genesis) (getset oldref) (lastMaybe ps) - sequence_ $ compareChanges outputter $ sets ++ [previous] + let l = sets ++ [previous] + let changes = map (\((t, new), (_, old)) -> (t, new, old)) + (zip l (drop 1 l)) + sequence_ $ compareChanges outputter changes where genesis = (0, S.empty) getset select change = do - s <- S.fromList <$> get (select change) + s <- S.fromList <$> loggedLocationsRef (select change) return (changetime change, s) - get ref = map toUUID . Logs.Presence.getLog . L.unpack <$> - catObject ref +{- Displays changes made. Streams, and can display changes affecting + - different keys, but does twice as much reading of logged values + - as showLogIncremental. -} +showLog :: (String -> Outputter) -> [RefChange] -> Annex () +showLog outputter cs = forM_ cs $ \c -> do + let keyname = key2file (changekey c) + new <- S.fromList <$> loggedLocationsRef (newref c) + old <- S.fromList <$> loggedLocationsRef (oldref c) + sequence_ $ compareChanges (outputter keyname) + [(changetime c, new, old)] + +mkOutputter :: M.Map UUID String -> TimeZone -> LogOptions -> FilePath -> Outputter +mkOutputter m zone o file + | rawDateOption o = normalOutput lookupdescription file show + | gourceOption o = gourceOutput lookupdescription file + | otherwise = normalOutput lookupdescription file (showTimeStamp zone) + where + lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m + normalOutput :: (UUID -> String) -> FilePath -> (POSIXTime -> String) -> Outputter -normalOutput lookupdescription file formattime present ts us = +normalOutput lookupdescription file formattime logchange ts us = liftIO $ mapM_ (putStrLn . format) us where time = formattime ts - addel = if present then "+" else "-" + addel = case logchange of + Added -> "+" + Removed -> "-" format u = unwords [ addel, time, file, "|", fromUUID u ++ " -- " ++ lookupdescription u ] gourceOutput :: (UUID -> String) -> FilePath -> Outputter -gourceOutput lookupdescription file present ts us = +gourceOutput lookupdescription file logchange ts us = liftIO $ mapM_ (putStrLn . intercalate "|" . format) us where time = takeWhile isDigit $ show ts - addel = if present then "A" else "M" + addel = case logchange of + Added -> "A" + Removed -> "M" format u = [ time, lookupdescription u, addel, file ] -{- Generates a display of the changes (which are ordered with newest first), - - by comparing each change with the previous change. +{- Generates a display of the changes. - Uses a formatter to generate a display of items that are added and - removed. -} -compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b] -compareChanges format changes = concatMap diff $ zip changes (drop 1 changes) +compareChanges :: Ord a => (LogChange -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a, S.Set a)] -> [b] +compareChanges format changes = concatMap diff changes 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 + diff (ts, new, old) = + [ format Added ts $ S.toList $ S.difference new old + , format Removed ts $ S.toList $ S.difference old new + ] -{- Gets the git log for a given location log file. +{- Streams the git log for a given key's 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 @@ -156,42 +199,75 @@ - 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. -} -getLog :: Key -> [CommandParam] -> Annex ([String], IO Bool) -getLog key os = do +getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool) +getKeyLog key os = do top <- fromRepo Git.repoPath p <- liftIO $ relPathCwdToFile top config <- Annex.getGitConfig let logfile = p locationLogFile config key - inRepo $ pipeNullSplit $ + getGitLog [logfile] (Param "--remove-empty" : os) + +{- Streams the git log for all git-annex branch changes. -} +getAllLog :: [CommandParam] -> Annex ([RefChange], IO Bool) +getAllLog = getGitLog [] + +getGitLog :: [FilePath] -> [CommandParam] -> Annex ([RefChange], IO Bool) +getGitLog fs os = do + (ls, cleanup) <- inRepo $ pipeNullSplit $ [ Param "log" , Param "-z" , Param "--pretty=format:%ct" , Param "--raw" , Param "--abbrev=40" - , Param "--remove-empty" ] ++ os ++ [ Param $ Git.fromRef Annex.Branch.fullname , Param "--" - , Param logfile - ] + ] ++ map Param fs + return (parseGitRawLog ls, cleanup) -readLog :: [String] -> [RefChange] -readLog = mapMaybe (parse . lines) +-- Parses chunked git log --raw output, which looks something like: +-- +-- [ "timestamp\n:changeline" +-- , "logfile" +-- , "" +-- , "timestamp\n:changeline" +-- , "logfile" +-- , ":changeline" +-- , "logfile" +-- , "" +-- ] +-- +-- The timestamp is not included before all changelines, so +-- keep track of the most recently seen timestamp. +parseGitRawLog :: [String] -> [RefChange] +parseGitRawLog = parse epoch where - parse (ts:raw:[]) = let (old, new) = parseRaw raw in - Just RefChange - { changetime = parseTimeStamp ts - , oldref = old - , newref = new - } - parse _ = Nothing + epoch = toEnum 0 :: POSIXTime + parse oldts ([]:rest) = parse oldts rest + parse oldts (c1:c2:rest) = case mrc of + Just rc -> rc : parse ts rest + Nothing -> parse ts (c2:rest) + where + (ts, cl) = case separate (== '\n') c1 of + (cl', []) -> (oldts, cl') + (tss, cl') -> (parseTimeStamp tss, cl') + mrc = do + (old, new) <- parseRawChangeLine cl + key <- locationLogFileKey c2 + return $ RefChange + { changetime = ts + , oldref = old + , newref = new + , changekey = key + } + parse _ _ = [] --- Parses something like ":100644 100644 oldsha newsha M" -parseRaw :: String -> (Git.Ref, Git.Ref) -parseRaw l = go $ words l +-- Parses something like "100644 100644 oldsha newsha M" +parseRawChangeLine :: String -> Maybe (Git.Ref, Git.Ref) +parseRawChangeLine = go . words where - go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha) - go _ = error $ "unable to parse git log output: " ++ l + go (_:_:oldsha:newsha:_) = Just (Git.Ref oldsha, Git.Ref newsha) + go _ = Nothing parseTimeStamp :: String -> POSIXTime parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") . diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -13,6 +13,7 @@ import qualified Git.Command import qualified Command.Unannex import qualified Annex.Branch +import qualified Database.Keys import Annex.Content import Annex.Init import Utility.FileMode @@ -61,7 +62,7 @@ annexdir <- fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir leftovers <- removeUnannexed =<< getKeysPresent InAnnex - liftIO $ prepareRemoveAnnexDir annexdir + prepareRemoveAnnexDir annexdir if null leftovers then liftIO $ removeDirectoryRecursive annexdir else error $ unlines @@ -89,9 +90,17 @@ liftIO exitSuccess {- Turn on write bits in all remaining files in the annex directory, in - - preparation for removal. -} -prepareRemoveAnnexDir :: FilePath -> IO () -prepareRemoveAnnexDir annexdir = + - preparation for removal. + - + - Also closes sqlite databases that might be in the directory, + - to avoid later failure to write any cached changes to them. -} +prepareRemoveAnnexDir :: FilePath -> Annex () +prepareRemoveAnnexDir annexdir = do + Database.Keys.closeDb + liftIO $ prepareRemoveAnnexDir' annexdir + +prepareRemoveAnnexDir' :: FilePath -> IO () +prepareRemoveAnnexDir' annexdir = recurseDir SystemFS annexdir >>= mapM_ (void . tryIO . allowWrite) {- Keys that were moved out of the annex have a hard link still in the diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -27,6 +27,7 @@ import qualified Database.Queue as H import Annex.Locations import Annex.Common hiding (delete) +import Annex.Version (versionUsesKeysDatabase) import qualified Annex import Annex.Perms import Annex.LockFile @@ -101,7 +102,10 @@ where go (Just h) = pure h go Nothing = do - h <- liftIO newDbHandle + h <- ifM versionUsesKeysDatabase + ( liftIO newDbHandle + , liftIO unavailableDbHandle + ) Annex.changeState $ \s -> s { Annex.keysdbhandle = Just h } return h diff --git a/Database/Keys/Handle.hs b/Database/Keys/Handle.hs --- a/Database/Keys/Handle.hs +++ b/Database/Keys/Handle.hs @@ -8,6 +8,7 @@ module Database.Keys.Handle ( DbHandle, newDbHandle, + unavailableDbHandle, DbState(..), withDbState, flushDbQueue, @@ -32,6 +33,9 @@ newDbHandle :: IO DbHandle newDbHandle = DbHandle <$> newMVar DbClosed + +unavailableDbHandle :: IO DbHandle +unavailableDbHandle = DbHandle <$> newMVar DbUnavailable -- Runs an action on the state of the handle, which can change its state. -- The MVar is empty while the action runs, which blocks other users diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -1,6 +1,6 @@ {- git-remote-gcrypt support - - - https://github.com/blake2-ppc/git-remote-gcrypt + - https://spwhitton.name/tech/code/git-remote-gcrypt/ - - Copyright 2013 Joey Hess - diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -19,6 +19,7 @@ logChange, loggedLocations, loggedLocationsHistorical, + loggedLocationsRef, isKnownKey, checkDead, setDead, @@ -31,10 +32,12 @@ import Logs import Logs.Presence import Annex.UUID -import Git.Types (RefDate) +import Annex.CatFile +import Git.Types (RefDate, Ref) import qualified Annex import Data.Time.Clock +import qualified Data.ByteString.Lazy.Char8 as L {- Log a change in the presence of a key's value in current repository. -} logStatus :: Key -> LogStatus -> Annex () @@ -60,6 +63,10 @@ {- Gets the location log on a particular date. -} loggedLocationsHistorical :: RefDate -> Key -> Annex [UUID] loggedLocationsHistorical = getLoggedLocations . historicalLogInfo + +{- Gets the locations contained in a git ref. -} +loggedLocationsRef :: Ref -> Annex [UUID] +loggedLocationsRef ref = map toUUID . getLog . L.unpack <$> catObject ref getLoggedLocations :: (FilePath -> Annex [String]) -> Key -> Annex [UUID] getLoggedLocations getter key = do diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -461,16 +461,17 @@ - external special remote every time time just to ask it what its - cost is. -} getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost -getCost external r gc = go =<< remoteCost' gc +getCost external r gc = catchNonAsync (go =<< remoteCost' gc) (const defcst) where go (Just c) = return c go Nothing = do c <- handleRequest external GETCOST Nothing $ \req -> case req of COST c -> Just $ return c - UNSUPPORTED_REQUEST -> Just $ return expensiveRemoteCost + UNSUPPORTED_REQUEST -> Just defcst _ -> Nothing setRemoteCost r c return c + defcst = return expensiveRemoteCost {- Caches the availability in the git config to avoid needing to start up an - external special remote every time time just to ask it what its @@ -480,15 +481,17 @@ - globally available is the default. -} getAvailability :: External -> Git.Repo -> RemoteGitConfig -> Annex Availability -getAvailability external r gc = maybe query return (remoteAnnexAvailability gc) +getAvailability external r gc = + maybe (catchNonAsync query (const defavail)) return (remoteAnnexAvailability gc) where query = do avail <- handleRequest external GETAVAILABILITY Nothing $ \req -> case req of AVAILABILITY avail -> Just $ return avail - UNSUPPORTED_REQUEST -> Just $ return GloballyAvailable + UNSUPPORTED_REQUEST -> Just defavail _ -> Nothing setRemoteAvailability r avail return avail + defavail = return GloballyAvailable claimurl :: External -> URLString -> Annex Bool claimurl external url = diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -30,7 +30,7 @@ import qualified Remote.Helper.Chunked.Legacy as Legacy import Creds import Utility.Metered -import Utility.Url (URLString) +import Utility.Url (URLString, matchStatusCodeException) import Annex.UUID import Remote.WebDAV.DavLocation @@ -269,12 +269,6 @@ (getPropsM >> ispresent True) (const $ ispresent False) ispresent = return . Right - -matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException -matchStatusCodeException want e@(StatusCodeException s _ _) - | want s = Just e - | otherwise = Nothing -matchStatusCodeException _ _ = Nothing -- Ignores any exceptions when performing a DAV action. safely :: DAVT IO a -> DAVT IO (Maybe a) diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1837,7 +1837,7 @@ cleanup' :: Bool -> FilePath -> IO () cleanup' final dir = whenM (doesDirectoryExist dir) $ do - Command.Uninit.prepareRemoveAnnexDir dir + Command.Uninit.prepareRemoveAnnexDir' dir -- This sometimes fails on Windows, due to some files -- being still opened by a subprocess. catchIO (removeDirectoryRecursive dir) $ \e -> diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( @@ -28,6 +28,11 @@ import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) +import Control.Exception (SomeAsyncException) +#endif +#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) @@ -74,6 +79,11 @@ catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` [ M.Handler (\ (e :: AsyncException) -> throwM e) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) + , M.Handler (\ (e :: SomeAsyncException) -> throwM e) +#endif +#endif , M.Handler (\ (e :: SomeException) -> onerr e) ] diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -25,7 +25,8 @@ assumeUrlExists, download, downloadQuiet, - parseURIRelaxed + parseURIRelaxed, + matchStatusCodeException, ) where import Common @@ -126,6 +127,7 @@ , urlSize :: Maybe Integer , urlSuggestedFile :: Maybe FilePath } + deriving (Show) assumeUrlExists :: UrlInfo assumeUrlExists = UrlInfo True Nothing Nothing @@ -135,7 +137,14 @@ getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo getUrlInfo url uo = case parseURIRelaxed url of Just u -> case parseUrl (show u) of - Just req -> existsconduit req `catchNonAsync` const dne + Just req -> catchJust + -- When http redirects to a protocol which + -- conduit does not support, it will throw + -- a StatusCodeException with found302. + (matchStatusCodeException (== found302)) + (existsconduit req) + (const (existscurl u)) + `catchNonAsync` (const dne) -- http-conduit does not support file:, ftp:, etc urls, -- so fall back to reading files and using curl. Nothing @@ -147,18 +156,7 @@ sz <- getFileSize' f stat found (Just sz) Nothing Nothing -> dne - | Build.SysConfig.curl -> do - output <- catchDefaultIO "" $ - readProcess "curl" $ toCommand curlparams - let len = extractlencurl output - let good = found len Nothing - case lastMaybe (lines output) of - Just ('2':_:_) -> good - -- don't try to parse ftp status - -- codes; if curl got a length, - -- it's good - _ | "ftp" `isInfixOf` uriScheme u && isJust len -> good - _ -> dne + | Build.SysConfig.curl -> existscurl u | otherwise -> dne Nothing -> dne where @@ -201,6 +199,23 @@ liftIO $ closeManager mgr return ret + existscurl u = do + output <- catchDefaultIO "" $ + readProcess "curl" $ toCommand curlparams + let len = extractlencurl output + let good = found len Nothing + let isftp = or + [ "ftp" `isInfixOf` uriScheme u + -- Check to see if http redirected to ftp. + , "Location: ftp://" `isInfixOf` output + ] + case lastMaybe (lines output) of + Just ('2':_:_) -> good + -- don't try to parse ftp status codes; if curl + -- got a length, it's good + _ | isftp && isJust len -> good + _ -> dne + -- Parse eg: attachment; filename="fname.ext" -- per RFC 2616 contentDispositionFilename :: String -> Maybe FilePath @@ -324,3 +339,13 @@ hUserAgent :: CI.CI B.ByteString hUserAgent = "User-Agent" #endif + +{- Use with eg: + - + - > catchJust (matchStatusCodeException (== notFound404)) + -} +matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException +matchStatusCodeException want e@(StatusCodeException s _ _) + | want s = Just e + | otherwise = Nothing +matchStatusCodeException _ _ = Nothing diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn --- a/doc/git-annex-drop.mdwn +++ b/doc/git-annex-drop.mdwn @@ -61,6 +61,16 @@ when git-annex has to contact remotes to check if it can drop files. For example: `-J4` +* `--batch` + + Enables batch mode, in which lines containing names of files to drop + are read from stdin. + +* `--json` + + Enable JSON output. This is intended to be parsed by programs that use + git-annex. Each line of output is a JSON object. + # SEE ALSO [[git-annex]](1) diff --git a/doc/git-annex-get.mdwn b/doc/git-annex-get.mdwn --- a/doc/git-annex-get.mdwn +++ b/doc/git-annex-get.mdwn @@ -45,6 +45,11 @@ as git-annex does not know the associated file, and the associated file may not even be in the current git working directory. +* file matching options + + The [[git-annex-matching-options]](1) + can be used to specify files to get. + * `--all` Rather than specifying a filename or path to get, this option can be @@ -60,10 +65,23 @@ Use this option to get a specified key. -* file matching options - - The [[git-annex-matching-options]](1) - can be used to specify files to get. +* `--batch` + + Enables batch mode, in which lines containing names of files to get + are read from stdin. + + As each specified file is processed, the usual progress output is + displayed. If the specified file's content is already present, or + it is not an annexed file, a blank line is output in response instead. + + Since the usual progress output while getting a file is verbose and not + machine-parseable, you may want to use --json in combination with + --batch. + +* `--json` + + Enable JSON output. This is intended to be parsed by programs that use + git-annex. Each line of output is a JSON object. # SEE ALSO diff --git a/doc/git-annex-log.mdwn b/doc/git-annex-log.mdwn --- a/doc/git-annex-log.mdwn +++ b/doc/git-annex-log.mdwn @@ -34,6 +34,12 @@ The [[git-annex-matching-options]](1) can be used to specify files to act on. +* `--all` + + Shows location log changes to all files, with the most recent changes first. + In this mode, the names of files are not available and keys are displayed + instead. + # SEE ALSO [[git-annex]](1) diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20160613 +Version: 6.20160619 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -292,10 +292,6 @@ Flag ConcurrentOutput Description: Use concurrent-output library -Flag EKG - Description: Enable use of EKG to monitor git-annex as it runs (at http://localhost:4242/) - Default: False - Flag Benchmark Description: Enable benchmarking Default: False @@ -470,11 +466,6 @@ Build-Depends: concurrent-output (>= 1.6) CPP-Options: -DWITH_CONCURRENTOUTPUT - if flag(EKG) - Build-Depends: ekg - GHC-Options: -with-rtsopts=-T - CPP-Options: -DWITH_EKG - if flag(Benchmark) Build-Depends: criterion, deepseq CPP-Options: -DWITH_BENCHMARK diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -16,7 +16,6 @@ xmpp: false android: false androidsplice: false - ekg: false packages: - '.' resolver: lts-5.18 diff --git a/templates/configurators/needgcrypt.hamlet b/templates/configurators/needgcrypt.hamlet --- a/templates/configurators/needgcrypt.hamlet +++ b/templates/configurators/needgcrypt.hamlet @@ -4,7 +4,7 @@ Need git-remote-gcrypt

To encrypt git repositories, you need to install # - + git-remote-gcrypt

diff --git a/templates/repolist.hamlet b/templates/repolist.hamlet --- a/templates/repolist.hamlet +++ b/templates/repolist.hamlet @@ -60,6 +60,11 @@ \ Sync now + $if notSyncing actions + + + \ Delete + $else \ Delete