diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2017 Joey Hess - - 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' diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -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. diff --git a/Annex/Export.hs b/Annex/Export.hs new file mode 100644 --- /dev/null +++ b/Annex/Export.hs @@ -0,0 +1,45 @@ +{- git-annex exports + - + - Copyright 2017 Joey Hess + - + - 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 diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -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 diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -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. -} diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -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 () diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -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 diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs --- a/Assistant/Commits.hs +++ b/Assistant/Commits.hs @@ -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 diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -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 diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -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 diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -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 diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs --- a/Assistant/Pushes.hs +++ b/Assistant/Pushes.hs @@ -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 diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -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 diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -67,6 +67,7 @@ void $ alertWhile commitAlert $ liftAnnex $ commitStaged msg recordCommit + recordExportCommit let numchanges = length readychanges mapM_ checkChangeContent readychanges return numchanges diff --git a/Assistant/Threads/Exporter.hs b/Assistant/Threads/Exporter.hs new file mode 100644 --- /dev/null +++ b/Assistant/Threads/Exporter.hs @@ -0,0 +1,78 @@ +{- git-annex assistant export updating thread + - + - Copyright 2017 Joey Hess + - + - 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 diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -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 diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -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 diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -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 diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -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 diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -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 diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -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 [] diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -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 diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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. diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -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 diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -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) diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -94,6 +94,8 @@ paramAddress = "ADDRESS" paramItem :: String paramItem = "ITEM" +paramTreeish :: String +paramTreeish = "TREEISH" paramKeyValue :: String paramKeyValue = "K=V" paramNothing :: String diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -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 diff --git a/Command/Export.hs b/Command/Export.hs new file mode 100644 --- /dev/null +++ b/Command/Export.hs @@ -0,0 +1,365 @@ +{- git-annex command + - + - Copyright 2017 Joey Hess + - + - 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 + ) diff --git a/Command/FindRef.hs b/Command/FindRef.hs --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -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) diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -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 diff --git a/Command/Trust.hs b/Command/Trust.hs --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -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 diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -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 diff --git a/Database/Export.hs b/Database/Export.hs new file mode 100644 --- /dev/null +++ b/Database/Export.hs @@ -0,0 +1,233 @@ +{- Sqlite database used for exports to special remotes. + - + - Copyright 2017 Joey Hess + -: + - 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 () diff --git a/Database/Fsck.hs b/Database/Fsck.hs --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -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 () diff --git a/Database/Handle.hs b/Database/Handle.hs --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -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 diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -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 diff --git a/Database/Queue.hs b/Database/Queue.hs --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -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 diff --git a/Database/Types.hs b/Database/Types.hs --- a/Database/Types.hs +++ b/Database/Types.hs @@ -1,6 +1,6 @@ {- types for SQL databases - - - Copyright 2015-2016 Joey Hess + - Copyright 2015-2017 Joey Hess - - 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 diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -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 diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -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 diff --git a/Logs/Export.hs b/Logs/Export.hs new file mode 100644 --- /dev/null +++ b/Logs/Export.hs @@ -0,0 +1,125 @@ +{- git-annex export log + - + - Copyright 2017 Joey Hess + - + - 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 diff --git a/Logs/Trust.hs b/Logs/Trust.hs --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -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 diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -53,6 +53,7 @@ checkAvailable, isXMPPRemote, claimingUrl, + isExportSupported, ) where import Data.Ord diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -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 diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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 diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -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 diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -1,6 +1,6 @@ {- A "remote" that is just a filesystem directory. - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2017 Joey Hess - - 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')) diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -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) diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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 diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -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 diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -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 diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs new file mode 100644 --- /dev/null +++ b/Remote/Helper/Export.hs @@ -0,0 +1,158 @@ +{- exports to remotes + - + - Copyright 2017 Joey Hess + - + - 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")]) + } diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -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) diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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 diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,6 +1,6 @@ {- S3 remotes - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2017 Joey Hess - - 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 [] diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -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 diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -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 diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -1,6 +1,6 @@ {- WebDAV remotes. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2017 Joey Hess - - 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 diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -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 diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 diff --git a/Types/Export.hs b/Types/Export.hs new file mode 100644 --- /dev/null +++ b/Types/Export.hs @@ -0,0 +1,53 @@ +{- git-annex export types + - + - Copyright 2017 Joey Hess + - + - 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 diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -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" diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -2,7 +2,7 @@ - - Most things should not need this, using Types instead - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2017 Joey Hess - - 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 + } diff --git a/Types/TrustLevel.hs b/Types/TrustLevel.hs --- a/Types/TrustLevel.hs +++ b/Types/TrustLevel.hs @@ -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 diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -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 diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -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 diff --git a/doc/git-annex-import.mdwn b/doc/git-annex-import.mdwn --- a/doc/git-annex-import.mdwn +++ b/doc/git-annex-import.mdwn @@ -96,6 +96,8 @@ [[git-annex-add]](1) +[[git-annex-export]](1) + # AUTHOR Joey Hess diff --git a/doc/git-annex-sync.mdwn b/doc/git-annex-sync.mdwn --- a/doc/git-annex-sync.mdwn +++ b/doc/git-annex-sync.mdwn @@ -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, diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -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..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..annexUrl` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20170818 +Version: 6.20170925 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -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