packages feed

git-annex 6.20160613 → 6.20160619

raw patch · 31 files changed

+450/−191 lines, 31 filesdep −ekg

Dependencies removed: ekg

Files

Annex/Branch.hs view
@@ -1,6 +1,6 @@ {- management of the git-annex branch  -- - Copyright 2011-2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>  -  - 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)
Annex/Locations.hs view
@@ -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
Annex/NumCopies.hs view
@@ -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) 				]
Annex/Version.hs view
@@ -55,6 +55,9 @@ versionSupportsAdjustedBranch :: Annex Bool versionSupportsAdjustedBranch = versionSupportsUnlockedPointers +versionUsesKeysDatabase :: Annex Bool+versionUsesKeysDatabase = versionSupportsUnlockedPointers+ setVersion :: Version -> Annex () setVersion = setConfig versionField
Assistant/Ssh.hs view
@@ -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
Assistant/WebApp/Configurators/Delete.hs view
@@ -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")
BuildFlags.hs view
@@ -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"
CHANGELOG view
@@ -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 <id@joeyh.name>  Tue, 19 Jul 2016 14:17:54 -0400+ git-annex (6.20160613) unstable; urgency=medium    * Improve SHA*E extension extraction code.
@@ -32,7 +32,7 @@ Copyright: 2007 Henrik Nyh <http://henrik.nyh.se/>            2010 Joey Hess <id@joeyh.name> 	   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
CmdLine/GitAnnex.hs view
@@ -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)
Command/Drop.hs view
@@ -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)
Command/Fsck.hs view
@@ -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
Command/Get.hs view
@@ -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)
Command/Log.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012, 2016 Joey Hess <id@joeyh.name>  -  - 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") .
Command/Uninit.hs view
@@ -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
Database/Keys.hs view
@@ -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
Database/Keys/Handle.hs view
@@ -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
Git/GCrypt.hs view
@@ -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 <id@joeyh.name>  -
Logs/Location.hs view
@@ -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
Remote/External.hs view
@@ -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 =
Remote/WebDAV.hs view
@@ -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)
Test.hs view
@@ -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 ->
Utility/Exception.hs view
@@ -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) 	]
Utility/Url.hs view
@@ -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
doc/git-annex-drop.mdwn view
@@ -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)
doc/git-annex-get.mdwn view
@@ -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
doc/git-annex-log.mdwn view
@@ -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)
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20160613+Version: 6.20160619 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -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
stack.yaml view
@@ -16,7 +16,6 @@     xmpp: false     android: false     androidsplice: false-    ekg: false packages: - '.' resolver: lts-5.18
templates/configurators/needgcrypt.hamlet view
@@ -4,7 +4,7 @@       Need git-remote-gcrypt     <p>       To encrypt git repositories, you need to install #-      <a href="https://github.com/joeyh/git-remote-gcrypt">+      <a href="https://spwhitton.name/tech/code/git-remote-gcrypt/">         git-remote-gcrypt     <p>       <a .btn .btn-primary .btn-lg href="">
templates/repolist.hamlet view
@@ -60,6 +60,11 @@                       <a href="@{SyncNowRepositoryR $ asUUID repoid}">                         <span .glyphicon .glyphicon-refresh>                         \ Sync now+                    $if notSyncing actions+                      <a title="Not allowed when syncing is disabled." href="#" style="color: #999;">+                        <span .glyphicon .glyphicon-trash>+                        \ Delete+                    $else                       <a href="@{DeleteRepositoryR $ asUUID repoid}">                         <span .glyphicon .glyphicon-trash>                         \ Delete