packages feed

git-annex 6.20170818 → 6.20170925

raw patch · 75 files changed

+2253/−408 lines, 75 files

Files

Annex/Branch.hs view
@@ -1,6 +1,6 @@ {- management of the git-annex branch  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -21,9 +21,11 @@ 	maybeChange, 	commit, 	forceCommit,+	getBranch, 	files,-	withIndex,+	graftTreeish, 	performTransitions,+	withIndex, ) where  import qualified Data.ByteString.Lazy as L@@ -45,6 +47,7 @@ import qualified Git.Branch import qualified Git.UnionMerge import qualified Git.UpdateIndex+import qualified Git.Tree import Git.LsTree (lsTreeParams) import qualified Git.HashObject import Annex.HashObject@@ -613,3 +616,25 @@ 	parse l =  		let (s, b) = separate (== '\t') l 		in (Ref s, Ref b)++{- Grafts a treeish into the branch at the specified location,+ - and then removes it. This ensures that the treeish won't get garbage+ - collected, and will always be available as long as the git-annex branch+ - is available. -}+graftTreeish :: Git.Ref -> TopFilePath -> Annex ()+graftTreeish treeish graftpoint = lockJournal $ \jl -> do+	branchref <- getBranch+	updateIndex jl branchref+	Git.Tree.Tree t <- inRepo $ Git.Tree.getTree branchref+	t' <- inRepo $ Git.Tree.recordTree $ Git.Tree.Tree $+		Git.Tree.RecordedSubTree graftpoint treeish [] : t+	c <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit+		"graft" [branchref] t'+	origtree <- inRepo $ Git.Tree.recordTree (Git.Tree.Tree t)+	c' <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit+		"graft cleanup" [c] origtree+	inRepo $ Git.Branch.update' fullname c'+	-- The tree in c' is the same as the tree in branchref,+	-- and the index was updated to that above, so it's safe to+	-- say that the index contains c'.+	setIndexSha c'
Annex/Content.hs view
@@ -354,8 +354,12 @@ shouldVerify AlwaysVerify = return True shouldVerify NoVerify = return False shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig-shouldVerify (RemoteVerify r) = shouldVerify DefaultVerify-	<&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r))+shouldVerify (RemoteVerify r) = +	(shouldVerify DefaultVerify+			<&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r)))+	-- Export remotes are not key/value stores, so always verify+	-- content from them even when verification is disabled.+	<||> Types.Remote.isExportSupported r  {- Checks if there is enough free disk space to download a key  - to its temp file.
+ Annex/Export.hs view
@@ -0,0 +1,45 @@+{- git-annex exports+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.Export where++import Annex+import Annex.CatFile+import Types.Key+import Types.Remote+import qualified Git++import qualified Data.Map as M+import Control.Applicative+import Prelude++-- An export includes both annexed files and files stored in git.+-- For the latter, a SHA1 key is synthesized.+data ExportKey = AnnexKey Key | GitKey Key+	deriving (Show, Eq, Ord)++asKey :: ExportKey -> Key+asKey (AnnexKey k) = k+asKey (GitKey k) = k++exportKey :: Git.Sha -> Annex ExportKey+exportKey sha = mk <$> catKey sha+  where+	mk (Just k) = AnnexKey k+	mk Nothing = GitKey $ Key+		{ keyName = show sha+		, keyVariety = SHA1Key (HasExt False)+		, keySize = Nothing+		, keyMtime = Nothing+		, keyChunkSize = Nothing+		, keyChunkNum = Nothing+		}++exportTree :: RemoteConfig -> Bool+exportTree c = case M.lookup "exporttree" c of+	Just "yes" -> True+	_ -> False
Annex/Init.hs view
@@ -146,32 +146,40 @@ probeCrippledFileSystem = do 	tmp <- fromRepo gitAnnexTmpMiscDir 	createAnnexDirectory tmp-	liftIO $ probeCrippledFileSystem' tmp+	probeCrippledFileSystem' tmp -probeCrippledFileSystem' :: FilePath -> IO Bool+probeCrippledFileSystem' :: FilePath -> Annex Bool #ifdef mingw32_HOST_OS probeCrippledFileSystem' _ = return True #else probeCrippledFileSystem' tmp = do 	let f = tmp </> "gaprobe"-	writeFile f ""+	liftIO $ writeFile f "" 	uncrippled <- probe f-	void $ tryIO $ allowWrite f-	removeFile f+	void $ liftIO $ tryIO $ allowWrite f+	liftIO $ removeFile f 	return $ not uncrippled   where 	probe f = catchBoolIO $ do 		let f2 = f ++ "2"-		nukeFile f2-		createSymbolicLink f f2-		nukeFile f2-		preventWrite f+		liftIO $ nukeFile f2+		liftIO $ createSymbolicLink f f2+		liftIO $ nukeFile f2+		liftIO $ preventWrite f 		-- Should be unable to write to the file, unless 		-- running as root, but some crippled 		-- filesystems ignore write bit removals.-		ifM ((== 0) <$> getRealUserID)+		ifM ((== 0) <$> liftIO getRealUserID) 			( return True-			, not <$> catchBoolIO (writeFile f "2" >> return True)+			, do+				r <- liftIO $ catchBoolIO $+					writeFile f "2" >> return True+				if r+					then do+						warning "Filesystem allows writing to files whose write bit is not set."+						return False+					else return True+ 			) #endif
Annex/Locations.hs view
@@ -36,6 +36,8 @@ 	gitAnnexFsckDbDir, 	gitAnnexFsckDbLock, 	gitAnnexFsckResultsLog,+	gitAnnexExportDbDir,+	gitAnnexExportLock, 	gitAnnexScheduleState, 	gitAnnexTransferDir, 	gitAnnexCredsDir,@@ -289,6 +291,19 @@ {- .git/annex/fsckresults/uuid is used to store results of git fscks -} gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath gitAnnexFsckResultsLog u r = gitAnnexDir r </> "fsckresults" </> fromUUID u++{- .git/annex/export/uuid/ is used to store information about+ - exports to special remotes. -}+gitAnnexExportDir :: UUID -> Git.Repo -> FilePath+gitAnnexExportDir u r = gitAnnexDir r </> "export" </> fromUUID u++{- Directory containing database used to record export info. -}+gitAnnexExportDbDir :: UUID -> Git.Repo -> FilePath+gitAnnexExportDbDir u r = gitAnnexExportDir u r </> "db"++{- Lock file for export state for a special remote. -}+gitAnnexExportLock :: UUID -> Git.Repo -> FilePath+gitAnnexExportLock u r = gitAnnexExportDbDir u r ++ ".lck"  {- .git/annex/schedulestate is used to store information about when  - scheduled jobs were last run. -}
Annex/SpecialRemote.hs view
@@ -81,7 +81,7 @@ 			(Just name, Right t) -> whenM (canenable u) $ do 				showSideAction $ "Auto enabling special remote " ++ name 				dummycfg <- liftIO dummyRemoteGitConfig-				res <- tryNonAsync $ setup t Enable (Just u) Nothing c dummycfg+				res <- tryNonAsync $ setup t (Enable c) (Just u) Nothing c dummycfg 				case res of 					Left e -> warning (show e) 					Right _ -> return ()
Assistant.hs view
@@ -18,6 +18,7 @@ import Assistant.Threads.Watcher import Assistant.Threads.Committer import Assistant.Threads.Pusher+import Assistant.Threads.Exporter import Assistant.Threads.Merger import Assistant.Threads.TransferWatcher import Assistant.Threads.Transferrer@@ -152,6 +153,8 @@ #endif 				, assist pushThread 				, assist pushRetryThread+				, assist exportThread+				, assist exportRetryThread 				, assist mergeThread 				, assist transferWatcherThread 				, assist transferPollerThread
Assistant/Commits.hs view
@@ -21,3 +21,12 @@ {- Records a commit in the channel. -} recordCommit :: Assistant () recordCommit = (atomically . flip consTList Commit) <<~ commitChan++{- Gets all unhandled export commits.+ - Blocks until at least one export commit is made. -}+getExportCommits :: Assistant [Commit]+getExportCommits = (atomically . getTList) <<~ exportCommitChan++{- Records an export commit in the channel. -}+recordExportCommit :: Assistant ()+recordExportCommit = (atomically . flip consTList Commit) <<~ exportCommitChan
Assistant/DaemonStatus.hs view
@@ -20,6 +20,7 @@ import qualified Remote import qualified Types.Remote as Remote import Config.DynamicConfig+import Annex.Export  import Control.Concurrent.STM import System.Posix.Types@@ -53,15 +54,18 @@ 	alive <- trustExclude DeadTrusted (map Remote.uuid rs) 	let good r = Remote.uuid r `elem` alive 	let syncable = filter good rs-	syncdata <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $+	contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $ 		filter (\r -> Remote.uuid r /= NoUUID) $ 		filter (not . Remote.isXMPPRemote) syncable+	let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes  	return $ \dstatus -> dstatus 		{ syncRemotes = syncable 		, syncGitRemotes = filter Remote.gitSyncableRemote syncable-		, syncDataRemotes = syncdata-		, syncingToCloudRemote = any iscloud syncdata+		, syncDataRemotes = dataremotes+		, exportRemotes = exportremotes+		, downloadRemotes = contentremotes+		, syncingToCloudRemote = any iscloud contentremotes 		}   where 	iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable
Assistant/MakeRemote.hs view
@@ -52,7 +52,7 @@ 	go Nothing = setupSpecialRemote name Rsync.remote config Nothing 		(Nothing, R.Init, Annex.SpecialRemote.newConfig name) 	go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing-		(Just u, R.Enable, c)+		(Just u, R.Enable c, c) 	config = M.fromList 		[ ("encryption", "shared") 		, ("rsyncurl", location)@@ -91,7 +91,7 @@ 	r <- Annex.SpecialRemote.findExisting name 	case r of 		Nothing -> error $ "Cannot find a special remote named " ++ name-		Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable, c)+		Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c)  setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName setupSpecialRemote = setupSpecialRemote' True
Assistant/Monad.hs view
@@ -62,7 +62,9 @@ 	, transferSlots :: TransferSlots 	, transferrerPool :: TransferrerPool 	, failedPushMap :: FailedPushMap+	, failedExportMap :: FailedPushMap 	, commitChan :: CommitChan+	, exportCommitChan :: CommitChan 	, changePool :: ChangePool 	, repoProblemChan :: RepoProblemChan 	, branchChangeHandle :: BranchChangeHandle@@ -80,6 +82,8 @@ 	<*> newTransferSlots 	<*> newTransferrerPool (checkNetworkConnections dstatus) 	<*> newFailedPushMap+	<*> newFailedPushMap+	<*> newCommitChan 	<*> newCommitChan 	<*> newChangePool 	<*> newRepoProblemChan
Assistant/Pushes.hs view
@@ -17,24 +17,21 @@ {- Blocks until there are failed pushes.  - Returns Remotes whose pushes failed a given time duration or more ago.  - (This may be an empty list.) -}-getFailedPushesBefore :: NominalDiffTime -> Assistant [Remote]-getFailedPushesBefore duration = do-	v <- getAssistant failedPushMap-	liftIO $ do-		m <- atomically $ readTMVar v-		now <- getCurrentTime-		return $ M.keys $ M.filter (not . toorecent now) m+getFailedPushesBefore :: NominalDiffTime -> FailedPushMap -> Assistant [Remote]+getFailedPushesBefore duration v = liftIO $ do+	m <- atomically $ readTMVar v+	now <- getCurrentTime+	return $ M.keys $ M.filter (not . toorecent now) m   where 	toorecent now time = now `diffUTCTime` time < duration  {- Modifies the map. -}-changeFailedPushMap :: (PushMap -> PushMap) -> Assistant ()-changeFailedPushMap a = do-	v <- getAssistant failedPushMap-	liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v+changeFailedPushMap :: FailedPushMap -> (PushMap -> PushMap) -> Assistant ()+changeFailedPushMap v f = liftIO $ atomically $+	store . f . fromMaybe M.empty =<< tryTakeTMVar v   where 	{- tryTakeTMVar empties the TMVar; refill it only if 	 - the modified map is not itself empty -}-	store v m+	store m 		| m == M.empty = noop 		| otherwise = putTMVar v $! m
Assistant/Sync.hs view
@@ -33,7 +33,9 @@ import Assistant.TransferSlots import Assistant.TransferQueue import Assistant.RepoProblem+import Assistant.Commits import Types.Transfer+import Database.Export  import Data.Time.Clock import qualified Data.Map as M@@ -48,10 +50,10 @@  - it's sufficient to requeue failed transfers.  -  - Also handles signaling any connectRemoteNotifiers, after the syncing is- - done.+ - done, and records an export commit to make any exports be updated.  -} reconnectRemotes :: [Remote] -> Assistant ()-reconnectRemotes [] = noop+reconnectRemotes [] = recordExportCommit reconnectRemotes rs = void $ do 	rs' <- liftIO $ filterM (Remote.checkAvailable True) rs 	unless (null rs') $ do@@ -60,6 +62,7 @@ 			whenM (liftIO $ Remote.checkAvailable False r) $ 				repoHasProblem (Remote.uuid r) (syncRemote r) 		mapM_ signal $ filter (`notElem` failedrs) rs'+	recordExportCommit   where 	gitremotes = filter (notspecialremote . Remote.repo) rs 	(_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs@@ -143,9 +146,11 @@ 				then retry currbranch g u failed 				else fallback branch g u failed -	updatemap succeeded failed = changeFailedPushMap $ \m ->-		M.union (makemap failed) $-			M.difference m (makemap succeeded)+	updatemap succeeded failed = do+		v <- getAssistant failedPushMap +		changeFailedPushMap v $ \m ->+			M.union (makemap failed) $+				M.difference m (makemap succeeded) 	makemap l = M.fromList $ zip l (repeat now)  	retry currbranch g u rs = do@@ -214,6 +219,8 @@ 	forM_ normalremotes $ \r -> 		liftAnnex $ Command.Sync.mergeRemote r 			currentbranch Command.Sync.mergeConfig def+	when haddiverged $+		updateExportTreeFromLogAll 	return (catMaybes failed, haddiverged)   where 	wantpull gc = remoteAnnexPull gc@@ -260,3 +267,9 @@ 	void Remote.remoteListRefresh   where 	key = Config.remoteConfig (Remote.repo r) "sync"++updateExportTreeFromLogAll :: Assistant ()+updateExportTreeFromLogAll = do+	rs <- exportRemotes <$> getDaemonStatus+	forM_ rs $ \r -> liftAnnex $+		openDb (Remote.uuid r) >>= updateExportTreeFromLog
Assistant/Threads/Committer.hs view
@@ -67,6 +67,7 @@ 				void $ alertWhile commitAlert $ 					liftAnnex $ commitStaged msg 				recordCommit+				recordExportCommit 				let numchanges = length readychanges 				mapM_ checkChangeContent readychanges 				return numchanges
+ Assistant/Threads/Exporter.hs view
@@ -0,0 +1,78 @@+{- git-annex assistant export updating thread+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Assistant.Threads.Exporter where++import Assistant.Common+import Assistant.Commits+import Assistant.Pushes+import Assistant.DaemonStatus+import Annex.Concurrent+import Utility.ThreadScheduler+import qualified Annex+import qualified Remote+import qualified Types.Remote as Remote+import qualified Command.Sync++import Control.Concurrent.Async+import Data.Time.Clock+import qualified Data.Map as M++{- This thread retries exports that failed before. -}+exportRetryThread :: NamedThread+exportRetryThread = namedThread "ExportRetrier" $ runEvery (Seconds halfhour) <~> do+	-- We already waited half an hour, now wait until there are failed+	-- exports to retry.+	toexport <- getFailedPushesBefore (fromIntegral halfhour) +		=<< getAssistant failedExportMap+	unless (null toexport) $ do+		debug ["retrying", show (length toexport), "failed exports"]+		void $ exportToRemotes toexport+  where+	halfhour = 1800++{- This thread updates exports soon after git commits are made. -}+exportThread :: NamedThread+exportThread = namedThread "Exporter" $ runEvery (Seconds 30) <~> do+	-- We already waited two seconds as a simple rate limiter.+	-- Next, wait until at least one commit has been made+	void getExportCommits+	-- Now see if now's a good time to push.+	void $ exportToRemotes =<< exportTargets++{- We want to avoid exporting to remotes that are marked readonly.+ -+ - Also, avoid exporting to local remotes we can easily tell are not available,+ - to avoid ugly messages when a removable drive is not attached.+ -}+exportTargets :: Assistant [Remote]+exportTargets = liftIO . filterM (Remote.checkAvailable True)+	=<< candidates <$> getDaemonStatus+  where+	candidates = filter (not . Remote.readonly) . exportRemotes++exportToRemotes :: [Remote] -> Assistant ()+exportToRemotes rs = do+	-- This is a long-duration action which runs in the Annex monad,+	-- so don't just liftAnnex to run it; fork the Annex state.+	runner <- liftAnnex $ forkState $+		forM rs $ \r -> do+			Annex.changeState $ \st -> st { Annex.errcounter = 0 }+			start <- liftIO getCurrentTime+			void $ Command.Sync.seekExportContent rs+			-- Look at command error counter to see if the export+			-- didn't work.+			failed <- (> 0) <$> Annex.getState Annex.errcounter+			Annex.changeState $ \st -> st { Annex.errcounter = 0 }+			return $ if failed+				then Just (r, start)+				else Nothing+	failed <- catMaybes+		<$> (liftAnnex =<< liftIO . wait =<< liftIO (async runner))+	unless (null failed) $ do+		v <- getAssistant failedExportMap+		changeFailedPushMap v $ M.union $ M.fromList failed
Assistant/Threads/Glacier.hs view
@@ -29,7 +29,7 @@   where 	isglacier r = Remote.remotetype r == Glacier.remote 	go = do-		rs <- filter isglacier . syncDataRemotes <$> getDaemonStatus+		rs <- filter isglacier . downloadRemotes <$> getDaemonStatus 		forM_ rs $ \r ->  			check r =<< liftAnnex (getFailedTransfers $ Remote.uuid r) 	check _ [] = noop
Assistant/Threads/Merger.hs view
@@ -10,6 +10,7 @@ import Assistant.Common import Assistant.TransferQueue import Assistant.BranchChange+import Assistant.Sync import Utility.DirWatcher import Utility.DirWatcher.Types import qualified Annex.Branch@@ -62,7 +63,8 @@ 	| isAnnexBranch file = do 		branchChanged 		diverged <- liftAnnex Annex.Branch.forceUpdate-		when diverged $+		when diverged $ do+			updateExportTreeFromLogAll 			queueDeferredDownloads "retrying deferred download" Later 	| otherwise = mergecurrent   where
Assistant/Threads/Pusher.hs view
@@ -22,6 +22,7 @@ 	-- We already waited half an hour, now wait until there are failed 	-- pushes to retry. 	topush <- getFailedPushesBefore (fromIntegral halfhour)+		=<< getAssistant failedPushMap 	unless (null topush) $ do 		debug ["retrying", show (length topush), "failed pushes"] 		void $ pushToRemotes topush
Assistant/Threads/TransferScanner.hs view
@@ -59,8 +59,9 @@ 			(s { transferScanRunning = b }, s) 		liftIO $ sendNotification $ transferNotifier ds 		-	{- All git remotes are synced, and all available remotes-	 - are scanned in full on startup, for multiple reasons, including:+	{- All git remotes are synced, all exports are updated,+	 - and all available remotes are scanned in full on startup,+	 - for multiple reasons, including: 	 - 	 - * This may be the first run, and there may be remotes 	 -   already in place, that need to be synced.@@ -78,7 +79,7 @@ 	 -} 	startupScan = do 		reconnectRemotes =<< syncGitRemotes <$> getDaemonStatus-		addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus+		addScanRemotes True =<< scannableRemotes  {- This is a cheap scan for failed transfers involving a remote. -} failedTransferScan :: Remote -> Assistant ()@@ -157,24 +158,29 @@ 			(AssociatedFile (Just f)) t r 	findtransfers f unwanted key = do 		let af = AssociatedFile (Just f)-		{- The syncable remotes may have changed since this-		 - scan began. -}-		syncrs <- syncDataRemotes <$> getDaemonStatus 		locs <- liftAnnex $ loggedLocations key 		present <- liftAnnex $ inAnnex key+		let slocs = S.fromList locs+		+		{- The remotes may have changed since this scan began. -}+		syncrs <- syncDataRemotes <$> getDaemonStatus+		let use l a = mapMaybe (a key slocs) . l <$> getDaemonStatus+ 		liftAnnex $ handleDropsFrom locs syncrs 			"expensive scan found too many copies of object" 			present key af [] callCommandAction-		liftAnnex $ do-			let slocs = S.fromList locs-			let use a = return $ mapMaybe (a key slocs) syncrs-			ts <- if present-				then filterM (wantSend True (Just key) af . Remote.uuid . fst)-					=<< use (genTransfer Upload False)-				else ifM (wantGet True (Just key) af)-					( use (genTransfer Download True) , return [] )-			let unwanted' = S.difference unwanted slocs-			return (unwanted', ts)+		ts <- if present+			then liftAnnex . filterM (wantSend True (Just key) af . Remote.uuid . fst)+				=<< use syncDataRemotes (genTransfer Upload False)+			else ifM (liftAnnex $ wantGet True (Just key) af)+				( use downloadRemotes (genTransfer Download True) , return [] )+		let unwanted' = S.difference unwanted slocs+		return (unwanted', ts)++-- Both syncDataRemotes and exportRemotes can be scanned.+-- The downloadRemotes list contains both.+scannableRemotes :: Assistant [Remote]+scannableRemotes = downloadRemotes <$> getDaemonStatus  genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer) genTransfer direction want key slocs r
Assistant/TransferQueue.hs view
@@ -66,9 +66,7 @@ 	| otherwise = go   where 	go = do-		-		rs <- liftAnnex . selectremotes-			=<< syncDataRemotes <$> getDaemonStatus+		rs <- liftAnnex . selectremotes =<< getDaemonStatus 		let matchingrs = filter (matching . Remote.uuid) rs 		if null matchingrs 			then do@@ -78,20 +76,21 @@ 				forM_ matchingrs $ \r -> 					enqueue reason schedule (gentransfer r) (stubInfo f r) 				return True-	selectremotes rs+	selectremotes st 		{- Queue downloads from all remotes that 		 - have the key. The list of remotes is ordered with 		 - cheapest first. More expensive ones will only be tried 		 - if downloading from a cheap one fails. -} 		| direction == Download = do 			s <- locs-			return $ filter (inset s) rs+			return $ filter (inset s) (downloadRemotes st) 		{- Upload to all remotes that want the content and don't 		 - already have it. -} 		| otherwise = do 			s <- locs 			filterM (wantSend True (Just k) f . Remote.uuid) $-				filter (\r -> not (inset s r || Remote.readonly r)) rs+				filter (\r -> not (inset s r || Remote.readonly r))+					(syncDataRemotes st) 	  where 		locs = S.fromList <$> Remote.keyLocations k 		inset s r = S.member (Remote.uuid r) s@@ -114,7 +113,7 @@ queueDeferredDownloads reason schedule = do 	q <- getAssistant transferQueue 	l <- liftIO $ atomically $ readTList (deferreddownloads q)-	rs <- syncDataRemotes <$> getDaemonStatus+	rs <- downloadRemotes <$> getDaemonStatus 	left <- filterM (queue rs) l 	unless (null left) $ 		liftIO $ atomically $ appendTList (deferreddownloads q) left
Assistant/Types/DaemonStatus.hs view
@@ -49,6 +49,10 @@ 	, syncGitRemotes :: [Remote] 	-- Ordered list of remotes to sync data with 	, syncDataRemotes :: [Remote]+	-- Ordered list of remotes to export to+	, exportRemotes :: [Remote]+	-- Ordered list of remotes that data can be downloaded from+	, downloadRemotes :: [Remote] 	-- Are we syncing to any cloud remotes? 	, syncingToCloudRemote :: Bool 	-- Set of uuids of remotes that are currently connected.@@ -94,6 +98,8 @@ 	<*> pure M.empty 	<*> pure M.empty 	<*> pure firstAlertId+	<*> pure []+	<*> pure [] 	<*> pure [] 	<*> pure [] 	<*> pure []
Assistant/WebApp/Configurators/Delete.hs view
@@ -72,7 +72,7 @@ deleteCurrentRepository = dangerPage $ do 	reldir <- fromJust . relDir <$> liftH getYesod 	havegitremotes <- haveremotes syncGitRemotes-	havedataremotes <- haveremotes syncDataRemotes+	havedataremotes <- haveremotes downloadRemotes 	((result, form), enctype) <- liftH $ 		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ 			sanityVerifierAForm $ SanityVerifier magicphrase
CHANGELOG view
@@ -1,9 +1,35 @@+git-annex (6.20170925) unstable; urgency=medium++  * git-annex export: New command, can create and efficiently update+    exports of trees to special remotes.+  * Use git-annex initremote with exporttree=yes to set up a special remote+    for use by git-annex export.+  * Implemented export to directory, S3, and webdav special remotes.+  * External special remote protocol extended to support export.+    Developers of external special remotes should consider if export makes+    sense for them and add support.+  * sync, assistant: Update tracking exports.+  * Support building with feed-1.0, while still supporting older versions.+  * init: Display an additional message when it detects a filesystem that+    allows writing to files whose write bit is not set.+  * S3: Allow removing files from IA.+  * webdav: Checking if a non-existent file is present on Box.com+    triggered a bug in its webdav support that generates an infinite series+    of redirects. Deal with such problems by assuming such behavior means+    the file is not present.+  * webdav: Fix lack of url-escaping of filenames. Mostly impacted exports+    of filenames containing eg spaces.+  * webdav: Changed path used on webdav server for temporary files.++ -- Joey Hess <id@joeyh.name>  Mon, 25 Sep 2017 11:13:58 -0400+ git-annex (6.20170818) unstable; urgency=high    * Security fix: Disallow hostname starting with a dash, which     would get passed to ssh and be treated an option. This could     be used by an attacker who provides a crafted repository url     to cause the victim to execute arbitrary code via -oProxyCommand.+    CVE-2017-12976     (The same class of security hole recently affected git itself.)   * git-annex.cabal: Deal with breaking changes in Cabal 2.0.   * Fix build with QuickCheck 2.10.
CmdLine/GitAnnex.hs view
@@ -95,6 +95,7 @@ import qualified Command.ImportFeed import qualified Command.RmUrl import qualified Command.Import+import qualified Command.Export import qualified Command.Map import qualified Command.Direct import qualified Command.Indirect@@ -141,6 +142,7 @@ 	, Command.ImportFeed.cmd 	, Command.RmUrl.cmd 	, Command.Import.cmd+	, Command.Export.cmd 	, Command.Init.cmd 	, Command.Describe.cmd 	, Command.InitRemote.cmd
CmdLine/Seek.hs view
@@ -77,12 +77,12 @@ 	go l = seekActions $ prepFiltered a $ 		return $ concat $ segmentPaths params l -withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CmdParams -> CommandSeek+withFilesInRefs :: (FilePath -> Key -> CommandStart) -> [Git.Ref] -> CommandSeek withFilesInRefs a = mapM_ go   where 	go r = do	 		matcher <- Limit.getMatcher-		(l, cleanup) <- inRepo $ LsTree.lsTree (Git.Ref r)+		(l, cleanup) <- inRepo $ LsTree.lsTree r 		forM_ l $ \i -> do 			let f = getTopFilePath $ LsTree.file i 			v <- catKey (LsTree.sha i)
CmdLine/Usage.hs view
@@ -94,6 +94,8 @@ paramAddress = "ADDRESS" paramItem :: String paramItem = "ITEM"+paramTreeish :: String+paramTreeish = "TREEISH" paramKeyValue :: String paramKeyValue = "K=V" paramNothing :: String
Command/EnableRemote.hs view
@@ -81,11 +81,11 @@ 	gc <- maybe (liftIO dummyRemoteGitConfig)  		(return . Remote.gitconfig) 		=<< Remote.byUUID u-	next $ performSpecialRemote t u fullconfig gc+	next $ performSpecialRemote t u c fullconfig gc -performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform-performSpecialRemote t u c gc = do-	(c', u') <- R.setup t R.Enable (Just u) Nothing c gc+performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform+performSpecialRemote t u oldc c gc = do+	(c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc 	next $ cleanupSpecialRemote u' c'  cleanupSpecialRemote :: UUID -> R.RemoteConfig -> CommandCleanup
+ Command/Export.hs view
@@ -0,0 +1,365 @@+{- git-annex command+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE TupleSections, BangPatterns #-}++module Command.Export where++import Command+import qualified Annex+import qualified Git+import qualified Git.DiffTree+import qualified Git.LsTree+import qualified Git.Ref+import Git.Types+import Git.FilePath+import Git.Sha+import Types.Remote+import Types.Export+import Annex.Export+import Annex.Content+import Annex.Transfer+import Annex.CatFile+import Annex.LockFile+import Logs.Location+import Logs.Export+import Database.Export+import Messages.Progress+import Config+import Utility.Tmp+import Utility.Metered++import qualified Data.ByteString.Lazy as L+import qualified Data.Map as M+import Control.Concurrent++cmd :: Command+cmd = command "export" SectionCommon+	"export content to a remote"+	paramTreeish (seek <$$> optParser)++data ExportOptions = ExportOptions+	{ exportTreeish :: Git.Ref+	, exportRemote :: DeferredParse Remote+	, exportTracking :: Bool+	}++optParser :: CmdParamsDesc -> Parser ExportOptions+optParser _ = ExportOptions+	<$> (Git.Ref <$> parsetreeish)+	<*> (parseRemoteOption <$> parseToOption)+	<*> parsetracking+  where+	parsetreeish = argument str+		( metavar paramTreeish+		)+	parsetracking = switch+		( long "tracking"+		<> help ("track changes to the " ++ paramTreeish)+		)++-- To handle renames which swap files, the exported file is first renamed+-- to a stable temporary name based on the key.+exportTempName :: ExportKey -> ExportLocation+exportTempName ek = mkExportLocation $ +	".git-annex-tmp-content-" ++ key2file (asKey (ek))++seek :: ExportOptions -> CommandSeek+seek o = do+	r <- getParsed (exportRemote o)+	unlessM (isExportSupported r) $+		giveup "That remote does not support exports."+	when (exportTracking o) $+		setConfig (remoteConfig r "export-tracking")+			(fromRef $ exportTreeish o)+	new <- fromMaybe (giveup "unknown tree") <$>+		-- Dereference the tree pointed to by the branch, commit,+		-- or tag.+		inRepo (Git.Ref.tree (exportTreeish o))+	withExclusiveLock (gitAnnexExportLock (uuid r)) $ do+		db <- openDb (uuid r)+		ea <- exportActions r+		changeExport r ea db new+		unlessM (Annex.getState Annex.fast) $+			void $ fillExport r ea db new+		closeDb db++-- | Changes what's exported to the remote. Does not upload any new+-- files, but does delete and rename files already exported to the remote.+changeExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> CommandSeek+changeExport r ea db new = do+	old <- getExport (uuid r)+	recordExportBeginning (uuid r) new+	+	-- Clean up after incomplete export of a tree, in which+	-- the next block of code below may have renamed some files to+	-- temp files. Diff from the incomplete tree to the new tree,+	-- and delete any temp files that the new tree can't use.+	forM_ (concatMap incompleteExportedTreeish old) $ \incomplete ->+		mapdiff (\diff -> startRecoverIncomplete r ea db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))+			incomplete+			new++	-- Diff the old and new trees, and delete or rename to new name all+	-- changed files in the export. After this, every file that remains+	-- in the export will have the content from the new treeish.+	-- +	-- When there was an export conflict, this resolves it.+	--+	-- The ExportTree is also updated here to reflect the new tree.+	case map exportedTreeish old of+		[] -> updateExportTree db emptyTree new+		[oldtreesha] -> do+			diffmap <- mkDiffMap oldtreesha new db+			let seekdiffmap a = seekActions $ pure $ map a (M.toList diffmap)+			-- Rename old files to temp, or delete.+			seekdiffmap $ \(ek, (moldf, mnewf)) -> do+				case (moldf, mnewf) of+					(Just oldf, Just _newf) ->+						startMoveToTempName r ea db oldf ek+					(Just oldf, Nothing) -> +						startUnexport' r ea db oldf ek+					_ -> stop+			-- Rename from temp to new files.+			seekdiffmap $ \(ek, (moldf, mnewf)) ->+				case (moldf, mnewf) of+					(Just _oldf, Just newf) ->+						startMoveFromTempName r ea db ek newf+					_ -> stop+		ts -> do+			warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.."+			forM_ ts $ \oldtreesha -> do+				-- Unexport both the srcsha and the dstsha,+				-- because the wrong content may have+				-- been renamed to the dstsha due to the+				-- export conflict.+				let unexportboth d = +					[ Git.DiffTree.srcsha d +					, Git.DiffTree.dstsha d+					]+				-- Don't rename to temp, because the+				-- content is unknown; delete instead.+				mapdiff+					(\diff -> startUnexport r ea db (Git.DiffTree.file diff) (unexportboth diff))+					oldtreesha new+			updateExportTree db emptyTree new+	liftIO $ recordExportTreeCurrent db new++	-- Waiting until now to record the export guarantees that,+	-- if this export is interrupted, there are no files left over+	-- from a previous export, that are not part of this export.+	c <- Annex.getState Annex.errcounter+	when (c == 0) $ do+		recordExport (uuid r) $ ExportChange+			{ oldTreeish = map exportedTreeish old+			, newTreeish = new+			}+  where+	mapdiff a oldtreesha newtreesha = do+		(diff, cleanup) <- inRepo $+			Git.DiffTree.diffTreeRecursive oldtreesha newtreesha+		seekActions $ pure $ map a diff+		void $ liftIO cleanup++-- Map of old and new filenames for each changed ExportKey in a diff.+type DiffMap = M.Map ExportKey (Maybe TopFilePath, Maybe TopFilePath)++mkDiffMap :: Git.Ref -> Git.Ref -> ExportHandle -> Annex DiffMap+mkDiffMap old new db = do+	(diff, cleanup) <- inRepo $ Git.DiffTree.diffTreeRecursive old new+	diffmap <- M.fromListWith combinedm . concat <$> forM diff mkdm+	void $ liftIO cleanup+	return diffmap+  where+	combinedm (srca, dsta) (srcb, dstb) = (srca <|> srcb, dsta <|> dstb)+	mkdm i = do+		srcek <- getek (Git.DiffTree.srcsha i)+		dstek <- getek (Git.DiffTree.dstsha i)+		updateExportTree' db srcek dstek i+		return $ catMaybes+			[ (, (Just (Git.DiffTree.file i), Nothing)) <$> srcek+			, (, (Nothing, Just (Git.DiffTree.file i))) <$> dstek+			]+	getek sha+		| sha == nullSha = return Nothing+		| otherwise = Just <$> exportKey sha++-- | Upload all exported files that are not yet in the remote,+-- Returns True when files were uploaded.+fillExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> Annex Bool+fillExport r ea db new = do+	(l, cleanup) <- inRepo $ Git.LsTree.lsTree new+	cvar <- liftIO $ newMVar False+	seekActions $ pure $ map (startExport r ea db cvar) l+	void $ liftIO $ cleanup+	liftIO $ takeMVar cvar++startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart+startExport r ea db cvar ti = do+	ek <- exportKey (Git.LsTree.sha ti)+	stopUnless (liftIO $ notElem loc <$> getExportedLocation db (asKey ek)) $ do+		showStart ("export " ++ name r) f+		liftIO $ modifyMVar_ cvar (pure . const True)+		next $ performExport r ea db ek af (Git.LsTree.sha ti) loc+  where+	loc = mkExportLocation f+	f = getTopFilePath (Git.LsTree.file ti)+	af = AssociatedFile (Just f)++performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform+performExport r ea db ek af contentsha loc = do+	let storer = storeExport ea+	sent <- case ek of+		AnnexKey k -> ifM (inAnnex k)+			( metered Nothing k $ \m -> do+				let rollback = void $+					performUnexport r ea db [ek] loc+				notifyTransfer Upload af $+					upload (uuid r) k af noRetry $ \pm -> do+						let m' = combineMeterUpdate pm m+						sendAnnex k rollback+							(\f -> storer f k loc m')+			, do+				showNote "not available"+				return False+			)+		-- Sending a non-annexed file.+		GitKey sha1k -> metered Nothing sha1k $ \m ->+			withTmpFile "export" $ \tmp h -> do+				b <- catObject contentsha+				liftIO $ L.hPut h b+				liftIO $ hClose h+				storer tmp sha1k loc m+	if sent+		then next $ cleanupExport r db ek loc+		else stop++cleanupExport :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> CommandCleanup+cleanupExport r db ek loc = do+	liftIO $ addExportedLocation db (asKey ek) loc+	logChange (asKey ek) (uuid r) InfoPresent+	return True++startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart+startUnexport r ea db f shas = do+	eks <- forM (filter (/= nullSha) shas) exportKey+	if null eks+		then stop+		else do+			showStart ("unexport " ++ name r) f'+			next $ performUnexport r ea db eks loc+  where+	loc = mkExportLocation f'+	f' = getTopFilePath f++startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart+startUnexport' r ea db f ek = do+	showStart ("unexport " ++ name r) f'+	next $ performUnexport r ea db [ek] loc+  where+	loc = mkExportLocation f'+	f' = getTopFilePath f++performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform+performUnexport r ea db eks loc = do+	ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks)+		( next $ cleanupUnexport r ea db eks loc+		, stop+		)++cleanupUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup+cleanupUnexport r ea db eks loc = do+	liftIO $ do+		forM_ eks $ \ek ->+			removeExportedLocation db (asKey ek) loc+		flushDbQueue db++	remaininglocs <- liftIO $ +		concat <$> forM eks (\ek -> getExportedLocation db (asKey ek))+	when (null remaininglocs) $+		forM_ eks $ \ek ->+			logChange (asKey ek) (uuid r) InfoMissing+	+	removeEmptyDirectories ea db loc (map asKey eks)++startRecoverIncomplete :: Remote -> ExportActions Annex -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart+startRecoverIncomplete r ea db sha oldf+	| sha == nullSha = stop+	| otherwise = do+		ek <- exportKey sha+		let loc = exportTempName ek+		showStart ("unexport " ++ name r) (fromExportLocation loc)+		liftIO $ removeExportedLocation db (asKey ek) oldloc+		next $ performUnexport r ea db [ek] loc+  where+	oldloc = mkExportLocation oldf'+	oldf' = getTopFilePath oldf++startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart+startMoveToTempName r ea db f ek = do+	showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)+	next $ performRename r ea db ek loc tmploc+  where+	loc = mkExportLocation f'+	f' = getTopFilePath f+	tmploc = exportTempName ek++startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart+startMoveFromTempName r ea db ek f = do+	let tmploc = exportTempName ek+	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do+		showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')+		next $ performRename r ea db ek tmploc loc+  where+	loc = mkExportLocation f'+	f' = getTopFilePath f++performRename :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform+performRename r ea db ek src dest = do+	ifM (renameExport ea (asKey ek) src dest)+		( next $ cleanupRename ea db ek src dest+		-- In case the special remote does not support renaming,+		-- unexport the src instead.+		, do+			warning "rename failed; deleting instead"+			performUnexport r ea db [ek] src+		)++cleanupRename :: ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup+cleanupRename ea db ek src dest = do+	liftIO $ do+		removeExportedLocation db (asKey ek) src+		addExportedLocation db (asKey ek) dest+		flushDbQueue db+	if exportDirectories src /= exportDirectories dest+		then removeEmptyDirectories ea db src [asKey ek]+		else return True++-- | Remove empty directories from the export. Call after removing an+-- exported file, and after calling removeExportLocation and flushing the+-- database.+removeEmptyDirectories :: ExportActions Annex -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool+removeEmptyDirectories ea db loc ks+	| null (exportDirectories loc) = return True+	| otherwise = case removeExportDirectory ea of+		Nothing -> return True+		Just removeexportdirectory -> do+			ok <- allM (go removeexportdirectory) +				(reverse (exportDirectories loc))+			unless ok $ liftIO $ do+				-- Add location back to export database, +				-- so this is tried again next time.+				forM_ ks $ \k ->+					addExportedLocation db k loc+				flushDbQueue db+			return ok+  where+	go removeexportdirectory d = +		ifM (liftIO $ isExportDirectoryEmpty db d)+			( removeexportdirectory d+			, return True+			)
Command/FindRef.hs view
@@ -9,6 +9,7 @@  import Command import qualified Command.Find as Find+import qualified Git  cmd :: Command cmd = withGlobalOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ @@ -17,4 +18,4 @@ 		paramRef (seek <$$> Find.optParser)  seek :: Find.FindOptions -> CommandSeek-seek o = Find.start o `withFilesInRefs` Find.findThese o+seek o = Find.start o `withFilesInRefs` (map Git.Ref $ Find.findThese o)
Command/ImportFeed.hs view
@@ -19,6 +19,9 @@ #if ! MIN_VERSION_time(1,5,0) import System.Locale #endif+#if MIN_VERSION_feed(1,0,0)+import qualified Data.Text as T+#endif  import Command import qualified Annex@@ -136,11 +139,13 @@  	mk f i = case getItemEnclosure i of 		Just (enclosureurl, _, _) -> return $ -			Just $ ToDownload f u i $ Enclosure enclosureurl+			Just $ ToDownload f u i $ Enclosure $ +				fromFeed enclosureurl 		Nothing -> mkquvi f i 	mkquvi f i = case getItemLink i of-		Just link -> ifM (quviSupported link)-			( return $ Just $ ToDownload f u i $ QuviLink link+		Just link -> ifM (quviSupported $ fromFeed link)+			( return $ Just $ ToDownload f u i $ QuviLink $ +				fromFeed link 			, return Nothing 			) 		Nothing -> return Nothing@@ -211,7 +216,8 @@ 		| otherwise = a  	knownitemid = case getItemId (item todownload) of-		Just (_, itemid) -> S.member itemid (knownitems cache)+		Just (_, itemid) ->+			S.member (fromFeed itemid) (knownitems cache) 		_ -> False  	rundownload url extension getter = do@@ -276,7 +282,8 @@ 		Just (Just d) -> Just $ 			formatTime defaultTimeLocale "%F" d 		-- if date cannot be parsed, use the raw string-		_ -> replace "/" "-" <$> getItemPublishDateString itm+		_ -> replace "/" "-" . fromFeed+			<$> getItemPublishDateString itm  extractMetaData :: ToDownload -> MetaData extractMetaData i = case getItemPublishDate (item i) :: Maybe (Maybe UTCTime) of@@ -290,7 +297,7 @@ minimalMetaData i = case getItemId (item i) of 	(Nothing) -> emptyMetaData 	(Just (_, itemid)) -> MetaData $ M.singleton itemIdField -		(S.singleton $ toMetaValue itemid)+		(S.singleton $ toMetaValue $ fromFeed itemid)  {- Extract fields from the feed and item, that are both used as metadata,  - and to generate the filename. -}@@ -300,18 +307,18 @@ 	, ("itemtitle", [itemtitle]) 	, ("feedauthor", [feedauthor]) 	, ("itemauthor", [itemauthor])-	, ("itemsummary", [getItemSummary $ item i])-	, ("itemdescription", [getItemDescription $ item i])-	, ("itemrights", [getItemRights $ item i])-	, ("itemid", [snd <$> getItemId (item i)])+	, ("itemsummary", [fromFeed <$> getItemSummary (item i)])+	, ("itemdescription", [fromFeed <$> getItemDescription (item i)])+	, ("itemrights", [fromFeed <$> getItemRights (item i)])+	, ("itemid", [fromFeed . snd <$> getItemId (item i)]) 	, ("title", [itemtitle, feedtitle]) 	, ("author", [itemauthor, feedauthor]) 	]   where-	feedtitle = Just $ getFeedTitle $ feed i-	itemtitle = getItemTitle $ item i-	feedauthor = getFeedAuthor $ feed i-	itemauthor = getItemAuthor $ item i+	feedtitle = Just $ fromFeed $ getFeedTitle $ feed i+	itemtitle = fromFeed <$> getItemTitle (item i)+	feedauthor = fromFeed <$> getFeedAuthor (feed i)+	itemauthor = fromFeed <$> getItemAuthor (item i)  itemIdField :: MetaField itemIdField = mkMetaFieldUnchecked "itemid"@@ -359,3 +366,11 @@  feedState :: URLString -> Annex FilePath feedState url = fromRepo $ gitAnnexFeedState $ fromUrl url Nothing++#if MIN_VERSION_feed(1,0,0)+fromFeed :: T.Text -> String+fromFeed = T.unpack+#else+fromFeed :: String -> String+fromFeed = id+#endif
Command/Sync.hs view
@@ -21,6 +21,7 @@ 	updateBranch, 	syncBranch, 	updateSyncBranch,+	seekExportContent, ) where  import Command@@ -46,14 +47,19 @@ import Annex.Content import Command.Get (getKey') import qualified Command.Move+import qualified Command.Export import Annex.Drop import Annex.UUID import Logs.UUID+import Logs.Export import Annex.AutoMerge import Annex.AdjustedBranch import Annex.Ssh import Annex.BloomFilter import Annex.UpdateInstead+import Annex.Export+import Annex.LockFile+import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse @@ -153,7 +159,8 @@  	remotes <- syncRemotes (syncWith o) 	let gitremotes = filter Remote.gitSyncableRemote remotes-	dataremotes <- filter (\r -> Remote.uuid r /= NoUUID)+	(exportremotes, dataremotes) <- partition (exportTree . Remote.config)+		. filter (\r -> Remote.uuid r /= NoUUID) 		<$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes  	-- Syncing involves many actions, any of which can independently@@ -165,16 +172,19 @@ 		, map (withbranch . pullRemote o mergeConfig) gitremotes 		,  [ mergeAnnex ] 		]-	whenM (shouldsynccontent <&&> seekSyncContent o dataremotes) $+	whenM shouldsynccontent $ do+		syncedcontent <- seekSyncContent o dataremotes+		exportedcontent <- seekExportContent exportremotes 		-- Transferring content can take a while, 		-- and other changes can be pushed to the git-annex 		-- branch on the remotes in the meantime, so pull 		-- and merge again to avoid our push overwriting 		-- those changes.-		mapM_ includeCommandAction $ concat-			[ map (withbranch . pullRemote o mergeConfig) gitremotes-			, [ commitAnnex, mergeAnnex ]-			]+		when (syncedcontent || exportedcontent) $ do+			mapM_ includeCommandAction $ concat+				[ map (withbranch . pullRemote o mergeConfig) gitremotes+				, [ commitAnnex, mergeAnnex ]+				] 	 	void $ includeCommandAction $ withbranch pushLocal 	-- Pushes to remotes can run concurrently.@@ -640,3 +650,35 @@ 		) 	put dest = includeCommandAction $  		Command.Move.toStart' dest False af k (mkActionItem af)++{- When a remote has an export-tracking branch, change the export to+ - follow the current content of the branch. Otherwise, transfer any files+ - that were part of an export but are not in the remote yet.+ - + - Returns True if any file transfers were made.+ -}+seekExportContent :: [Remote] -> Annex Bool+seekExportContent rs = or <$> forM rs go+  where+	go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do+		db <- Export.openDb (Remote.uuid r)+		ea <- Remote.exportActions r+		exported <- case remoteAnnexExportTracking (Remote.gitconfig r) of+			Nothing -> getExport (Remote.uuid r)+			Just b -> do+				mcur <- inRepo $ Git.Ref.tree b+				case mcur of+					Nothing -> getExport (Remote.uuid r)+					Just cur -> do+						Command.Export.changeExport r ea db cur+						return [Exported cur []]+		Export.closeDb db `after` fillexport r ea db exported++	fillexport _ _ _ [] = return False+	fillexport r ea db (Exported { exportedTreeish = t }:[]) =+		Command.Export.fillExport r ea db t+	fillexport r _ _ _ = do+		warning $ "Export conflict detected. Different trees have been exported to " ++ +			Remote.name r ++ +			". Use git-annex export to resolve this conflict."+		return False
Command/Trust.hs view
@@ -36,5 +36,5 @@ 			groupSet uuid S.empty 		l <- lookupTrust uuid 		when (l /= level) $-			warning $ "This remote's trust level is locally overridden to " ++ showTrustLevel l ++ " via git config."+			warning $ "This remote's trust level is overridden to " ++ showTrustLevel l ++ "." 		next $ return True
Config.hs view
@@ -18,6 +18,7 @@ import Config.DynamicConfig import Types.Availability import Git.Types+import qualified Types.Remote as Remote  type UnqualifiedConfigKey = String data ConfigKey = ConfigKey String@@ -54,6 +55,9 @@  instance RemoteNameable RemoteName where 	 getRemoteName = id++instance RemoteNameable Remote where+	getRemoteName = Remote.name  {- A per-remote config setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
+ Database/Export.hs view
@@ -0,0 +1,233 @@+{- Sqlite database used for exports to special remotes.+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -:+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++module Database.Export (+	ExportHandle,+	openDb,+	closeDb,+	flushDbQueue,+	addExportedLocation,+	removeExportedLocation,+	getExportedLocation,+	isExportDirectoryEmpty,+	getExportTreeCurrent,+	recordExportTreeCurrent,+	getExportTree,+	addExportTree,+	removeExportTree,+	updateExportTree,+	updateExportTree',+	updateExportTreeFromLog,+	ExportedId,+	ExportedDirectoryId,+	ExportTreeId,+	ExportTreeCurrentId,+) where++import Database.Types+import qualified Database.Queue as H+import Database.Init+import Annex.Locations+import Annex.Common hiding (delete)+import Types.Export+import Annex.Export+import qualified Logs.Export as Log+import Annex.LockFile+import Git.Types+import Git.Sha+import Git.FilePath+import qualified Git.DiffTree++import Database.Persist.TH+import Database.Esqueleto hiding (Key)++data ExportHandle = ExportHandle H.DbQueue UUID++share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|+-- Files that have been exported to the remote and are present on it.+Exported+  key IKey+  file SFilePath+  ExportedIndex key file+-- Directories that exist on the remote, and the files that are in them.+ExportedDirectory+  subdir SFilePath+  file SFilePath+  ExportedDirectoryIndex subdir file+-- The content of the tree that has been exported to the remote.+-- Not all of these files are necessarily present on the remote yet.+ExportTree+  key IKey+  file SFilePath+  ExportTreeIndex key file+-- The tree stored in ExportTree+ExportTreeCurrent+  tree SRef+  UniqueTree tree+|]++{- Opens the database, creating it if it doesn't exist yet.+ -+ - Only a single process should write to the export at a time, so guard+ - any writes with the gitAnnexExportLock.+ -}+openDb :: UUID -> Annex ExportHandle+openDb u = do+	dbdir <- fromRepo (gitAnnexExportDbDir u)+	let db = dbdir </> "db"+	unlessM (liftIO $ doesFileExist db) $ do+		initDb db $ void $+			runMigrationSilent migrateExport+	h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"+	return $ ExportHandle h u++closeDb :: ExportHandle -> Annex ()+closeDb (ExportHandle h _) = liftIO $ H.closeDbQueue h++queueDb :: ExportHandle -> SqlPersistM () -> IO ()+queueDb (ExportHandle h _) = H.queueDb h checkcommit+  where+	-- commit queue after 1000 changes+	checkcommit sz _lastcommittime+		| sz > 1000 = return True+		| otherwise = return False++flushDbQueue :: ExportHandle -> IO ()+flushDbQueue (ExportHandle h _) = H.flushDbQueue h++recordExportTreeCurrent :: ExportHandle -> Sha -> IO ()+recordExportTreeCurrent h s = queueDb h $ do+	delete $ from $ \r -> do+		where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree)+	void $ insertUnique $ ExportTreeCurrent $ toSRef s++getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha)+getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do+	l <- select $ from $ \r -> do+		where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree)+		return (r ^. ExportTreeCurrentTree)+	case l of+		(s:[]) -> return $ Just $ fromSRef $ unValue s+		_ -> return Nothing++addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()+addExportedLocation h k el = queueDb h $ do+	void $ insertUnique $ Exported ik ef+	let edirs = map+		(\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef)+		(exportDirectories el)+#if MIN_VERSION_persistent(2,1,0)+	insertMany_ edirs+#else+	void $ insertMany edirs+#endif+  where+	ik = toIKey k+	ef = toSFilePath (fromExportLocation el)++removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()+removeExportedLocation h k el = queueDb h $ do+	delete $ from $ \r -> do+		where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef)+	let subdirs = map (toSFilePath . fromExportDirectory)+		(exportDirectories el)+	delete $ from $ \r -> do+		where_ (r ^. ExportedDirectoryFile ==. val ef+			&&. r ^. ExportedDirectorySubdir `in_` valList subdirs)+  where+	ik = toIKey k+	ef = toSFilePath (fromExportLocation el)++{- Note that this does not see recently queued changes. -}+getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]+getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do+	l <- select $ from $ \r -> do+		where_ (r ^. ExportedKey ==. val ik)+		return (r ^. ExportedFile)+	return $ map (mkExportLocation . fromSFilePath . unValue) l+  where+	ik = toIKey k++{- Note that this does not see recently queued changes. -}+isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool+isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do+	l <- select $ from $ \r -> do+		where_ (r ^. ExportedDirectorySubdir ==. val ed)+		return (r ^. ExportedDirectoryFile)+	return $ null l+  where+	ed = toSFilePath $ fromExportDirectory d++{- Get locations in the export that might contain a key. -}+getExportTree :: ExportHandle -> Key -> IO [ExportLocation]+getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do+	l <- select $ from $ \r -> do+		where_ (r ^. ExportTreeKey ==. val ik)+		return (r ^. ExportTreeFile)+	return $ map (mkExportLocation . fromSFilePath . unValue) l+  where+	ik = toIKey k++addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()+addExportTree h k loc = queueDb h $+	void $ insertUnique $ ExportTree ik ef+  where+	ik = toIKey k+	ef = toSFilePath (fromExportLocation loc)++removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()+removeExportTree h k loc = queueDb h $ +	delete $ from $ \r ->+		where_ (r ^. ExportTreeKey ==. val ik &&. r ^. ExportTreeFile ==. val ef)+  where+	ik = toIKey k+	ef = toSFilePath (fromExportLocation loc)++{- Diff from the old to the new tree and update the ExportTree table. -}+updateExportTree :: ExportHandle -> Sha -> Sha -> Annex ()+updateExportTree h old new = do+	(diff, cleanup) <- inRepo $+		Git.DiffTree.diffTreeRecursive old new+	forM_ diff $ \i -> do+		srcek <- getek (Git.DiffTree.srcsha i)+		dstek <- getek (Git.DiffTree.dstsha i)+		updateExportTree' h srcek dstek i+	void $ liftIO cleanup+  where+	getek sha+		| sha == nullSha = return Nothing+		| otherwise = Just <$> exportKey sha++updateExportTree' :: ExportHandle -> Maybe ExportKey -> Maybe ExportKey -> Git.DiffTree.DiffTreeItem-> Annex ()+updateExportTree' h srcek dstek i = do+	case srcek of+		Nothing -> return ()+		Just k -> liftIO $ removeExportTree h (asKey k) loc+	case dstek of+		Nothing -> return ()+		Just k -> liftIO $ addExportTree h (asKey k) loc+  where+	loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i+			+updateExportTreeFromLog :: ExportHandle -> Annex ()+updateExportTreeFromLog db@(ExportHandle _ u) = +	withExclusiveLock (gitAnnexExportLock u) $ do+		old <- liftIO $ fromMaybe emptyTree+			<$> getExportTreeCurrent db+		l <- Log.getExport u+		case map Log.exportedTreeish l of+			(new:[]) | new /= old -> do+				updateExportTree db old new+				liftIO $ recordExportTreeCurrent db new+				liftIO $ flushDbQueue db+			_ -> return ()
Database/Fsck.hs view
@@ -63,7 +63,7 @@ 		initDb db $ void $ 			runMigrationSilent migrateFsck 	lockFileCached =<< fromRepo (gitAnnexFsckDbLock u)-	h <- liftIO $ H.openDbQueue db "fscked"+	h <- liftIO $ H.openDbQueue H.MultiWriter db "fscked" 	return $ FsckHandle h u  closeDb :: FsckHandle -> Annex ()
Database/Handle.hs view
@@ -9,6 +9,7 @@  module Database.Handle ( 	DbHandle,+	DbConcurrency(..), 	openDb, 	TableName, 	queryDb,@@ -35,27 +36,49 @@  {- A DbHandle is a reference to a worker thread that communicates with  - the database. It has a MVar which Jobs are submitted to. -}-data DbHandle = DbHandle (Async ()) (MVar Job)+data DbHandle = DbHandle DbConcurrency (Async ()) (MVar Job)  {- Name of a table that should exist once the database is initialized. -} type TableName = String +{- Sqlite only allows a single write to a database at a time; a concurrent+ - write will crash. + -+ - While a DbHandle serializes concurrent writes from+ - multiple threads. But, when a database can be written to by+ - multiple processes concurrently, use MultiWriter to make writes+ - to the database be done robustly.+ - + - The downside of using MultiWriter is that after writing a change to the+ - database, the a query using the same DbHandle will not immediately see+ - the change! This is because the change is actually written using a+ - separate database connection, and caching can prevent seeing the change.+ - Also, consider that if multiple processes are writing to a database,+ - you can't rely on seeing values you've just written anyway, as another+ - process may change them.+ -+ - When a database can only be written to by a single process, use+ - SingleWriter. Changes written to the database will always be immediately+ - visible then.+ -}+data DbConcurrency = SingleWriter | MultiWriter+ {- Opens the database, but does not perform any migrations. Only use- - if the database is known to exist and have the right tables. -}-openDb :: FilePath -> TableName -> IO DbHandle-openDb db tablename = do+ - once the database is known to exist and have the right tables. -}+openDb :: DbConcurrency -> FilePath -> TableName -> IO DbHandle+openDb dbconcurrency db tablename = do 	jobs <- newEmptyMVar 	worker <- async (workerThread (T.pack db) tablename jobs) 	 	-- work around https://github.com/yesodweb/persistent/issues/474 	liftIO $ fileEncoding stderr -	return $ DbHandle worker jobs+	return $ DbHandle dbconcurrency worker jobs  {- This is optional; when the DbHandle gets garbage collected it will  - auto-close. -} closeDb :: DbHandle -> IO ()-closeDb (DbHandle worker jobs) = do+closeDb (DbHandle _ worker jobs) = do 	putMVar jobs CloseJob 	wait worker @@ -68,9 +91,12 @@  - Only one action can be run at a time against a given DbHandle.  - If called concurrently in the same process, this will block until  - it is able to run.+ -+ - Note that when the DbHandle was opened in MultiWriter mode, recent+ - writes may not be seen by queryDb.  -} queryDb :: DbHandle -> SqlPersistM a -> IO a-queryDb (DbHandle _ jobs) a = do+queryDb (DbHandle _ _ jobs) a = do 	res <- newEmptyMVar 	putMVar jobs $ QueryJob $ 		liftIO . putMVar res =<< tryNonAsync a@@ -79,9 +105,9 @@  {- Writes a change to the database.  -- - If a database is opened multiple times and there's a concurrent writer,- - the write could fail. Retries repeatedly for up to 10 seconds, - - which should avoid all but the most exceptional problems.+ - In MultiWriter mode, catches failure to write to the database,+ - and retries repeatedly for up to 10 seconds,  which should avoid+ - all but the most exceptional problems.  -} commitDb :: DbHandle -> SqlPersistM () -> IO () commitDb h wa = robustly Nothing 100 (commitDb' h wa)@@ -97,23 +123,34 @@ 				robustly (Just e) (n-1) a  commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())-commitDb' (DbHandle _ jobs) a = do+commitDb' (DbHandle MultiWriter _ jobs) a = do 	res <- newEmptyMVar-	putMVar jobs $ ChangeJob $ \runner ->+	putMVar jobs $ RobustChangeJob $ \runner -> 		liftIO $ putMVar res =<< tryNonAsync (runner a) 	takeMVar res+commitDb' (DbHandle SingleWriter _ jobs) a = do+	res <- newEmptyMVar+	putMVar jobs $ ChangeJob $+		liftIO . putMVar res =<< tryNonAsync a+	takeMVar res+		`catchNonAsync` (const $ error "sqlite commit crashed")  data Job 	= QueryJob (SqlPersistM ())-	| ChangeJob ((SqlPersistM () -> IO ()) -> IO ())+	| ChangeJob (SqlPersistM ())+	| RobustChangeJob ((SqlPersistM () -> IO ()) -> IO ()) 	| CloseJob  workerThread :: T.Text -> TableName -> MVar Job -> IO ()-workerThread db tablename jobs =-	catchNonAsync (runSqliteRobustly tablename db loop) showerr+workerThread db tablename jobs = go   where-  	showerr e = hPutStrLn stderr $-		"sqlite worker thread crashed: " ++ show e+	go = do+		v <- tryNonAsync (runSqliteRobustly tablename db loop)+		case v of+			Left e -> hPutStrLn stderr $+				"sqlite worker thread crashed: " ++ show e+			Right True -> go+			Right False -> return () 	 	getjob :: IO (Either BlockedIndefinitelyOnMVar Job) 	getjob = try $ takeMVar jobs@@ -124,13 +161,21 @@ 			-- Exception is thrown when the MVar is garbage 			-- collected, which means the whole DbHandle 			-- is not used any longer. Shutdown cleanly.-			Left BlockedIndefinitelyOnMVar -> return ()-			Right CloseJob -> return ()+			Left BlockedIndefinitelyOnMVar -> return False+			Right CloseJob -> return False 			Right (QueryJob a) -> a >> loop-			-- change is run in a separate database connection+			Right (ChangeJob a) -> do+				a+				-- Exit this sqlite transaction so the+				-- database gets updated on disk.+				return True+			-- Change is run in a separate database connection 			-- since sqlite only supports a single writer at a 			-- time, and it may crash the database connection-			Right (ChangeJob a) -> liftIO (a (runSqliteRobustly tablename db)) >> loop+			-- that the write is made to.+			Right (RobustChangeJob a) -> do+				liftIO (a (runSqliteRobustly tablename db))+				loop 	 -- like runSqlite, but calls settle on the raw sql Connection. runSqliteRobustly :: TableName -> T.Text -> (SqlPersistM a) -> IO a
Database/Keys.hs view
@@ -124,7 +124,7 @@ 			open db 		(False, False) -> return DbUnavailable   where-	open db = liftIO $ DbOpen <$> H.openDbQueue db SQL.containedTable+	open db = liftIO $ DbOpen <$> H.openDbQueue H.MultiWriter db SQL.containedTable 	-- If permissions don't allow opening the database, treat it as if 	-- it does not exist. 	permerr e = case createdb of
Database/Queue.hs view
@@ -9,6 +9,7 @@  module Database.Queue ( 	DbQueue,+	DbConcurrency(..), 	openDbQueue, 	queryDbQueue, 	closeDbQueue,@@ -35,9 +36,9 @@ {- Opens the database queue, but does not perform any migrations. Only use  - if the database is known to exist and have the right tables; ie after  - running initDb. -}-openDbQueue :: FilePath -> TableName -> IO DbQueue-openDbQueue db tablename = DQ-	<$> openDb db tablename+openDbQueue :: DbConcurrency -> FilePath -> TableName -> IO DbQueue+openDbQueue dbconcurrency db tablename = DQ+	<$> openDb dbconcurrency db tablename 	<*> (newMVar =<< emptyQueue)  {- This or flushDbQueue must be called, eg at program exit to ensure@@ -60,8 +61,11 @@ {- Makes a query using the DbQueue's database connection.  - This should not be used to make changes to the database!  -- - Queries will not return changes that have been recently queued,+ - Queries will not see changes that have been recently queued,  - so use with care.+ -+ - Also, when the database was opened in MultiWriter mode,+ - queries may not see changes even after flushDbQueue.  -} queryDbQueue :: DbQueue -> SqlPersistM a -> IO a queryDbQueue (DQ hdl _) = queryDb hdl
Database/Types.hs view
@@ -1,6 +1,6 @@ {- types for SQL databases  -- - Copyright 2015-2016 Joey Hess <id@joeyh.name>+ - Copyright 2015-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,6 +16,7 @@ import Utility.PartialPrelude import Key import Utility.InodeCache+import Git.Types (Ref(..))  -- A serialized Key newtype SKey = SKey String@@ -93,3 +94,21 @@  derivePersistField "SFilePath" +-- A serialized Ref+newtype SRef = SRef Ref++-- Note that Read instance does not work when used in any kind of complex+-- data structure.+instance Read SRef where+	readsPrec _ s = [(SRef (Ref s), "")]++instance Show SRef where+	show (SRef (Ref s)) = s++derivePersistField "SRef"++toSRef :: Ref -> SRef+toSRef = SRef++fromSRef :: SRef -> Ref+fromSRef (SRef r) = r
Git/Tree.hs view
@@ -14,6 +14,7 @@ 	recordTree, 	TreeItem(..), 	adjustTree,+	treeMode, ) where  import Common@@ -94,11 +95,14 @@ 	send h = do 		forM_ l $ \i -> hPutStr h $ case i of 			TreeBlob f fm s -> mkTreeOutput fm BlobObject s f-			RecordedSubTree f s _ -> mkTreeOutput 0o040000 TreeObject s f+			RecordedSubTree f s _ -> mkTreeOutput treeMode TreeObject s f 			NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree" 			TreeCommit f fm s -> mkTreeOutput fm CommitObject s f 		hPutStr h "\NUL" -- signal end of tree to --batch 	receive h = getSha "mktree" (hGetLine h)++treeMode :: FileMode+treeMode = 0o040000  mkTreeOutput :: FileMode -> ObjectType -> Sha -> TopFilePath -> String mkTreeOutput fm ot s f = concat
Logs.hs view
@@ -42,6 +42,7 @@ 	, activityLog 	, differenceLog 	, multicastLog+	, exportLog 	]  {- All the ways to get a key from a presence log file -}@@ -96,6 +97,9 @@  multicastLog :: FilePath multicastLog = "multicast.log"++exportLog :: FilePath+exportLog = "export.log"  {- The pathname of the location log file for a given key. -} locationLogFile :: GitConfig -> Key -> String
+ Logs/Export.hs view
@@ -0,0 +1,125 @@+{- git-annex export log+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Logs.Export where++import qualified Data.Map as M++import Annex.Common+import qualified Annex.Branch+import qualified Git+import Git.Sha+import Git.FilePath+import Logs+import Logs.MapLog+import Annex.UUID++data Exported = Exported+	{ exportedTreeish :: Git.Ref+	, incompleteExportedTreeish :: [Git.Ref]+	}+	deriving (Eq, Show)++data ExportParticipants = ExportParticipants+	{ exportFrom :: UUID+	, exportTo :: UUID+	}+	deriving (Eq, Ord)++data ExportChange = ExportChange+	{ oldTreeish :: [Git.Ref]+	, newTreeish :: Git.Ref+	}++-- | Get what's been exported to a special remote.+--+-- If the list contains multiple items, there was an export conflict,+-- and different trees were exported to the same special remote.+getExport :: UUID -> Annex [Exported]+getExport remoteuuid = nub . mapMaybe get . M.toList . simpleMap +	. parseExportLog+	<$> Annex.Branch.get exportLog+  where+	get (ep, exported)+		| exportTo ep == remoteuuid = Just exported+		| otherwise = Nothing++-- | Record a change in what's exported to a special remote.+--+-- This is called before an export begins uploading new files to the+-- remote, but after it's cleaned up any files that need to be deleted+-- from the old treeish.+--+-- Any entries in the log for the oldTreeish will be updated to the+-- newTreeish. This way, when multiple repositories are exporting to+-- the same special remote, there's no conflict as long as they move+-- forward in lock-step.+--+-- Also, the newTreeish is grafted into the git-annex branch. This is done+-- to ensure that it's available later.+recordExport :: UUID -> ExportChange -> Annex ()+recordExport remoteuuid ec = do+	c <- liftIO currentVectorClock+	u <- getUUID+	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }+	let exported = Exported (newTreeish ec) []+	Annex.Branch.change exportLog $+		showExportLog+			. changeMapLog c ep exported +			. M.mapWithKey (updateothers c u)+			. parseExportLog+  where+	updateothers c u ep le@(LogEntry _ exported@(Exported { exportedTreeish = t }))+		| u == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le+		| otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec })++-- | Record the beginning of an export, to allow cleaning up from+-- interrupted exports.+--+-- This is called before any changes are made to the remote.+recordExportBeginning :: UUID -> Git.Ref -> Annex ()+recordExportBeginning remoteuuid newtree = do+	c <- liftIO currentVectorClock+	u <- getUUID+	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }+	old <- fromMaybe (Exported emptyTree [])+		. M.lookup ep . simpleMap +		. parseExportLog+		<$> Annex.Branch.get exportLog+	let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) }+	Annex.Branch.change exportLog $+		showExportLog +			. changeMapLog c ep new+			. parseExportLog+	Annex.Branch.graftTreeish newtree (asTopFilePath "export.tree")++parseExportLog :: String -> MapLog ExportParticipants Exported+parseExportLog = parseMapLog parseExportParticipants parseExported++showExportLog :: MapLog ExportParticipants Exported -> String+showExportLog = showMapLog formatExportParticipants formatExported++formatExportParticipants :: ExportParticipants -> String+formatExportParticipants ep = +	fromUUID (exportFrom ep) ++ ':' : fromUUID (exportTo ep)++parseExportParticipants :: String -> Maybe ExportParticipants+parseExportParticipants s = case separate (== ':') s of+	("",_) -> Nothing+	(_,"") -> Nothing+	(f,t) -> Just $ ExportParticipants+		{ exportFrom = toUUID f+		, exportTo = toUUID t+		}+formatExported :: Exported -> String+formatExported exported = unwords $ map Git.fromRef $+	exportedTreeish exported : incompleteExportedTreeish exported++parseExported :: String -> Maybe Exported+parseExported s = case words s of+	(et:it) -> Just $ Exported (Git.Ref et) (map Git.Ref it)+	_ -> Nothing
Logs/Trust.hs view
@@ -65,10 +65,16 @@ trustMapLoad :: Annex TrustMap trustMapLoad = do 	overrides <- Annex.getState Annex.forcetrust+	l <- remoteList+	-- Exports are never trusted, since they are not key/value stores.+	exports <- filterM Types.Remote.isExportSupported l+	let exportoverrides = M.fromList $+		map (\r -> (Types.Remote.uuid r, UnTrusted)) exports 	logged <- trustMapRaw-	configured <- M.fromList . catMaybes-		<$> (map configuredtrust <$> remoteList)-	let m = M.union overrides $ M.union configured logged+	let configured = M.fromList $ mapMaybe configuredtrust l+	let m = M.union exportoverrides $+		M.union overrides $+		M.union configured logged 	Annex.changeState $ \s -> s { Annex.trustmap = Just m } 	return m   where
Remote.hs view
@@ -53,6 +53,7 @@ 	checkAvailable, 	isXMPPRemote, 	claimingUrl,+	isExportSupported, ) where  import Data.Ord
Remote/BitTorrent.hs view
@@ -26,6 +26,7 @@ import Annex.Perms import Annex.UUID import qualified Annex.Url as Url+import Remote.Helper.Export  import Network.URI @@ -35,12 +36,13 @@ #endif  remote :: RemoteType-remote = RemoteType {-	typename = "bittorrent",-	enumerate = list,-	generate = gen,-	setup = error "not supported"-}+remote = RemoteType+	{ typename = "bittorrent"+	, enumerate = list+	, generate = gen+	, setup = error "not supported"+	, exportSupported = exportUnsupported+	}  -- There is only one bittorrent remote, and it always exists. list :: Bool -> Annex [Git.Repo]@@ -61,6 +63,7 @@ 		, lockContent = Nothing 		, checkPresent = checkKey 		, checkPresentCheap = False+		, exportActions = exportUnsupported 		, whereisKey = Nothing 		, remoteFsck = Nothing 		, repairRepo = Nothing
Remote/Bup.hs view
@@ -25,6 +25,7 @@ import qualified Remote.Helper.Ssh as Ssh import Remote.Helper.Special import Remote.Helper.Messages+import Remote.Helper.Export import Utility.Hash import Utility.UserInfo import Annex.UUID@@ -34,12 +35,13 @@ type BupRepo = String  remote :: RemoteType-remote = RemoteType {-	typename = "bup",-	enumerate = const (findSpecialRemotes "buprepo"),-	generate = gen,-	setup = bupSetup-}+remote = RemoteType+	{ typename = "bup"+	, enumerate = const (findSpecialRemotes "buprepo")+	, generate = gen+	, setup = bupSetup+	, exportSupported = exportUnsupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do@@ -61,6 +63,7 @@ 		, lockContent = Nothing 		, checkPresent = checkPresentDummy 		, checkPresentCheap = bupLocal buprepo+		, exportActions = exportUnsupported 		, whereisKey = Nothing 		, remoteFsck = Nothing 		, repairRepo = Nothing
Remote/Ddar.hs view
@@ -19,6 +19,7 @@ import Config import Config.Cost import Remote.Helper.Special+import Remote.Helper.Export import Annex.Ssh import Annex.UUID import Utility.SshHost@@ -29,12 +30,13 @@ 	}  remote :: RemoteType-remote = RemoteType {-	typename = "ddar",-	enumerate = const (findSpecialRemotes "ddarrepo"),-	generate = gen,-	setup = ddarSetup-}+remote = RemoteType+	{ typename = "ddar"+	, enumerate = const (findSpecialRemotes "ddarrepo")+	, generate = gen+	, setup = ddarSetup+	, exportSupported = exportUnsupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do@@ -60,6 +62,7 @@ 		, lockContent = Nothing 		, checkPresent = checkPresentDummy 		, checkPresentCheap = ddarLocal ddarrepo+		, exportActions = exportUnsupported 		, whereisKey = Nothing 		, remoteFsck = Nothing 		, repairRepo = Nothing
Remote/Directory.hs view
@@ -1,6 +1,6 @@ {- A "remote" that is just a filesystem directory.  -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -19,24 +19,28 @@  import Annex.Common import Types.Remote+import Types.Export import Types.Creds import qualified Git import Config.Cost import Config import Utility.FileMode import Remote.Helper.Special+import Remote.Helper.Export import qualified Remote.Directory.LegacyChunked as Legacy import Annex.Content import Annex.UUID import Utility.Metered+import Utility.Tmp  remote :: RemoteType-remote = RemoteType {-	typename = "directory",-	enumerate = const (findSpecialRemotes "directory"),-	generate = gen,-	setup = directorySetup-}+remote = RemoteType+	{ typename = "directory"+	, enumerate = const (findSpecialRemotes "directory")+	, generate = gen+	, setup = directorySetup+	, exportSupported = exportIsSupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do@@ -44,20 +48,30 @@ 	let chunkconfig = getChunkConfig c 	return $ Just $ specialRemote c 		(prepareStore dir chunkconfig)-		(retrieve dir chunkconfig)-		(simplyPrepare $ remove dir)-		(simplyPrepare $ checkKey dir chunkconfig)+		(retrieveKeyFileM dir chunkconfig)+		(simplyPrepare $ removeKeyM dir)+		(simplyPrepare $ checkPresentM dir chunkconfig) 		Remote 			{ uuid = u 			, cost = cst 			, name = Git.repoDescribe r 			, storeKey = storeKeyDummy 			, retrieveKeyFile = retreiveKeyFileDummy-			, retrieveKeyFileCheap = retrieveCheap dir chunkconfig+			, retrieveKeyFileCheap = retrieveKeyFileCheapM dir chunkconfig 			, removeKey = removeKeyDummy 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = True+			, exportActions = return $ ExportActions+				{ storeExport = storeExportM dir+				, retrieveExport = retrieveExportM dir+				, removeExport = removeExportM dir+				, checkPresentExport = checkPresentExportM dir+				-- Not needed because removeExportLocation+				-- auto-removes empty directories.+				, removeExportDirectory = Nothing+				, renameExport = renameExportM dir+				} 			, whereisKey = Nothing 			, remoteFsck = Nothing 			, repairRepo = Nothing@@ -111,25 +125,22 @@ storeDir :: FilePath -> Key -> FilePath storeDir d k = addTrailingPathSeparator $ d </> hashDirLower def k </> keyFile k -{- Where we store temporary data for a key, in the directory, as it's being- - written. -}-tmpDir :: FilePath -> Key -> FilePath-tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k- {- Check if there is enough free disk space in the remote's directory to  - store the key. Note that the unencrypted key size is checked. -} prepareStore :: FilePath -> ChunkConfig -> Preparer Storer-prepareStore d chunkconfig = checkPrepare checker+prepareStore d chunkconfig = checkPrepare (checkDiskSpaceDirectory d) 	(byteStorer $ store d chunkconfig)   where-	checker k = do-		annexdir <- fromRepo gitAnnexObjectDir-		samefilesystem <- liftIO $ catchDefaultIO False $ -			(\a b -> deviceID a == deviceID b)-				<$> getFileStatus d-				<*> getFileStatus annexdir-		checkDiskSpace (Just d) k 0 samefilesystem +checkDiskSpaceDirectory :: FilePath -> Key -> Annex Bool+checkDiskSpaceDirectory d k = do+	annexdir <- fromRepo gitAnnexObjectDir+	samefilesystem <- liftIO $ catchDefaultIO False $ +		(\a b -> deviceID a == deviceID b)+			<$> getFileStatus d+			<*> getFileStatus annexdir+	checkDiskSpace (Just d) k 0 samefilesystem+ store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool store d chunkconfig k b p = liftIO $ do 	void $ tryIO $ createDirectoryIfMissing True tmpdir@@ -141,7 +152,7 @@ 			finalizeStoreGeneric tmpdir destdir 			return True   where-	tmpdir = tmpDir d k+	tmpdir = addTrailingPathSeparator $ d </> "tmp" </> keyFile k 	destdir = storeDir d k  {- Passed a temp directory that contains the files that should be placed@@ -159,17 +170,17 @@ 		mapM_ preventWrite =<< dirContents dest 		preventWrite dest -retrieve :: FilePath -> ChunkConfig -> Preparer Retriever-retrieve d (LegacyChunks _) = Legacy.retrieve locations d-retrieve d _ = simplyPrepare $ byteRetriever $ \k sink ->+retrieveKeyFileM :: FilePath -> ChunkConfig -> Preparer Retriever+retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d+retrieveKeyFileM d _ = simplyPrepare $ byteRetriever $ \k sink -> 	sink =<< liftIO (L.readFile =<< getLocation d k) -retrieveCheap :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool+retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool -- no cheap retrieval possible for chunks-retrieveCheap _ (UnpaddedChunks _) _ _ _ = return False-retrieveCheap _ (LegacyChunks _) _ _ _ = return False+retrieveKeyFileCheapM _ (UnpaddedChunks _) _ _ _ = return False+retrieveKeyFileCheapM _ (LegacyChunks _) _ _ _ = return False #ifndef mingw32_HOST_OS-retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do+retrieveKeyFileCheapM d NoChunks k _af f = liftIO $ catchBoolIO $ do 	file <- absPath =<< getLocation d k 	ifM (doesFileExist file) 		( do@@ -178,11 +189,11 @@ 		, return False 		) #else-retrieveCheap _ _ _ _ _ = return False+retrieveKeyFileCheapM _ _ _ _ _ = return False #endif -remove :: FilePath -> Remover-remove d k = liftIO $ removeDirGeneric d (storeDir d k)+removeKeyM :: FilePath -> Remover+removeKeyM d k = liftIO $ removeDirGeneric d (storeDir d k)  {- Removes the directory, which must be located under the topdir.  -@@ -209,13 +220,68 @@ 		then return ok 		else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir) -checkKey :: FilePath -> ChunkConfig -> CheckPresent-checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k-checkKey d _ k = liftIO $-	ifM (anyM doesFileExist (locations d k))+checkPresentM :: FilePath -> ChunkConfig -> CheckPresent+checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k+checkPresentM d _ k = checkPresentGeneric d (locations d k)++checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool+checkPresentGeneric d ps = liftIO $+	ifM (anyM doesFileExist ps) 		( return True 		, ifM (doesDirectoryExist d) 			( return False 			, giveup $ "directory " ++ d ++ " is not accessible" 			) 		)++storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportM d src _k loc p = liftIO $ catchBoolIO $ do+	createDirectoryIfMissing True (takeDirectory dest)+	-- Write via temp file so that checkPresentGeneric will not+	-- see it until it's fully stored.+	viaTmp (\tmp () -> withMeteredFile src p (L.writeFile tmp)) dest ()+	return True+  where+	dest = exportPath d loc++retrieveExportM :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool+retrieveExportM d _k loc dest p = liftIO $ catchBoolIO $ do+	withMeteredFile src p (L.writeFile dest)+	return True+  where+	src = exportPath d loc++removeExportM :: FilePath -> Key -> ExportLocation -> Annex Bool+removeExportM d _k loc = liftIO $ do+	nukeFile src+	removeExportLocation d loc+	return True+  where+	src = exportPath d loc++checkPresentExportM :: FilePath -> Key -> ExportLocation -> Annex Bool+checkPresentExportM d _k loc =+	checkPresentGeneric d [exportPath d loc]++renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool+renameExportM d _k oldloc newloc = liftIO $ catchBoolIO $ do+	createDirectoryIfMissing True (takeDirectory dest)+	renameFile src dest+	removeExportLocation d oldloc+	return True+  where+	src = exportPath d oldloc+	dest = exportPath d newloc++exportPath :: FilePath -> ExportLocation -> FilePath+exportPath d loc = d </> fromExportLocation loc++{- Removes the ExportLocation directory and its parents, so long as+ - they're empty, up to but not including the topdir. -}+removeExportLocation :: FilePath -> ExportLocation -> IO ()+removeExportLocation topdir loc = go (Just $ fromExportLocation loc) (Right ())+  where+	go _ (Left _e) = return ()+	go Nothing _ = return ()+	go (Just loc') _ = go (upFrom loc')+		=<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation loc'))
Remote/External.hs view
@@ -11,6 +11,7 @@ import qualified Annex import Annex.Common import Types.Remote+import Types.Export import Types.CleanupActions import Types.UrlContents import qualified Git@@ -18,6 +19,7 @@ import Git.Config (isTrue, boolConfig) import Git.Env import Remote.Helper.Special+import Remote.Helper.Export import Remote.Helper.ReadOnly import Remote.Helper.Messages import Utility.Metered@@ -39,12 +41,13 @@ import qualified Data.Map as M  remote :: RemoteType-remote = RemoteType {-	typename = "external",-	enumerate = const (findSpecialRemotes "externaltype"),-	generate = gen,-	setup = externalSetup-}+remote = RemoteType+	{ typename = "external"+	, enumerate = const (findSpecialRemotes "externaltype")+	, generate = gen+	, setup = externalSetup+	, exportSupported = checkExportSupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc@@ -59,21 +62,41 @@ 			Nothing 			Nothing 			Nothing+			exportUnsupported+			exportUnsupported 	| otherwise = do 		external <- newExternal externaltype u c gc 		Annex.addCleanup (RemoteCleanup u) $ stopExternal external 		cst <- getCost external r gc 		avail <- getAvailability external r gc+		exportsupported <- checkExportSupported' external+		let exportactions = if exportsupported+			then return $ ExportActions+				{ storeExport = storeExportM external+				, retrieveExport = retrieveExportM external+				, removeExport = removeExportM external+				, checkPresentExport = checkPresentExportM external+				, removeExportDirectory = Just $ removeExportDirectoryM external+				, renameExport = renameExportM external+				}+			else exportUnsupported+		-- Cheap exportSupported that replaces the expensive+		-- checkExportSupported now that we've already checked it.+		let cheapexportsupported = if exportsupported+			then exportIsSupported+			else exportUnsupported 		mk cst avail-			(store external)-			(retrieve external)-			(remove external)-			(checkKey external)-			(Just (whereis external))-			(Just (claimurl external))-			(Just (checkurl external))+			(storeKeyM external)+			(retrieveKeyFileM external)+			(removeKeyM external)+			(checkPresentM external)+			(Just (whereisKeyM external))+			(Just (claimUrlM external))+			(Just (checkUrlM external))+			exportactions+			cheapexportsupported   where-	mk cst avail tostore toretrieve toremove tocheckkey towhereis toclaimurl tocheckurl = do+	mk cst avail tostore toretrieve toremove tocheckkey towhereis toclaimurl tocheckurl exportactions cheapexportsupported = do 		let rmt = Remote 			{ uuid = u 			, cost = cst@@ -85,6 +108,7 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False+			, exportActions = exportactions 			, whereisKey = towhereis 			, remoteFsck = Nothing 			, repairRepo = Nothing@@ -94,7 +118,8 @@ 			, gitconfig = gc 			, readonly = False 			, availability = avail-			, remotetype = remote+			, remotetype = remote +				{ exportSupported = cheapexportsupported } 			, mkUnavailable = gen r u c $ 				gc { remoteAnnexExternalType = Just "!dne!" } 			, getInfo = return [("externaltype", externaltype)]@@ -132,8 +157,23 @@ 	gitConfigSpecialRemote u c'' "externaltype" externaltype 	return (c'', u) -store :: External -> Storer-store external = fileStorer $ \k f p ->+checkExportSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool+checkExportSupported c gc = do+	let externaltype = fromMaybe (giveup "Specify externaltype=") $+		remoteAnnexExternalType gc <|> M.lookup "externaltype" c+	checkExportSupported' +		=<< newExternal externaltype NoUUID c gc++checkExportSupported' :: External -> Annex Bool+checkExportSupported' external = safely $+	handleRequest external EXPORTSUPPORTED Nothing $ \resp -> case resp of+		EXPORTSUPPORTED_SUCCESS -> Just $ return True+		EXPORTSUPPORTED_FAILURE -> Just $ return False+		UNSUPPORTED_REQUEST -> Just $ return False+		_ -> Nothing++storeKeyM :: External -> Storer+storeKeyM external = fileStorer $ \k f p -> 	handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp -> 		case resp of 			TRANSFER_SUCCESS Upload k' | k == k' ->@@ -144,8 +184,8 @@ 					return False 			_ -> Nothing -retrieve :: External -> Retriever-retrieve external = fileRetriever $ \d k p -> +retrieveKeyFileM :: External -> Retriever+retrieveKeyFileM external = fileRetriever $ \d k p ->  	handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp -> 		case resp of 			TRANSFER_SUCCESS Download k'@@ -154,8 +194,8 @@ 				| k == k' -> Just $ giveup errmsg 			_ -> Nothing -remove :: External -> Remover-remove external k = safely $ +removeKeyM :: External -> Remover+removeKeyM external k = safely $  	handleRequestKey external REMOVE k Nothing $ \resp -> 		case resp of 			REMOVE_SUCCESS k'@@ -166,8 +206,8 @@ 					return False 			_ -> Nothing -checkKey :: External -> CheckPresent-checkKey external k = either giveup id <$> go+checkPresentM :: External -> CheckPresent+checkPresentM external k = either giveup id <$> go   where 	go = handleRequestKey external CHECKPRESENT k Nothing $ \resp -> 		case resp of@@ -179,13 +219,95 @@ 				| k' == k -> Just $ return $ Left errmsg 			_ -> Nothing -whereis :: External -> Key -> Annex [String]-whereis external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of+whereisKeyM :: External -> Key -> Annex [String]+whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of 	WHEREIS_SUCCESS s -> Just $ return [s] 	WHEREIS_FAILURE -> Just $ return [] 	UNSUPPORTED_REQUEST -> Just $ return [] 	_ -> Nothing +storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportM external f k loc p = safely $+	handleRequestExport external loc req k (Just p) $ \resp -> case resp of+		TRANSFER_SUCCESS Upload k' | k == k' ->+			Just $ return True+		TRANSFER_FAILURE Upload k' errmsg | k == k' ->+			Just $ do+				warning errmsg+				return False+		UNSUPPORTED_REQUEST -> Just $ do+			warning "TRANSFEREXPORT not implemented by external special remote"+			return False+		_ -> Nothing+  where+	req sk = TRANSFEREXPORT Upload sk f++retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool+retrieveExportM external k loc d p = safely $+	handleRequestExport external loc req k (Just p) $ \resp -> case resp of+		TRANSFER_SUCCESS Download k'+			| k == k' -> Just $ return True+		TRANSFER_FAILURE Download k' errmsg+			| k == k' -> Just $ do+				warning errmsg+				return False+		UNSUPPORTED_REQUEST -> Just $ do+			warning "TRANSFEREXPORT not implemented by external special remote"+			return False+		_ -> Nothing+  where+	req sk = TRANSFEREXPORT Download sk d++checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool+checkPresentExportM external k loc = either giveup id <$> go+  where+	go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of+		CHECKPRESENT_SUCCESS k'+			| k' == k -> Just $ return $ Right True+		CHECKPRESENT_FAILURE k'+			| k' == k -> Just $ return $ Right False+		CHECKPRESENT_UNKNOWN k' errmsg+			| k' == k -> Just $ return $ Left errmsg+		UNSUPPORTED_REQUEST -> Just $ return $+			Left "CHECKPRESENTEXPORT not implemented by external special remote"+		_ -> Nothing++removeExportM :: External -> Key -> ExportLocation -> Annex Bool+removeExportM external k loc = safely $+	handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of+		REMOVE_SUCCESS k'+			| k == k' -> Just $ return True+		REMOVE_FAILURE k' errmsg+			| k == k' -> Just $ do+				warning errmsg+				return False+		UNSUPPORTED_REQUEST -> Just $ do+			warning "REMOVEEXPORT not implemented by external special remote"+			return False+		_ -> Nothing++removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool+removeExportDirectoryM external dir = safely $+	handleRequest external req Nothing $ \resp -> case resp of+		REMOVEEXPORTDIRECTORY_SUCCESS -> Just $ return True+		REMOVEEXPORTDIRECTORY_FAILURE -> Just $ return False+		UNSUPPORTED_REQUEST -> Just $ return True+		_ -> Nothing+  where+	req = REMOVEEXPORTDIRECTORY dir++renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool+renameExportM external k src dest = safely $+	handleRequestExport external src req k Nothing $ \resp -> case resp of+		RENAMEEXPORT_SUCCESS k'+			| k' == k -> Just $ return True+		RENAMEEXPORT_FAILURE k' +			| k' == k -> Just $ return False+		UNSUPPORTED_REQUEST -> Just $ return False+		_ -> Nothing+  where+	req sk = RENAMEEXPORT sk dest+ safely :: Annex Bool -> Annex Bool safely a = go =<< tryNonAsync a   where@@ -217,6 +339,16 @@ 	Right sk -> handleRequest external (mkreq sk) mp responsehandler 	Left e -> giveup e +{- Export location is first sent in an EXPORT message before+ - the main request. This is done because the ExportLocation can+ - contain spaces etc. -}+handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a+handleRequestExport external loc mkreq k mp responsehandler = do+	withExternalState external $ \st -> do+		checkPrepared st external+		sendMessage st external (EXPORT loc)+	handleRequestKey external mkreq k mp responsehandler+ handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequest' st external req mp responsehandler 	| needsPREPARE req = do@@ -499,16 +631,16 @@ 		return avail 	defavail = return GloballyAvailable -claimurl :: External -> URLString -> Annex Bool-claimurl external url =+claimUrlM :: External -> URLString -> Annex Bool+claimUrlM external url = 	handleRequest external (CLAIMURL url) Nothing $ \req -> case req of 		CLAIMURL_SUCCESS -> Just $ return True 		CLAIMURL_FAILURE -> Just $ return False 		UNSUPPORTED_REQUEST -> Just $ return False 		_ -> Nothing -checkurl :: External -> URLString -> Annex UrlContents-checkurl external url = +checkUrlM :: External -> URLString -> Annex UrlContents+checkUrlM external url =  	handleRequest external (CHECKURL url) Nothing $ \req -> case req of 		CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz 			(if null f then Nothing else Just $ mkSafeFilePath f)
Remote/External/Types.hs view
@@ -37,6 +37,7 @@ import Types.Transfer (Direction(..)) import Config.Cost (Cost) import Types.Remote (RemoteConfig)+import Types.Export import Types.Availability (Availability(..)) import Types.Key import Utility.Url (URLString)@@ -116,12 +117,20 @@ 	| CHECKPRESENT SafeKey 	| REMOVE SafeKey 	| WHEREIS SafeKey+	| EXPORTSUPPORTED+	| EXPORT ExportLocation+	| TRANSFEREXPORT Direction SafeKey FilePath+	| CHECKPRESENTEXPORT SafeKey+	| REMOVEEXPORT SafeKey+	| REMOVEEXPORTDIRECTORY ExportDirectory+	| RENAMEEXPORT SafeKey ExportLocation 	deriving (Show)  -- Does PREPARE need to have been sent before this request? needsPREPARE :: Request -> Bool needsPREPARE PREPARE = False needsPREPARE INITREMOTE = False+needsPREPARE EXPORTSUPPORTED = False needsPREPARE _ = True  instance Proto.Sendable Request where@@ -137,9 +146,29 @@ 		, Proto.serialize key 		, Proto.serialize file 		]-	formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", Proto.serialize key ]+	formatMessage (CHECKPRESENT key) =+		[ "CHECKPRESENT", Proto.serialize key ] 	formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ] 	formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]+	formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"]+	formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]+	formatMessage (TRANSFEREXPORT direction key file) = +		[ "TRANSFEREXPORT"+		, Proto.serialize direction+		, Proto.serialize key+		, Proto.serialize file+		]+	formatMessage (CHECKPRESENTEXPORT key) =+		[ "CHECKPRESENTEXPORT", Proto.serialize key ]+	formatMessage (REMOVEEXPORT key) =+		[ "REMOVEEXPORT", Proto.serialize key ]+	formatMessage (REMOVEEXPORTDIRECTORY dir) =+		[ "REMOVEEXPORTDIRECTORY", Proto.serialize dir ]+	formatMessage (RENAMEEXPORT key newloc) =+		[ "RENAMEEXPORT"+		, Proto.serialize key+		, Proto.serialize newloc+		]  -- Responses the external remote can make to requests. data Response@@ -163,6 +192,12 @@ 	| CHECKURL_FAILURE ErrorMsg 	| WHEREIS_SUCCESS String 	| WHEREIS_FAILURE+	| EXPORTSUPPORTED_SUCCESS+	| EXPORTSUPPORTED_FAILURE+	| REMOVEEXPORTDIRECTORY_SUCCESS+	| REMOVEEXPORTDIRECTORY_FAILURE+	| RENAMEEXPORT_SUCCESS Key+	| RENAMEEXPORT_FAILURE Key 	| UNSUPPORTED_REQUEST 	deriving (Show) @@ -187,6 +222,12 @@ 	parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE 	parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS 	parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE+	parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS+	parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE+	parseCommand "REMOVEEXPORTDIRECTORY-SUCCESS" = Proto.parse0 REMOVEEXPORTDIRECTORY_SUCCESS+	parseCommand "REMOVEEXPORTDIRECTORY-FAILURE" = Proto.parse0 REMOVEEXPORTDIRECTORY_FAILURE+	parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS+	parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE 	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST 	parseCommand _ = Proto.parseFail @@ -315,3 +356,11 @@ instance Proto.Serializable URI where 	serialize = show 	deserialize = parseURI++instance Proto.Serializable ExportLocation where+	serialize = fromExportLocation+	deserialize = Just . mkExportLocation++instance Proto.Serializable ExportDirectory where+	serialize = fromExportDirectory+	deserialize = Just . mkExportDirectory
Remote/GCrypt.hs view
@@ -38,6 +38,7 @@ import Remote.Helper.Encryptable import Remote.Helper.Special import Remote.Helper.Messages+import Remote.Helper.Export import qualified Remote.Helper.Ssh as Ssh import Utility.Metered import Annex.UUID@@ -51,14 +52,15 @@ import Utility.SshHost  remote :: RemoteType-remote = RemoteType {-	typename = "gcrypt",+remote = RemoteType+	{ typename = "gcrypt" 	-- Remote.Git takes care of enumerating gcrypt remotes too, 	-- and will call our gen on them.-	enumerate = const (return []),-	generate = gen,-	setup = gCryptSetup-}+	, enumerate = const (return [])+	, generate = gen+	, setup = gCryptSetup+	, exportSupported = exportUnsupported+	}  chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen gcryptr u c gc = do@@ -114,6 +116,7 @@ 		, lockContent = Nothing 		, checkPresent = checkPresentDummy 		, checkPresentCheap = repoCheap r+		, exportActions = exportUnsupported 		, whereisKey = Nothing 		, remoteFsck = Nothing 		, repairRepo = Nothing
Remote/Git.hs view
@@ -50,6 +50,7 @@ import Utility.SimpleProtocol import Remote.Helper.Git import Remote.Helper.Messages+import Remote.Helper.Export import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt import qualified Remote.P2P@@ -66,12 +67,13 @@ import Network.URI  remote :: RemoteType-remote = RemoteType {-	typename = "git",-	enumerate = list,-	generate = gen,-	setup = gitSetup-}+remote = RemoteType+	{ typename = "git"+	, enumerate = list+	, generate = gen+	, setup = gitSetup+	, exportSupported = exportUnsupported+	}  list :: Bool -> Annex [Git.Repo] list autoinit = do@@ -110,7 +112,7 @@ 	if isNothing mu || mu == Just u 		then return (c, u) 		else error "git remote did not have specified uuid"-gitSetup Enable (Just u) _ c _ = do+gitSetup (Enable _) (Just u) _ c _ = do 	inRepo $ Git.Command.run 		[ Param "remote" 		, Param "add"@@ -118,7 +120,7 @@ 		, Param $ fromMaybe (giveup "no location") (M.lookup "location" c) 		] 	return (c, u)-gitSetup Enable Nothing _ _ _ = error "unable to enable git remote with no specified uuid"+gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid"  {- It's assumed to be cheap to read the config of non-URL remotes, so this is  - done each time git-annex is run in a way that uses remotes.@@ -157,6 +159,7 @@ 			, lockContent = Just (lockKey new) 			, checkPresent = inAnnex new 			, checkPresentCheap = repoCheap r+			, exportActions = exportUnsupported 			, whereisKey = Nothing 			, remoteFsck = if Git.repoIsUrl r 				then Nothing
Remote/Glacier.hs view
@@ -18,6 +18,7 @@ import Config.Cost import Remote.Helper.Special import Remote.Helper.Messages+import Remote.Helper.Export import qualified Remote.Helper.AWS as AWS import Creds import Utility.Metered@@ -29,12 +30,13 @@ type Archive = FilePath  remote :: RemoteType-remote = RemoteType {-	typename = "glacier",-	enumerate = const (findSpecialRemotes "glacier"),-	generate = gen,-	setup = glacierSetup-}+remote = RemoteType+	{ typename = "glacier"+	, enumerate = const (findSpecialRemotes "glacier")+	, generate = gen+	, setup = glacierSetup+	, exportSupported = exportUnsupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost@@ -57,6 +59,7 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False+			, exportActions = exportUnsupported 			, whereisKey = Nothing 			, remoteFsck = Nothing 			, repairRepo = Nothing@@ -87,8 +90,9 @@ 	(c', encsetup) <- encryptionSetup c gc 	c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds 	let fullconfig = c'' `M.union` defaults-	when (ss == Init) $-		genVault fullconfig gc u+	case ss of+		Init -> genVault fullconfig gc u+		_ -> return () 	gitConfigSpecialRemote u fullconfig "glacier" "true" 	return (fullconfig, u)   where
Remote/Helper/Encryptable.hs view
@@ -15,6 +15,7 @@ 	embedCreds, 	cipherKey, 	extractCipher,+	isEncrypted, 	describeEncryption, ) where @@ -57,7 +58,7 @@ 	encryption = M.lookup "encryption" c 	-- Generate a new cipher, depending on the chosen encryption scheme 	genCipher cmd = case encryption of-		_ | M.member "cipher" c || M.member "cipherkeys" c || M.member "pubkeys" c -> cannotchange+		_ | hasEncryptionConfig c -> cannotchange 		Just "none" -> return (c, NoEncryption) 		Just "shared" -> encsetup $ genSharedCipher cmd 		-- hybrid encryption is the default when a keyid is@@ -166,6 +167,15 @@ 	_ -> Nothing   where 	readkeys = KeyIds . splitc ','++isEncrypted :: RemoteConfig -> Bool+isEncrypted c = case M.lookup "encryption" c of+	Just "none" -> False+	Just _ -> True+	Nothing -> hasEncryptionConfig c++hasEncryptionConfig :: RemoteConfig -> Bool+hasEncryptionConfig c = M.member "cipher" c || M.member "cipherkeys" c || M.member "pubkeys" c  describeEncryption :: RemoteConfig -> String describeEncryption c = case extractCipher c of
+ Remote/Helper/Export.hs view
@@ -0,0 +1,158 @@+{- exports to remotes+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE FlexibleInstances #-}++module Remote.Helper.Export where++import Annex.Common+import Types.Remote+import Types.Backend+import Types.Key+import Backend+import Remote.Helper.Encryptable (isEncrypted)+import Database.Export+import Annex.Export++import qualified Data.Map as M+import Control.Concurrent.STM++-- | Use for remotes that do not support exports.+class HasExportUnsupported a where+	exportUnsupported :: a++instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where+	exportUnsupported = \_ _ -> return False++instance HasExportUnsupported (Annex (ExportActions Annex)) where+	exportUnsupported = return $ ExportActions+		{ storeExport = \_ _ _ _ -> do+			warning "store export is unsupported"+			return False+		, retrieveExport = \_ _ _ _ -> return False+		, checkPresentExport = \_ _ -> return False+		, removeExport = \_ _ -> return False+		, removeExportDirectory = Just $ \_ -> return False+		, renameExport = \_ _ _ -> return False+		}++exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool+exportIsSupported = \_ _ -> return True++-- | Prevent or allow exporttree=yes when setting up a new remote,+-- depending on exportSupported and other configuration.+adjustExportableRemoteType :: RemoteType -> RemoteType+adjustExportableRemoteType rt = rt { setup = setup' }+  where+	setup' st mu cp c gc = do+		let cont = setup rt st mu cp c gc+		ifM (exportSupported rt c gc)+			( case st of+				Init+					| exportTree c && isEncrypted c ->+						giveup "cannot enable both encryption and exporttree"+					| otherwise -> cont+				Enable oldc+					| exportTree c /= exportTree oldc ->+						giveup "cannot change exporttree of existing special remote"+					| otherwise -> cont+			, if exportTree c+				then giveup "exporttree=yes is not supported by this special remote"+				else cont+			)++-- | If the remote is exportSupported, and exporttree=yes, adjust the+-- remote to be an export.+adjustExportable :: Remote -> Annex Remote+adjustExportable r = case M.lookup "exporttree" (config r) of+	Just "yes" -> ifM (isExportSupported r)+		( isexport+		, notexport+		)+	Nothing -> notexport+	Just "no" -> notexport+	Just _ -> error "bad exporttree value"+  where+	notexport = return $ r +		{ exportActions = exportUnsupported+		, remotetype = (remotetype r)+			{ exportSupported = exportUnsupported+			}+		}+	isexport = do+		db <- openDb (uuid r)++		updateflag <- liftIO newEmptyTMVarIO+		let updateonce = liftIO $ atomically $+			ifM (isEmptyTMVar updateflag)+				( do+					putTMVar updateflag ()+					return True+				, return False+				)+		+		-- Get export locations for a key. Checks once+		-- if the export log is different than the database and+		-- updates the database, to notice when an export has been+		-- updated from another repository.+		let getexportlocs = \k -> do+			whenM updateonce $+				updateExportTreeFromLog db+			liftIO $ getExportTree db k++		return $ r+			-- Storing a key on an export could be implemented,+			-- but it would perform unncessary work+			-- when another repository has already stored the+			-- key, and the local repository does not know+			-- about it. To avoid unnecessary costs, don't do it.+			{ storeKey = \_ _ _ -> do+				warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it"+				return False+			-- Keys can be retrieved, but since an export+			-- is not a true key/value store, the content of+			-- the key has to be able to be strongly verified.+			, retrieveKeyFile = \k _af dest p -> unVerified $+				if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))+					then do+						locs <- getexportlocs k+						case locs of+							[] -> do+								warning "unknown export location"+								return False+							(l:_) -> do+								ea <- exportActions r+								retrieveExport ea k l dest p+					else do+						warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"+						return False+			, retrieveKeyFileCheap = \_ _ _ -> return False+			-- Removing a key from an export would need to+			-- change the tree in the export log to not include+			-- the file. Otherwise, conflicts when removing+			-- files would not be dealt with correctly.+			-- There does not seem to be a good use case for+			-- removing a key from an export in any case.+			, removeKey = \_k -> do+				warning "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"+				return False+			-- Can't lock content on exports, since they're+			-- not key/value stores, and someone else could+			-- change what's exported to a file at any time.+			, lockContent = Nothing+			-- Check if any of the files a key was exported+			-- to are present. This doesn't guarantee the+			-- export contains the right content.+			, checkPresent = \k -> do+				ea <- exportActions r+				anyM (checkPresentExport ea k)+					=<< getexportlocs k+			, mkUnavailable = return Nothing+			, getInfo = do+				is <- getInfo r+				return (is++[("export", "yes")])+			}
Remote/Hook.hs view
@@ -16,6 +16,7 @@ import Annex.UUID import Remote.Helper.Special import Remote.Helper.Messages+import Remote.Helper.Export import Utility.Env import Messages.Progress @@ -25,12 +26,13 @@ type HookName = String  remote :: RemoteType-remote = RemoteType {-	typename = "hook",-	enumerate = const (findSpecialRemotes "hooktype"),-	generate = gen,-	setup = hookSetup-}+remote = RemoteType+	{ typename = "hook"+	, enumerate = const (findSpecialRemotes "hooktype")+	, generate = gen+	, setup = hookSetup+	, exportSupported = exportUnsupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do@@ -51,6 +53,7 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False+			, exportActions = exportUnsupported 			, whereisKey = Nothing 			, remoteFsck = Nothing 			, repairRepo = Nothing
Remote/List.hs view
@@ -18,6 +18,7 @@ import Annex.UUID import Remote.Helper.Hooks import Remote.Helper.ReadOnly+import Remote.Helper.Export import qualified Git import qualified Git.Config @@ -42,7 +43,7 @@ import qualified Remote.External  remoteTypes :: [RemoteType]-remoteTypes =+remoteTypes = map adjustExportableRemoteType 	[ Remote.Git.remote 	, Remote.GCrypt.remote 	, Remote.P2P.remote@@ -100,8 +101,9 @@ 	u <- getRepoUUID r 	gc <- Annex.getRemoteGitConfig r 	let c = fromMaybe M.empty $ M.lookup u m-	mrmt <- generate t r u c gc-	return $ adjustReadOnly . addHooks <$> mrmt+	generate t r u c gc >>= maybe+		(return Nothing)+		(Just <$$> adjustExportable . adjustReadOnly . addHooks)  {- Updates a local git Remote, re-reading its git config. -} updateRemote :: Remote -> Annex (Maybe Remote)
Remote/P2P.hs view
@@ -24,6 +24,7 @@ import Config import Config.Cost import Remote.Helper.Git+import Remote.Helper.Export import Messages.Progress import Utility.Metered import Utility.AuthToken@@ -33,14 +34,15 @@ import Control.Concurrent.STM  remote :: RemoteType-remote = RemoteType {-	typename = "p2p",+remote = RemoteType+	{ typename = "p2p" 	-- Remote.Git takes care of enumerating P2P remotes, 	-- and will call chainGen on them.-	enumerate = const (return []),-	generate = \_ _ _ _ -> return Nothing,-	setup = error "P2P remotes are set up using git-annex p2p"-}+	, enumerate = const (return [])+	, generate = \_ _ _ _ -> return Nothing+	, setup = error "P2P remotes are set up using git-annex p2p"+	, exportSupported = exportUnsupported+	}  chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen addr r u c gc = do@@ -57,6 +59,7 @@ 		, lockContent = Just (lock u addr connpool) 		, checkPresent = checkpresent u addr connpool 		, checkPresentCheap = False+		, exportActions = exportUnsupported 		, whereisKey = Nothing 		, remoteFsck = Nothing 		, repairRepo = Nothing
Remote/Rsync.hs view
@@ -28,6 +28,7 @@ import Annex.Ssh import Remote.Helper.Special import Remote.Helper.Messages+import Remote.Helper.Export import Remote.Rsync.RsyncUrl import Crypto import Utility.Rsync@@ -43,12 +44,13 @@ import qualified Data.Map as M  remote :: RemoteType-remote = RemoteType {-	typename = "rsync",-	enumerate = const (findSpecialRemotes "rsyncurl"),-	generate = gen,-	setup = rsyncSetup-}+remote = RemoteType+	{ typename = "rsync"+	, enumerate = const (findSpecialRemotes "rsyncurl")+	, generate = gen+	, setup = rsyncSetup+	, exportSupported = exportUnsupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do@@ -73,6 +75,7 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False+			, exportActions = exportUnsupported 			, whereisKey = Nothing 			, remoteFsck = Nothing 			, repairRepo = Nothing
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes  -- - Copyright 2011-2015 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -33,12 +33,15 @@  import Annex.Common import Types.Remote+import Types.Export+import Annex.Export import qualified Git import Config import Config.Cost import Remote.Helper.Special import Remote.Helper.Http import Remote.Helper.Messages+import Remote.Helper.Export import qualified Remote.Helper.AWS as AWS import Creds import Annex.UUID@@ -53,12 +56,13 @@ type BucketName = String  remote :: RemoteType-remote = RemoteType {-	typename = "S3",-	enumerate = const (findSpecialRemotes "s3"),-	generate = gen,-	setup = s3Setup-}+remote = RemoteType+	{ typename = "S3"+	, enumerate = const (findSpecialRemotes "s3")+	, generate = gen+	, setup = s3Setup+	, exportSupported = exportIsSupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do@@ -84,7 +88,17 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False-			, whereisKey = Just (getWebUrls info)+			, exportActions = withS3Handle c gc u $ \h -> +				return $ ExportActions+					{ storeExport = storeExportS3 info h+					, retrieveExport = retrieveExportS3 info h+					, removeExport = removeExportS3 info h+					, checkPresentExport = checkPresentExportS3 info h+					-- S3 does not have directories.+					, removeExportDirectory = Nothing+					, renameExport = renameExportS3 info h+					}+			, whereisKey = Just (getWebUrls info c) 			, remoteFsck = Nothing 			, repairRepo = Nothing 			, config = c@@ -104,6 +118,7 @@ s3Setup ss mu mcreds c gc = do 	u <- maybe (liftIO genUUID) return mu 	s3Setup' ss u mcreds c gc+ s3Setup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) s3Setup' ss u mcreds c gc 	| configIA c = archiveorg@@ -127,8 +142,9 @@ 		(c', encsetup) <- encryptionSetup c gc 		c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds 		let fullconfig = c'' `M.union` defaults-		when (ss == Init) $-			genBucket fullconfig gc u+		case ss of+			Init -> genBucket fullconfig gc u+			_ -> return () 		use fullconfig  	archiveorg = do@@ -166,25 +182,26 @@  store :: Remote -> S3Info -> S3Handle -> Storer store _r info h = fileStorer $ \k f p -> do-	case partSize info of-		Just partsz | partsz > 0 -> do-			fsz <- liftIO $ getFileSize f-			if fsz > partsz-				then multipartupload fsz partsz k f p-				else singlepartupload k f p-		_ -> singlepartupload k f p	+	storeHelper info h f (T.pack $ bucketObject info k) p 	-- Store public URL to item in Internet Archive. 	when (isIA info && not (isChunkKey k)) $ 		setUrlPresent webUUID k (iaPublicKeyUrl info k) 	return True++storeHelper :: S3Info -> S3Handle -> FilePath -> S3.Object -> MeterUpdate -> Annex ()+storeHelper info h f object p = case partSize info of+	Just partsz | partsz > 0 -> do+		fsz <- liftIO $ getFileSize f+		if fsz > partsz+			then multipartupload fsz partsz+			else singlepartupload+	_ -> singlepartupload   where-	singlepartupload k f p = do+	singlepartupload = do 		rbody <- liftIO $ httpBodyStorer f p-		void $ sendS3Handle h $ putObject info (T.pack $ bucketObject info k) rbody-	multipartupload fsz partsz k f p = do+		void $ sendS3Handle h $ putObject info object rbody+	multipartupload fsz partsz = do #if MIN_VERSION_aws(0,10,6)-		let object = T.pack (bucketObject info k)- 		let startreq = (S3.postInitiateMultipartUpload (bucket info) object) 				{ S3.imuStorageClass = Just (storageClass info) 				, S3.imuMetadata = metaHeaders info@@ -223,16 +240,27 @@ 			(bucket info) object uploadid (zip [1..] etags) #else 		warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library."-		singlepartupload k f p+		singlepartupload #endif  {- Implemented as a fileRetriever, that uses conduit to stream the chunks  - out to the file. Would be better to implement a byteRetriever, but  - that is difficult. -} retrieve :: Remote -> S3Info -> Maybe S3Handle -> Retriever-retrieve _ info (Just h) = fileRetriever $ \f k p -> liftIO $ runResourceT $ do+retrieve _ info (Just h) = fileRetriever $ \f k p ->+	retrieveHelper info h (T.pack $ bucketObject info k) f p+retrieve r info Nothing = case getpublicurl info of+	Nothing -> \_ _ _ -> do+		warnMissingCredPairFor "S3" (AWS.creds $ uuid r)+		return False+	Just geturl -> fileRetriever $ \f k p ->+		unlessM (downloadUrl k p [geturl k] f) $+			giveup "failed to download content"++retrieveHelper :: S3Info -> S3Handle -> S3.Object -> FilePath -> MeterUpdate -> Annex ()+retrieveHelper info h object f p = liftIO $ runResourceT $ do 	(fr, fh) <- allocate (openFile f WriteMode) hClose-	let req = S3.getObject (bucket info) (T.pack $ bucketObject info k)+	let req = S3.getObject (bucket info) object 	S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req 	responseBody rsp $$+- sinkprogressfile fh p zeroBytesProcessed 	release fr@@ -247,13 +275,6 @@ 					void $ meterupdate sofar' 					S.hPut fh bs 				sinkprogressfile fh meterupdate sofar'-retrieve r info Nothing = case getpublicurl info of-	Nothing -> \_ _ _ -> do-		warnMissingCredPairFor "S3" (AWS.creds $ uuid r)-		return False-	Just geturl -> fileRetriever $ \f k p ->-		unlessM (downloadUrl k p [geturl k] f) $-			giveup "failed to download content"  retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False@@ -262,18 +283,25 @@  - While it may remove the file, there are generally other files  - derived from it that it does not remove. -} remove :: S3Info -> S3Handle -> Remover-remove info h k-	| isIA info = do-		warning "Cannot remove content from the Internet Archive"-		return False-	| otherwise = do-		res <- tryNonAsync $ sendS3Handle h $-			S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)-		return $ either (const False) (const True) res+remove info h k = do+	res <- tryNonAsync $ sendS3Handle h $+		S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)+	return $ either (const False) (const True) res  checkKey :: Remote -> S3Info -> Maybe S3Handle -> CheckPresent+checkKey r info Nothing k = case getpublicurl info of+	Nothing -> do+		warnMissingCredPairFor "S3" (AWS.creds $ uuid r)+		giveup "No S3 credentials configured"+	Just geturl -> do+		showChecking r+		withUrlOptions $ checkBoth (geturl k) (keySize k) checkKey r info (Just h) k = do 	showChecking r+	checkKeyHelper info h (T.pack $ bucketObject info k)++checkKeyHelper :: S3Info -> S3Handle -> S3.Object -> Annex Bool+checkKeyHelper info h object = do #if MIN_VERSION_aws(0,10,0) 	rsp <- go 	return (isJust $ S3.horMetadata rsp)@@ -283,8 +311,7 @@ 		return True #endif   where-	go = sendS3Handle h $-		S3.headObject (bucket info) (T.pack $ bucketObject info k)+	go = sendS3Handle h $ S3.headObject (bucket info) object  #if ! MIN_VERSION_aws(0,10,0) 	{- Catch exception headObject returns when an object is not present@@ -299,14 +326,50 @@ 			| otherwise = Nothing #endif -checkKey r info Nothing k = case getpublicurl info of-	Nothing -> do-		warnMissingCredPairFor "S3" (AWS.creds $ uuid r)-		giveup "No S3 credentials configured"-	Just geturl -> do-		showChecking r-		withUrlOptions $ checkBoth (geturl k) (keySize k)+storeExportS3 :: S3Info -> S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportS3 info h f _k loc p = +	catchNonAsync go (\e -> warning (show e) >> return False)+  where+	go = do+		storeHelper info h f (T.pack $ bucketExportLocation info loc) p+		return True +retrieveExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool+retrieveExportS3 info h _k loc f p =+	catchNonAsync go (\e -> warning (show e) >> return False)+  where+	go = do+		retrieveHelper info h (T.pack $ bucketExportLocation info loc) f p+		return True++removeExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool+removeExportS3 info h _k loc = +	catchNonAsync go (\e -> warning (show e) >> return False)+  where+	go = do+		res <- tryNonAsync $ sendS3Handle h $+			S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)+		return $ either (const False) (const True) res++checkPresentExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool+checkPresentExportS3 info h _k loc =+	checkKeyHelper info h (T.pack $ bucketExportLocation info loc)++-- S3 has no move primitive; copy and delete.+renameExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool+renameExportS3 info h _k src dest = catchNonAsync go (\_ -> return False)+  where+	go = do+		let co = S3.copyObject (bucket info) dstobject+			(S3.ObjectId (bucket info) srcobject Nothing)+			S3.CopyMetadata+		-- ACL is not preserved by copy.+		void $ sendS3Handle h $ co { S3.coAcl = acl info }+		void $ sendS3Handle h $ S3.DeleteObject srcobject (bucket info)+		return True+	srcobject = T.pack $ bucketExportLocation info src+	dstobject = T.pack $ bucketExportLocation info dest+ {- Generate the bucket if it does not already exist, including creating the  - UUID file within the bucket.  -@@ -470,6 +533,7 @@ 	{ bucket :: S3.Bucket 	, storageClass :: S3.StorageClass 	, bucketObject :: Key -> String+	, bucketExportLocation :: ExportLocation -> String 	, metaHeaders :: [(T.Text, T.Text)] 	, partSize :: Maybe Integer 	, isIA :: Bool@@ -487,6 +551,7 @@ 		{ bucket = b 		, storageClass = getStorageClass c 		, bucketObject = getBucketObject c+		, bucketExportLocation = getBucketExportLocation c 		, metaHeaders = getMetaHeaders c 		, partSize = getPartSize c 		, isIA = configIA c@@ -550,9 +615,12 @@ 		Just "ia" -> iaMunge $ getFilePrefix c ++ s 		_ -> getFilePrefix c ++ s -{- Internet Archive limits filenames to a subset of ascii,- - with no whitespace. Other characters are xml entity- - encoded. -}+getBucketExportLocation :: RemoteConfig -> ExportLocation -> FilePath+getBucketExportLocation c loc = getFilePrefix c ++ fromExportLocation loc++{- Internet Archive documentation limits filenames to a subset of ascii.+ - While other characters seem to work now, this entity encodes everything+ - else to avoid problems. -} iaMunge :: String -> String iaMunge = (>>= munge)   where@@ -625,8 +693,10 @@ #endif 	showstorageclass sc = show sc -getWebUrls :: S3Info -> Key -> Annex [URLString]-getWebUrls info k = case (public info, getpublicurl info) of-	(True, Just geturl) -> return [geturl k]-	_ -> return []+getWebUrls :: S3Info -> RemoteConfig -> Key -> Annex [URLString]+getWebUrls info c k+	| exportTree c = return []+	| otherwise = case (public info, getpublicurl info) of+		(True, Just geturl) -> return [geturl k]+		_ -> return []
Remote/Tahoe.hs view
@@ -34,6 +34,7 @@ import Config import Config.Cost import Remote.Helper.Special+import Remote.Helper.Export import Annex.UUID import Annex.Content import Logs.RemoteState@@ -51,12 +52,13 @@ type Capability = String  remote :: RemoteType-remote = RemoteType {-	typename = "tahoe",-	enumerate = const (findSpecialRemotes "tahoe"),-	generate = gen,-	setup = tahoeSetup-}+remote = RemoteType+	{ typename = "tahoe"+	, enumerate = const (findSpecialRemotes "tahoe")+	, generate = gen+	, setup = tahoeSetup+	, exportSupported = exportUnsupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do@@ -75,6 +77,7 @@ 		, lockContent = Nothing 		, checkPresent = checkKey u hdl 		, checkPresentCheap = False+		, exportActions = exportUnsupported 		, whereisKey = Just (getWhereisKey u) 		, remoteFsck = Nothing 		, repairRepo = Nothing
Remote/Web.hs view
@@ -10,6 +10,7 @@ import Annex.Common import Types.Remote import Remote.Helper.Messages+import Remote.Helper.Export import qualified Git import qualified Git.Construct import Annex.Content@@ -22,12 +23,13 @@ import qualified Utility.Quvi as Quvi  remote :: RemoteType-remote = RemoteType {-	typename = "web",-	enumerate = list,-	generate = gen,-	setup = error "not supported"-}+remote = RemoteType+	{ typename = "web"+	, enumerate = list+	, generate = gen+	, setup = error "not supported"+	, exportSupported = exportUnsupported+	}  -- There is only one web remote, and it always exists. -- (If the web should cease to exist, remove this module and redistribute@@ -50,6 +52,7 @@ 		, lockContent = Nothing 		, checkPresent = checkKey 		, checkPresentCheap = False+		, exportActions = exportUnsupported 		, whereisKey = Nothing 		, remoteFsck = Nothing 		, repairRepo = Nothing
Remote/WebDAV.hs view
@@ -1,6 +1,6 @@ {- WebDAV remotes.  -- - Copyright 2012-2014 Joey Hess <id@joeyh.name>+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -15,23 +15,25 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.Lazy.UTF8 as L8-import Network.HTTP.Client (HttpException(..))+import Network.HTTP.Client (HttpException(..), RequestBody) import Network.HTTP.Types import System.IO.Error import Control.Monad.Catch  import Annex.Common import Types.Remote+import Types.Export import qualified Git import Config import Config.Cost import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.Http+import Remote.Helper.Export import qualified Remote.Helper.Chunked.Legacy as Legacy import Creds import Utility.Metered-import Utility.Url (URLString, matchStatusCodeException)+import Utility.Url (URLString, matchStatusCodeException, matchHttpExceptionContent) import Annex.UUID import Remote.WebDAV.DavLocation @@ -40,12 +42,13 @@ #endif  remote :: RemoteType-remote = RemoteType {-	typename = "webdav",-	enumerate = const (findSpecialRemotes "webdav"),-	generate = gen,-	setup = webdavSetup-}+remote = RemoteType+	{ typename = "webdav"+	, enumerate = const (findSpecialRemotes "webdav")+	, generate = gen+	, setup = webdavSetup+	, exportSupported = exportIsSupported+	}  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = new <$> remoteCost gc expensiveRemoteCost@@ -68,6 +71,15 @@ 			, lockContent = Nothing 			, checkPresent = checkPresentDummy 			, checkPresentCheap = False+			, exportActions = withDAVHandle this $ \mh -> return $ ExportActions+				{ storeExport = storeExportDav mh+				, retrieveExport = retrieveExportDav mh+				, checkPresentExport = checkPresentExportDav this mh+				, removeExport = removeExportDav mh+				, removeExportDirectory = Just $+					removeExportDirectoryDav mh+				, renameExport = renameExportDav mh+				} 			, whereisKey = Nothing 			, remoteFsck = Nothing 			, repairRepo = Nothing@@ -111,17 +123,21 @@ store _  (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do 	let tmp = keyTmpLocation k 	let dest = keyLocation k-	void $ mkColRecursive tmpDir+	storeHelper dav tmp dest reqbody+	return True++storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO ()+storeHelper dav tmp dest reqbody = do+	maybe noop (void . mkColRecursive) (locationParent tmp) 	inLocation tmp $ 		putContentM' (contentType, reqbody)-	finalizeStore (baseURL dav) tmp dest-	return True+	finalizeStore dav tmp dest -finalizeStore :: URLString -> DavLocation -> DavLocation -> DAVT IO ()-finalizeStore baseurl tmp dest = do+finalizeStore :: DavHandle -> DavLocation -> DavLocation -> DAVT IO ()+finalizeStore dav tmp dest = do 	inLocation dest $ void $ safely $ delContentM 	maybe noop (void . mkColRecursive) (locationParent dest)-	moveDAV baseurl tmp dest+	moveDAV (baseURL dav) tmp dest  retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False@@ -130,27 +146,30 @@ retrieve _ Nothing = giveup "unable to connect" retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $-	goDAV dav $-		inLocation (keyLocation k) $-			withContentM $-				httpBodyRetriever d p+	goDAV dav $ retrieveHelper (keyLocation k) d p +retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO ()+retrieveHelper loc d p = inLocation loc $+	withContentM $ httpBodyRetriever d p+ remove :: Maybe DavHandle -> Remover remove Nothing _ = return False-remove (Just dav) k = liftIO $ do+remove (Just dav) k = liftIO $ goDAV dav $ 	-- Delete the key's whole directory, including any 	-- legacy chunked files, etc, in a single action.-	let d = keyDir k-	goDAV dav $ do-		v <- safely $ inLocation d delContentM-		case v of-			Just _ -> return True-			Nothing -> do-				v' <- existsDAV d-				case v' of-					Right False -> return True-					_ -> return False+	removeHelper (keyDir k) +removeHelper :: DavLocation -> DAVT IO Bool+removeHelper d = do+	v <- safely $ inLocation d delContentM+	case v of+		Just _ -> return True+		Nothing -> do+			v' <- existsDAV d+			case v' of+				Right False -> return True+				_ -> return False+ checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent checkKey r _ Nothing _ = giveup $ name r ++ " not configured" checkKey r chunkconfig (Just dav) k = do@@ -162,12 +181,57 @@ 				existsDAV (keyLocation k) 			either giveup return v +storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool+storeExportDav mh f k loc p = runExport mh $ \dav -> do+	reqbody <- liftIO $ httpBodyStorer f p+	storeHelper dav (keyTmpLocation k) (exportLocation loc) reqbody+	return True++retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool+retrieveExportDav mh  _k loc d p = runExport mh $ \_dav -> do+	retrieveHelper (exportLocation loc) d p+	return True++checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool+checkPresentExportDav r mh _k loc = case mh of+	Nothing -> giveup $ name r ++ " not configured"+	Just h -> liftIO $ do+		v <- goDAV h $ existsDAV (exportLocation loc)+		either giveup return v++removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool+removeExportDav mh _k loc = runExport mh $ \_dav ->+	removeHelper (exportLocation loc)++removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool+removeExportDirectoryDav mh dir = runExport mh $ \_dav ->+	safely (inLocation (fromExportDirectory dir) delContentM)+		>>= maybe (return False) (const $ return True)++renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool+renameExportDav Nothing _ _ _ = return False+renameExportDav (Just h) _k src dest+	-- box.com's DAV endpoint has buggy handling of renames,+	-- so avoid renaming when using it.+	| boxComUrl `isPrefixOf` baseURL h = return False+	| otherwise = runExport (Just h) $ \dav -> do+		maybe noop (void . mkColRecursive) (locationParent (exportLocation dest))+		moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)+		return True++runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool+runExport Nothing _ = return False+runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))+ configUrl :: Remote -> Maybe URLString configUrl r = fixup <$> M.lookup "url" (config r)   where 	-- box.com DAV url changed-	fixup = replace "https://www.box.com/dav/" "https://dav.box.com/dav/"+	fixup = replace "https://www.box.com/dav/" boxComUrl +boxComUrl :: URLString+boxComUrl = "https://dav.box.com/dav/"+ type DavUser = B8.ByteString type DavPass = B8.ByteString @@ -194,8 +258,8 @@ 	test $ liftIO $ evalDAVT url $ do 		prepDAV user pass 		makeParentDirs-		void $ mkColRecursive tmpDir-		inLocation (tmpLocation "git-annex-test") $ do+		void $ mkColRecursive "/"+		inLocation (tmpLocation "test") $ do 			putContentM (Nothing, L8.fromString "test") 			delContentM   where@@ -269,13 +333,16 @@ 		-- more depth is certainly not needed to check if a 		-- location exists. 		setDepth (Just Depth1)-		catchJust-			(matchStatusCodeException (== notFound404))+		catchJust missinghttpstatus 			(getPropsM >> ispresent True) 			(const $ ispresent False) 	ispresent = return . Right+	missinghttpstatus e = +		matchStatusCodeException (== notFound404) e+		<|> matchHttpExceptionContent toomanyredirects e+	toomanyredirects (TooManyRedirects _) = True+	toomanyredirects _ = False --- Ignores any exceptions when performing a DAV action. safely :: DAVT IO a -> DAVT IO (Maybe a) safely = eitherToMaybe <$$> tryNonAsync @@ -348,7 +415,7 @@ 	storer locs = Legacy.storeChunked chunksize locs storehttp b 	recorder l s = storehttp l (L8.fromString s) 	finalizer tmp' dest' = goDAV dav $ -		finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')+		finalizeStore dav tmp' (fromJust $ locationParent dest')  	tmp = addTrailingPathSeparator $ keyTmpLocation k 	dest = keyLocation k
Remote/WebDAV/DavLocation.hs view
@@ -11,6 +11,7 @@ module Remote.WebDAV.DavLocation where  import Types+import Types.Export import Annex.Locations import Utility.Url (URLString) #ifdef mingw32_HOST_OS@@ -20,14 +21,17 @@ import System.FilePath.Posix -- for manipulating url paths import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) import Control.Monad.IO.Class (MonadIO)+import Network.URI import Data.Default  -- Relative to the top of the DAV url. type DavLocation = String -{- Runs action in subdirectory, relative to the current location. -}+{- Runs action with a new location relative to the current location. -} inLocation :: (MonadIO m) => DavLocation -> DAVT m a -> DAVT m a-inLocation d = inDAVLocation (</> d)+inLocation d = inDAVLocation (</> d')+  where+	d' = escapeURIString isUnescapedInURI d  {- The directory where files(s) for a key are stored. -} keyDir :: Key -> DavLocation@@ -42,15 +46,15 @@ keyLocation :: Key -> DavLocation keyLocation k = keyDir k ++ keyFile k +exportLocation :: ExportLocation -> DavLocation+exportLocation = fromExportLocation+ {- Where we store temporary data for a key as it's being uploaded. -} keyTmpLocation :: Key -> DavLocation keyTmpLocation = tmpLocation . keyFile  tmpLocation :: FilePath -> DavLocation-tmpLocation f = tmpDir </> f--tmpDir :: DavLocation-tmpDir = "tmp"+tmpLocation f = "git-annex-webdav-tmp-" ++ f  locationParent :: String -> Maybe String locationParent loc
Test.hs view
@@ -147,7 +147,7 @@ 		exitWith exitcode 	runsubprocesstests opts (Just _) = isolateGitConfig $ do 		ensuretmpdir-		crippledfilesystem <- Annex.Init.probeCrippledFileSystem' tmpdir+		crippledfilesystem <- annexeval $ Annex.Init.probeCrippledFileSystem' tmpdir 		case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of 			Nothing -> error "No tests found!?" 			Just act -> ifM act
+ Types/Export.hs view
@@ -0,0 +1,53 @@+{- git-annex export types+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Types.Export (+	ExportLocation,+	mkExportLocation,+	fromExportLocation,+	ExportDirectory,+	mkExportDirectory,+	fromExportDirectory,+	exportDirectories,+) where++import Git.FilePath++import qualified System.FilePath.Posix as Posix++-- A location on a remote that a key can be exported to.+-- The FilePath will be relative to the top of the export,+-- and uses unix-style path separators.+newtype ExportLocation = ExportLocation FilePath+	deriving (Show, Eq)++mkExportLocation :: FilePath -> ExportLocation+mkExportLocation = ExportLocation . toInternalGitPath++fromExportLocation :: ExportLocation -> FilePath+fromExportLocation (ExportLocation f) = f++newtype ExportDirectory = ExportDirectory FilePath+	deriving (Show, Eq)++mkExportDirectory :: FilePath -> ExportDirectory+mkExportDirectory = ExportDirectory . toInternalGitPath++fromExportDirectory :: ExportDirectory -> FilePath+fromExportDirectory (ExportDirectory f) = f++-- | All subdirectories down to the ExportLocation, with the deepest ones+-- last. Does not include the top of the export.+exportDirectories :: ExportLocation -> [ExportDirectory]+exportDirectories (ExportLocation f) =+	map (ExportDirectory . Posix.joinPath . reverse) (subs [] dirs)+  where+	subs _ [] = []+	subs ps (d:ds) = (d:ps) : subs (d:ps) ds++	dirs = map Posix.dropTrailingPathSeparator $+		reverse $ drop 1 $ reverse $ Posix.splitPath f
Types/GitConfig.hs view
@@ -199,6 +199,7 @@ 	, remoteAnnexPush :: Bool 	, remoteAnnexReadOnly :: Bool 	, remoteAnnexVerify :: Bool+	, remoteAnnexExportTracking :: Maybe Git.Ref 	, remoteAnnexTrustLevel :: Maybe String 	, remoteAnnexStartCommand :: Maybe String 	, remoteAnnexStopCommand :: Maybe String@@ -247,6 +248,8 @@ 		, remoteAnnexPush = getbool "push" True 		, remoteAnnexReadOnly = getbool "readonly" False 		, remoteAnnexVerify = getbool "verify" True+		, remoteAnnexExportTracking = Git.Ref+			<$> notempty (getmaybe "export-tracking") 		, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel" 		, remoteAnnexStartCommand = notempty $ getmaybe "start-command" 		, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"
Types/Remote.hs view
@@ -2,7 +2,7 @@  -  - Most things should not need this, using Types instead  -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -18,10 +18,12 @@ 	, Availability(..) 	, Verification(..) 	, unVerified+	, isExportSupported+	, ExportActions(..) 	) 	where -import Data.Map as M+import qualified Data.Map as M import Data.Ord  import qualified Git@@ -32,9 +34,10 @@ import Types.Creds import Types.UrlContents import Types.NumCopies+import Types.Export import Config.Cost import Utility.Metered-import Git.Types+import Git.Types (RemoteName) import Utility.SafeCommand import Utility.Url @@ -42,92 +45,96 @@  type RemoteConfig = M.Map RemoteConfigKey String -data SetupStage = Init | Enable-	deriving (Eq)+data SetupStage = Init | Enable RemoteConfig  {- There are different types of remotes. -}-data RemoteTypeA a = RemoteType {+data RemoteTypeA a = RemoteType 	-- human visible type name-	typename :: String,+	{ typename :: String 	-- enumerates remotes of this type 	-- The Bool is True if automatic initialization of remotes is desired-	enumerate :: Bool -> a [Git.Repo],-	-- generates a remote of this type-	generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),+	, enumerate :: Bool -> a [Git.Repo]+	-- generates a remote of this type from the current git config+	, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)) 	-- initializes or enables a remote-	setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)-}+	, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)+	-- check if a remote of this type is able to support export+	, exportSupported :: RemoteConfig -> RemoteGitConfig -> a Bool+	}  instance Eq (RemoteTypeA a) where 	x == y = typename x == typename y  {- An individual remote. -}-data RemoteA a = Remote {+data RemoteA a = Remote 	-- each Remote has a unique uuid-	uuid :: UUID,+	{ uuid :: UUID 	-- each Remote has a human visible name-	name :: RemoteName,+	, name :: RemoteName 	-- Remotes have a use cost; higher is more expensive-	cost :: Cost,+	, cost :: Cost+ 	-- Transfers a key's contents from disk to the remote. 	-- The key should not appear to be present on the remote until 	-- all of its contents have been transferred.-	storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool,+	, storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool 	-- Retrieves a key's contents to a file. 	-- (The MeterUpdate does not need to be used if it writes 	-- sequentially to the file.)-	retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a (Bool, Verification),+	, retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a (Bool, Verification) 	-- Retrieves a key's contents to a tmp file, if it can be done cheaply. 	-- It's ok to create a symlink or hardlink.-	retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool,+	, retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool 	-- Removes a key's contents (succeeds if the contents are not present)-	removeKey :: Key -> a Bool,+	, removeKey :: Key -> a Bool 	-- Uses locking to prevent removal of a key's contents, 	-- thus producing a VerifiedCopy, which is passed to the callback. 	-- If unable to lock, does not run the callback, and throws an 	-- error. 	-- This is optional; remotes do not have to support locking.-	lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r),+	, lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r) 	-- Checks if a key is present in the remote. 	-- Throws an exception if the remote cannot be accessed.-	checkPresent :: Key -> a Bool,+	, checkPresent :: Key -> a Bool 	-- Some remotes can checkPresent without an expensive network 	-- operation.-	checkPresentCheap :: Bool,+	, checkPresentCheap :: Bool+	-- Some remotes support exports of trees.+	, exportActions :: a (ExportActions a) 	-- Some remotes can provide additional details for whereis.-	whereisKey :: Maybe (Key -> a [String]),+	, whereisKey :: Maybe (Key -> a [String]) 	-- Some remotes can run a fsck operation on the remote, 	-- without transferring all the data to the local repo 	-- The parameters are passed to the fsck command on the remote.-	remoteFsck :: Maybe ([CommandParam] -> a (IO Bool)),+	, remoteFsck :: Maybe ([CommandParam] -> a (IO Bool)) 	-- Runs an action to repair the remote's git repository.-	repairRepo :: Maybe (a Bool -> a (IO Bool)),+	, repairRepo :: Maybe (a Bool -> a (IO Bool)) 	-- a Remote has a persistent configuration store-	config :: RemoteConfig,+	, config :: RemoteConfig 	-- git repo for the Remote-	repo :: Git.Repo,+	, repo :: Git.Repo 	-- a Remote's configuration from git-	gitconfig :: RemoteGitConfig,+	, gitconfig :: RemoteGitConfig 	-- a Remote can be assocated with a specific local filesystem path-	localpath :: Maybe FilePath,+	, localpath :: Maybe FilePath 	-- a Remote can be known to be readonly-	readonly :: Bool,+	, readonly :: Bool 	-- a Remote can be globally available. (Ie, "in the cloud".)-	availability :: Availability,+	, availability :: Availability 	-- the type of the remote-	remotetype :: RemoteTypeA a,+	, remotetype :: RemoteTypeA a 	-- For testing, makes a version of this remote that is not 	-- available for use. All its actions should fail.-	mkUnavailable :: a (Maybe (RemoteA a)),+	, mkUnavailable :: a (Maybe (RemoteA a)) 	-- Information about the remote, for git annex info to display.-	getInfo :: a [(String, String)],+	, getInfo :: a [(String, String)] 	-- Some remotes can download from an url (or uri).-	claimUrl :: Maybe (URLString -> a Bool),+	, claimUrl :: Maybe (URLString -> a Bool) 	-- Checks that the url is accessible, and gets information about 	-- its contents, without downloading the full content. 	-- Throws an exception if the url is inaccessible.-	checkUrl :: Maybe (URLString -> a UrlContents)-}+	, checkUrl :: Maybe (URLString -> a UrlContents)+	}  instance Show (RemoteA a) where 	show remote = "Remote { name =\"" ++ name remote ++ "\" }"@@ -150,3 +157,34 @@ unVerified a = do 	ok <- a 	return (ok, UnVerified)++isExportSupported :: RemoteA a -> a Bool+isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r)++data ExportActions a = ExportActions +	-- Exports content to an ExportLocation.+	-- The exported file should not appear to be present on the remote+	-- until all of its contents have been transferred.+	{ storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a Bool+	-- Retrieves exported content to a file.+	-- (The MeterUpdate does not need to be used if it writes+	-- sequentially to the file.)+	, retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Bool+	-- Removes an exported file (succeeds if the contents are not present)+	, removeExport :: Key -> ExportLocation -> a Bool+	-- Removes an exported directory. Typically the directory will be+	-- empty, but it could possbly contain files or other directories,+	-- and it's ok to delete those. If the remote does not use+	-- directories, or automatically cleans up empty directories,+	-- this can be Nothing. Should not fail if the directory was+	-- already removed.+	, removeExportDirectory :: Maybe (ExportDirectory -> a Bool)+	-- Checks if anything is exported to the remote at the specified+	-- ExportLocation.+	-- Throws an exception if the remote cannot be accessed.+	, checkPresentExport :: Key -> ExportLocation -> a Bool+	-- Renames an already exported file.+	-- This may fail, if the file doesn't exist, or the remote does not+	-- support renames.+	, renameExport :: Key -> ExportLocation -> ExportLocation -> a Bool+	}
Types/TrustLevel.hs view
@@ -21,7 +21,7 @@ -- This order may seem backwards, but we generally want to list dead -- remotes last and trusted ones first. data TrustLevel = Trusted | SemiTrusted | UnTrusted | DeadTrusted-	deriving (Eq, Enum, Ord, Bounded)+	deriving (Eq, Enum, Ord, Bounded, Show)  instance Default TrustLevel  where 	def = SemiTrusted
Utility/Tmp.hs view
@@ -28,7 +28,7 @@ {- Runs an action like writeFile, writing to a temp file first and  - then moving it into place. The temp file is stored in the same  - directory as the final file to avoid cross-device renames. -}-viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () viaTmp a file content = bracketIO setup cleanup use   where 	(dir, base) = splitFileName file
Utility/Url.hs view
@@ -27,6 +27,7 @@ 	downloadQuiet, 	parseURIRelaxed, 	matchStatusCodeException,+	matchHttpExceptionContent, ) where  import Common@@ -364,4 +365,17 @@ 	| want s = Just e 	| otherwise = Nothing matchStatusCodeException _ _ = Nothing+#endif++#if MIN_VERSION_http_client(0,5,0)+matchHttpExceptionContent :: (HttpExceptionContent -> Bool) -> HttpException -> Maybe HttpException+matchHttpExceptionContent want e@(HttpExceptionRequest _ hec)+	| want hec = Just e+	| otherwise = Nothing+matchHttpExceptionContent _ _ = Nothing+#else+matchHttpExceptionContent :: (HttpException -> Bool) -> HttpException -> Maybe HttpException+matchHttpExceptionContent want e+	| want e = Just e+	| otherwise = Nothing #endif
doc/git-annex-import.mdwn view
@@ -96,6 +96,8 @@  [[git-annex-add]](1) +[[git-annex-export]](1)+ # AUTHOR  Joey Hess <id@joeyh.name>
doc/git-annex-sync.mdwn view
@@ -82,6 +82,10 @@   This behavior can be overridden by configuring the preferred content   of a repository. See [[git-annex-preferred-content]](1). +  When a special remote is configured as an export and is tracking a branch,+  the export will be updated to the current content of the branch.+  See [[git-annex-export]](1).+ * `--content-of=path` `-C path`    While --content operates on all annexed files in the work tree,
doc/git-annex.mdwn view
@@ -158,6 +158,12 @@      See [[git-annex-importfeed]](1) for details. +* `export treeish --to remote`++  Export content to a remote.++  See [[git-annex-export]](1) for details.+ * `undo [filename|directory] ...`    Undo last change to a file or directory.@@ -1203,6 +1209,14 @@   By default, git-annex will verify the checksums of objects downloaded   from remotes. If you trust a remote and don't want the overhead   of these checksums, you can set this to `false`.++* `remote.<name>.annex-export-tracking`++  When set to a branch name or other treeish, this makes what's exported+  to the special remote track changes to the branch. See+  [[git-annex-export]](1). `git-annex sync --content` and the +  git-annex assistant update exports when changes have been+  committed to the tracking branch.  * `remote.<name>.annexUrl`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20170818+Version: 6.20170925 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -506,6 +506,7 @@     Annex.Direct     Annex.Drop     Annex.Environment+    Annex.Export     Annex.FileMatcher     Annex.Fixup     Annex.GitOverlay@@ -579,6 +580,7 @@     Assistant.Threads.ConfigMonitor     Assistant.Threads.Cronner     Assistant.Threads.DaemonStatus+    Assistant.Threads.Exporter     Assistant.Threads.Glacier     Assistant.Threads.Merger     Assistant.Threads.MountWatcher@@ -697,6 +699,7 @@     Command.EnableTor     Command.ExamineKey     Command.Expire+    Command.Export     Command.Find     Command.FindRef     Command.Fix@@ -787,6 +790,7 @@     Config.GitConfig     Creds     Crypto+    Database.Export     Database.Fsck     Database.Handle     Database.Init@@ -849,6 +853,7 @@     Logs.Config     Logs.Difference     Logs.Difference.Pure+    Logs.Export     Logs.FsckResults     Logs.Group     Logs.Line@@ -901,6 +906,7 @@     Remote.Helper.Chunked     Remote.Helper.Chunked.Legacy     Remote.Helper.Encryptable+    Remote.Helper.Export     Remote.Helper.Git     Remote.Helper.Hooks     Remote.Helper.Http@@ -941,6 +947,7 @@     Types.DesktopNotify     Types.Difference     Types.Distribution+    Types.Export     Types.FileMatcher     Types.GitConfig     Types.Group