diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -42,8 +42,12 @@ , keyChunkNum = Nothing } -warnExportConflict :: Remote -> Annex () -warnExportConflict r = toplevelWarning True $ - "Export conflict detected. Different trees have been exported to " ++ - Remote.name r ++ - ". Use git-annex export to resolve this conflict." +warnExportImportConflict :: Remote -> Annex () +warnExportImportConflict r = do + ops <- Remote.isImportSupported r >>= return . \case + True -> "exported to and/or imported from" + False -> "exported to" + toplevelWarning True $ + "Conflict detected. Different trees have been " ++ ops ++ + Remote.name r ++ + ". Use git-annex export to resolve this conflict." diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -135,14 +135,27 @@ mkLargeFilesParser :: Annex (String -> [ParseResult]) mkLargeFilesParser = do - magicmime <- liftIO initMagicMimeType - let parse = parseToken $ commonTokens + magicmime <- liftIO initMagicMime #ifdef WITH_MAGICMIME - ++ [ ValueToken "mimetype" (usev $ matchMagic magicmime) ] + let mimer n f = ValueToken n (usev $ f magicmime) #else - ++ [ ValueToken "mimetype" (const $ Left "\"mimetype\" not supported; not built with MagicMime support") ] + let mimer n = ValueToken n $ + const $ Left $ "\""++n++"\" not supported; not built with MagicMime support" #endif + let parse = parseToken $ commonTokens ++ +#ifdef WITH_MAGICMIME + [ mimer "mimetype" $ + matchMagic "mimetype" getMagicMimeType providedMimeType + , mimer "mimeencoding" $ + matchMagic "mimeencoding" getMagicMimeEncoding providedMimeEncoding + ] +#else + [ mimer "mimetype" + , mimer "mimeencoding" + ] +#endif return $ map parse . tokenizeMatcher + where {- Generates a matcher for files large enough (or meeting other criteria) - to be added to the annex, rather than directly to git. -} diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -23,6 +23,7 @@ import Git.Tree import Git.Sha import Git.FilePath +import Git.History import qualified Git.Ref import qualified Git.Branch import qualified Annex @@ -30,6 +31,7 @@ import Annex.LockFile import Annex.Content import Annex.Export +import Annex.RemoteTrackingBranch import Command import Backend import Config @@ -59,19 +61,16 @@ {- Configures how to build an import commit. -} data ImportCommitConfig = ImportCommitConfig - { importCommitParent :: Maybe Sha - -- ^ Commit to use as a parent of the import commit. + { importCommitTracking :: Maybe Sha + -- ^ Current commit on the remote tracking branch. , importCommitMode :: Git.Branch.CommitMode , importCommitMessage :: String } -{- Builds a commit for an import from a special remote. - - - - When a remote provided a history of versions of files, - - builds a corresponding tree of git commits. +{- Buils a commit for an import from a special remote. - - - When there are no changes to commit (ie, the imported tree is the same - - as the tree in the importCommitParent), returns Nothing. + - When there are no changes to make (importCommitTracking + - already matches what was imported), returns Nothing. - - After importing from a remote, exporting the same thing back to the - remote should be a no-op. So, the export log and database are @@ -88,11 +87,11 @@ -> ImportableContents Key -> Annex (Maybe Ref) buildImportCommit remote importtreeconfig importcommitconfig importable = - case importCommitParent importcommitconfig of - Nothing -> go emptyTree Nothing - Just basecommit -> inRepo (Git.Ref.tree basecommit) >>= \case - Nothing -> go emptyTree Nothing - Just origtree -> go origtree (Just basecommit) + case importCommitTracking importcommitconfig of + Nothing -> go Nothing + Just trackingcommit -> inRepo (Git.Ref.tree trackingcommit) >>= \case + Nothing -> go Nothing + Just _ -> go (Just trackingcommit) where basetree = case importtreeconfig of ImportTree -> emptyTree @@ -101,29 +100,14 @@ ImportTree -> Nothing ImportSubTree dir _ -> Just dir - go origtree basecommit = do + go trackingcommit = do imported@(History finaltree _) <- buildImportTrees basetree subdir importable - mkcommits origtree basecommit imported >>= \case - Nothing -> return Nothing + buildImportCommit' importcommitconfig trackingcommit imported >>= \case Just finalcommit -> do updatestate finaltree return (Just finalcommit) - - mkcommits origtree basecommit (History importedtree hs) = do - parents <- catMaybes <$> mapM (mkcommits origtree basecommit) hs - if importedtree == origtree && null parents - then return Nothing -- no changes to commit - else do - let commitparents = if null parents - then catMaybes [basecommit] - else parents - commit <- inRepo $ Git.Branch.commitTree - (importCommitMode importcommitconfig) - (importCommitMessage importcommitconfig) - commitparents - importedtree - return (Just commit) + Nothing -> return Nothing updatestate committedtree = do importedtree <- case subdir of @@ -136,7 +120,7 @@ updateexportdb importedtree oldexport <- updateexportlog importedtree updatelocationlog oldexport importedtree - + updateexportdb importedtree = do db <- Export.openDb (Remote.uuid remote) Export.writeLockDbWhile db $ do @@ -176,9 +160,61 @@ Export.runExportDiffUpdater updater db oldtree finaltree Export.closeDb db -data History t = History t [History t] - deriving (Show) +buildImportCommit' :: ImportCommitConfig -> Maybe Sha -> History Sha -> Annex (Maybe Sha) +buildImportCommit' importcommitconfig mtrackingcommit imported@(History ti _) = + case mtrackingcommit of + Nothing -> Just <$> mkcommits imported + Just trackingcommit -> do + -- Get history of tracking branch to at most + -- one more level deep than what was imported, + -- so we'll have enough history to compare, + -- but not spend too much time getting it. + let maxdepth = succ (historyDepth imported) + inRepo (getHistoryToDepth maxdepth trackingcommit) + >>= go trackingcommit + where + go _ Nothing = Just <$> mkcommits imported + go trackingcommit (Just h) + -- If the tracking branch head is a merge commit + -- with a tree that matches the head of the history, + -- and one side of the merge matches the history, + -- nothing new needs to be committed. + | t == ti && any (sametodepth imported) (S.toList s) = return Nothing + -- If the tracking branch matches the history, + -- nothing new needs to be committed. + -- (This is unlikely to happen.) + | sametodepth imported h' = return Nothing + | otherwise = do + importedcommit <- case getRemoteTrackingBranchImportHistory h of + Nothing -> + mkcommits imported + Just oldimported@(History oldhc _) -> do + let oldimportedtrees = mapHistory historyCommitTree oldimported + mknewcommits oldhc oldimportedtrees imported + Just <$> makeRemoteTrackingBranchMergeCommit' + trackingcommit importedcommit ti + where + h'@(History t s) = mapHistory historyCommitTree h + sametodepth a b = a == truncateHistoryToDepth (historyDepth a) b + + mkcommit parents tree = inRepo $ Git.Branch.commitTree + (importCommitMode importcommitconfig) + (importCommitMessage importcommitconfig) + parents + tree + + mkcommits (History importedtree hs) = do + parents <- mapM mkcommits (S.toList hs) + mkcommit parents importedtree + + -- Reuse the commits from the old imported History when possible. + mknewcommits oldhc old new@(History importedtree hs) + | old == new = return $ historyCommit oldhc + | otherwise = do + parents <- mapM (mknewcommits oldhc old) (S.toList hs) + mkcommit parents importedtree + {- Builds a history of git trees reflecting the ImportableContents. - - When a subdir is provided, imported tree is grafted into the basetree at @@ -190,10 +226,14 @@ -> ImportableContents Key -> Annex (History Sha) buildImportTrees basetree msubdir importable = History - <$> (go (importableContents importable) =<< Annex.gitRepo) - <*> mapM (buildImportTrees basetree msubdir) (importableHistory importable) + <$> (buildtree (importableContents importable) =<< Annex.gitRepo) + <*> buildhistory where - go ls repo = withMkTreeHandle repo $ \hdl -> do + buildhistory = S.fromList + <$> mapM (buildImportTrees basetree msubdir) + (importableHistory importable) + + buildtree ls repo = withMkTreeHandle repo $ \hdl -> do importtree <- liftIO . recordTree' hdl . treeItemsToTree =<< mapM mktreeitem ls @@ -201,6 +241,7 @@ Nothing -> return importtree Just subdir -> liftIO $ graftTree' importtree subdir basetree repo hdl + mktreeitem (loc, k) = do let lf = fromImportLocation loc let treepath = asTopFilePath lf @@ -214,8 +255,8 @@ {- Downloads all new ContentIdentifiers as needed to generate Keys. - Supports concurrency when enabled. - - - If any download fails, the whole thing fails, but it will resume where - - it left off. + - If any download fails, the whole thing fails with Nothing, + - but it will resume where it left off. -} downloadImport :: Remote -> ImportTreeConfig -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (Maybe (ImportableContents Key)) downloadImport remote importtreeconfig importablecontents = do @@ -233,17 +274,17 @@ bracket CIDDb.openDb CIDDb.closeDb $ \db -> do CIDDb.needsUpdateFromLog db >>= maybe noop (CIDDb.updateFromLog db) - go cidmap downloading importablecontents db + go False cidmap downloading importablecontents db where - go cidmap downloading (ImportableContents l h) db = do + go oldversion cidmap downloading (ImportableContents l h) db = do jobs <- forM l $ \i -> - startdownload cidmap downloading db i + startdownload cidmap downloading db i oldversion l' <- liftIO $ forM jobs $ either pure (atomically . takeTMVar) if any isNothing l' then return Nothing else do - h' <- mapM (\ic -> go cidmap downloading ic db) h + h' <- mapM (\ic -> go True cidmap downloading ic db) h if any isNothing h' then return Nothing else return $ Just $ @@ -261,12 +302,14 @@ s <- readTVar downloading writeTVar downloading $ S.delete cid s - startdownload cidmap downloading db i@(loc, (cid, _sz)) = getcidkey cidmap db cid >>= \case + startdownload cidmap downloading db i@(loc, (cid, _sz)) oldversion = getcidkey cidmap db cid >>= \case (k:_) -> return $ Left $ Just (loc, k) [] -> do job <- liftIO $ newEmptyTMVarIO let downloadaction = do showStart ("import " ++ Remote.name remote) (fromImportLocation loc) + when oldversion $ + showNote "old version" next $ tryNonAsync (download cidmap db i) >>= \case Left e -> next $ do warning (show e) diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -355,9 +355,13 @@ gitAnnexExportUpdateLock :: UUID -> Git.Repo -> FilePath gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r ++ ".upl" -{- Directory containing database used to record remote content ids. -} +{- Directory containing database used to record remote content ids. + - + - (This used to be "cid", but a problem with the database caused it to + - need to be rebuilt with a new name.) + -} gitAnnexContentIdentifierDbDir :: Git.Repo -> FilePath -gitAnnexContentIdentifierDbDir r = gitAnnexDir r "cid" +gitAnnexContentIdentifierDbDir r = gitAnnexDir r "cids" {- Lock file for writing to the content id database. -} gitAnnexContentIdentifierLock :: Git.Repo -> FilePath diff --git a/Annex/Magic.hs b/Annex/Magic.hs --- a/Annex/Magic.hs +++ b/Annex/Magic.hs @@ -10,10 +10,13 @@ module Annex.Magic ( Magic, MimeType, - initMagicMimeType, + MimeEncoding, + initMagicMime, getMagicMimeType, + getMagicMimeEncoding, ) where +import Types.Mime #ifdef WITH_MAGICMIME import Magic import Utility.Env @@ -22,24 +25,35 @@ type Magic = () #endif -initMagicMimeType :: IO (Maybe Magic) +initMagicMime :: IO (Maybe Magic) #ifdef WITH_MAGICMIME -initMagicMimeType = catchMaybeIO $ do - m <- magicOpen [MagicMimeType] +initMagicMime = catchMaybeIO $ do + m <- magicOpen [MagicMime] liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case Nothing -> magicLoadDefault m Just d -> magicLoad m (d "magic" "magic.mgc") return m #else -initMagicMimeType = return Nothing +initMagicMime = return Nothing #endif -type MimeType = String - -getMagicMimeType :: Magic -> FilePath -> IO (Maybe MimeType) +getMagicMime :: Magic -> FilePath -> IO (Maybe (MimeType, MimeEncoding)) #ifdef WITH_MAGICMIME -getMagicMimeType m f = Just <$> magicFile m f +getMagicMime m f = Just . parse <$> magicFile m f + where + parse s = + let (mimetype, rest) = separate (== ';') s + in case rest of + (' ':'c':'h':'a':'r':'s':'e':'t':'=':mimeencoding) -> + (mimetype, mimeencoding) + _ -> (mimetype, "") #else -getMagicMimeType _ _ = return Nothing +getMagicMime _ _ = return Nothing #endif + +getMagicMimeType :: Magic -> FilePath -> IO (Maybe MimeType) +getMagicMimeType m f = fmap fst <$> getMagicMime m f + +getMagicMimeEncoding :: Magic -> FilePath -> IO (Maybe MimeEncoding) +getMagicMimeEncoding m f = fmap snd <$> getMagicMime m f diff --git a/Annex/RemoteTrackingBranch.hs b/Annex/RemoteTrackingBranch.hs --- a/Annex/RemoteTrackingBranch.hs +++ b/Annex/RemoteTrackingBranch.hs @@ -10,14 +10,20 @@ , mkRemoteTrackingBranch , fromRemoteTrackingBranch , setRemoteTrackingBranch + , makeRemoteTrackingBranchMergeCommit + , makeRemoteTrackingBranchMergeCommit' + , getRemoteTrackingBranchImportHistory ) where import Annex.Common import Git.Types import qualified Git.Ref import qualified Git.Branch +import Git.History import qualified Types.Remote as Remote +import qualified Data.Set as S + newtype RemoteTrackingBranch = RemoteTrackingBranch { fromRemoteTrackingBranch :: Ref } deriving (Show, Eq) @@ -32,3 +38,54 @@ setRemoteTrackingBranch :: RemoteTrackingBranch -> Sha -> Annex () setRemoteTrackingBranch tb commit = inRepo $ Git.Branch.update' (fromRemoteTrackingBranch tb) commit + +{- Makes a merge commit that preserves the import history of the + - RemoteTrackingBranch, while grafting new git history into it. + - + - The second parent of the merge commit is the past history of the + - RemoteTrackingBranch as imported from a remote. When importing a + - history of trees from a remote, commits can be sythesized from + - them, but such commits won't have the same sha due to eg date differing. + - But since we know that the second parent consists entirely of such + - import commits, they can be reused when updating the + - RemoteTrackingBranch. + - + - The commitsha should have the treesha as its tree. + -} +makeRemoteTrackingBranchMergeCommit :: RemoteTrackingBranch -> Sha -> Sha -> Annex Sha +makeRemoteTrackingBranchMergeCommit tb commitsha treesha = + -- Check if the tracking branch exists. + inRepo (Git.Ref.sha (fromRemoteTrackingBranch tb)) >>= \case + Nothing -> return commitsha + Just _ -> inRepo (getHistoryToDepth 1 (fromRemoteTrackingBranch tb)) >>= \case + Nothing -> return commitsha + Just (History hc _) -> case historyCommitParents hc of + [_, importhistory] -> + makeRemoteTrackingBranchMergeCommit' commitsha importhistory treesha + -- Earlier versions of git-annex did not + -- make the merge commit, or perhaps + -- something else changed where the + -- tracking branch pointed. + _ -> return commitsha + +makeRemoteTrackingBranchMergeCommit' :: Sha -> Sha -> Sha -> Annex Sha +makeRemoteTrackingBranchMergeCommit' commitsha importedhistory treesha = + inRepo $ Git.Branch.commitTree + Git.Branch.AutomaticCommit + "remote tracking branch" + [commitsha, importedhistory] + treesha + +{- When makeRemoteTrackingBranchMergeCommit was used, this finds the + - import history, starting from the second parent of the merge commit. + -} +getRemoteTrackingBranchImportHistory :: History HistoryCommit -> Maybe (History HistoryCommit) +getRemoteTrackingBranchImportHistory (History hc s) = + case historyCommitParents hc of + [_, importhistory] -> go importhistory (S.toList s) + _ -> Nothing + where + go _ [] = Nothing + go i (h@(History hc' _):hs) + | historyCommit hc' == i = Just h + | otherwise = go i hs diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -77,9 +77,7 @@ storageclasses = [ ("Standard redundancy", StandardRedundancy) #ifdef WITH_S3 -#if MIN_VERSION_aws(0,13,0) , ("Infrequent access (cheaper for backups and archives)", StandardInfrequentAccess) -#endif #endif , ("Reduced redundancy (costs less)", ReducedRedundancy) ] diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -33,12 +33,6 @@ #endif #ifdef WITH_S3 , "S3" -#if MIN_VERSION_aws(0,10,6) - ++ "(multipartupload)" -#endif -#if MIN_VERSION_aws(0,13,0) - ++ "(storageclasses)" -#endif #else #warning Building without S3. #endif diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,36 @@ +git-annex (7.20190503) upstream; urgency=medium + + * adb special remote supports being configured with importtree=yes, + to allow git-annex import of files from an Android device. This can be + combined with exporttree=yes and git-annex export used to send changes + back to the Android device. + * S3 special remote supports being configured with importtree=yes, + to allow git-annex import of files from a S3 bucket. This can be + combined with exporttree=yes and git-annex export used to send changes + back to the S3 bucket. + * S3: When versioning is enabled on a bucket, importing from it will + import old versions of files that were written to the bucket as well + as the current versions. A git history is synthesized to reflect the way + the bucket changed over time. + * Fix bug that caused importing from a special remote to repeatedly + download unchanged files when multiple files in the remote have the same + content. + * Made git-annex sync --content much faster when all the remotes it's + syncing with are export/import remotes. + * sync: When listing contents on an import remote fails, proceed with + other syncing instead of aborting. + * renameremote: New command, changes the name that is used to enable + a special remote. Especially useful when you want to reuse the name + of an old remote for something new. + * Drop support for building with aws older than 0.14. + * info: Show when a remote is configured with importtree. + * Added mimeencoding= term to annex.largefiles expressions. + This is probably mostly useful to match non-text files with eg + "mimeencoding=binary" + * git-annex matchexpression: Added --mimeencoding option. + + -- Joey Hess Fri, 03 May 2019 12:47:41 -0400 + git-annex (7.20190322) upstream; urgency=medium * New feature allows importing from special remotes, using diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -54,6 +54,7 @@ import qualified Command.Describe import qualified Command.InitRemote import qualified Command.EnableRemote +import qualified Command.RenameRemote import qualified Command.EnableTor import qualified Command.Multicast import qualified Command.Expire @@ -145,6 +146,7 @@ , Command.Describe.cmd , Command.InitRemote.cmd , Command.EnableRemote.cmd + , Command.RenameRemote.cmd , Command.EnableTor.cmd , Command.Multicast.cmd , Command.Reinject.cmd diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -156,7 +156,7 @@ startMoveFromTempName r db ek newf _ -> stop ts -> do - warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.." + warning "Resolving export conflict.." forM_ ts $ \oldtreesha -> do -- Unexport both the srcsha and the dstsha, -- because the wrong content may have @@ -235,7 +235,8 @@ Nothing -> noop Just (tb, commitsha) -> whenM (liftIO $ fromAllFilled <$> takeMVar allfilledvar) $ - setRemoteTrackingBranch tb commitsha + makeRemoteTrackingBranchMergeCommit tb commitsha newtree + >>= setRemoteTrackingBranch tb liftIO $ fromFileUploaded <$> takeMVar cvar diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -33,6 +33,8 @@ import Git.Branch import Types.Import +import Control.Concurrent.STM + cmd :: Command cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, fileMatchingOptions] $ @@ -263,12 +265,22 @@ Just tree -> mk tree Nothing -> giveup $ "Unable to find base tree for branch " ++ fromRef branch - parentcommit <- fromtrackingbranch Git.Ref.sha - let importcommitconfig = ImportCommitConfig parentcommit ManualCommit importmessage + trackingcommit <- fromtrackingbranch Git.Ref.sha + let importcommitconfig = ImportCommitConfig trackingcommit AutomaticCommit importmessage + let commitimport = commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig - importable <- download importtreeconfig =<< listcontents - void $ includeCommandAction $ - commitRemote remote branch tb parentcommit importtreeconfig importcommitconfig importable + importabletvar <- liftIO $ newTVarIO Nothing + void $ includeCommandAction (listContents remote importabletvar) + liftIO (atomically (readTVar importabletvar)) >>= \case + Nothing -> return () + Just importable -> downloadImport remote importtreeconfig importable >>= \case + Nothing -> warning $ concat + [ "Failed to import some files from " + , Remote.name remote + , ". Re-run command to resume import." + ] + Just imported -> void $ + includeCommandAction $ commitimport imported where importmessage = "import from " ++ Remote.name remote @@ -276,23 +288,17 @@ fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb) - listcontents = do - showStart' "list" (Just (Remote.name remote)) - Remote.listImportableContents (Remote.importActions remote) >>= \case - Nothing -> do - showEndFail - giveup $ "Unable to list contents of " ++ Remote.name remote - Just importable -> do - showEndOk - return importable - - download importtreeconfig importablecontents = - downloadImport remote importtreeconfig importablecontents >>= \case - Nothing -> giveup $ "Failed to import some files from " ++ Remote.name remote ++ ". Re-run command to resume import." - Just importable -> return importable +listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart +listContents remote tvar = do + showStart' "list" (Just (Remote.name remote)) + next $ Remote.listImportableContents (Remote.importActions remote) >>= \case + Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote + Just importable -> next $ do + liftIO $ atomically $ writeTVar tvar (Just importable) + return True commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents Key -> CommandStart -commitRemote remote branch tb parentcommit importtreeconfig importcommitconfig importable = do +commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = do showStart' "update" (Just $ fromRef $ fromRemoteTrackingBranch tb) next $ do importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable @@ -302,7 +308,7 @@ -- Update the tracking branch. Done even when there -- is nothing new to import, to make sure it exists. updateremotetrackingbranch importcommit = - case importcommit <|> parentcommit of + case importcommit <|> trackingcommit of Just c -> do setRemoteTrackingBranch tb c return True diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -77,13 +77,15 @@ perform opts cache url = go =<< downloadFeed url where go Nothing = next $ feedProblem url "downloading the feed failed" - go (Just f) = case findDownloads url f of - [] -> next $ - feedProblem url "bad feed content; no enclosures to download" - l -> do - showOutput - ok <- and <$> mapM (performDownload opts cache) l - next $ cleanup url ok + go (Just feedcontent) = case parseFeedString feedcontent of + Nothing -> next $ feedProblem url "parsing the feed failed" + Just f -> case findDownloads url f of + [] -> next $ + feedProblem url "bad feed content; no enclosures to download" + l -> do + showOutput + ok <- and <$> mapM (performDownload opts cache) l + next $ cleanup url ok cleanup :: URLString -> Bool -> CommandCleanup cleanup url True = do @@ -142,14 +144,14 @@ Nothing -> Nothing {- Feeds change, so a feed download cannot be resumed. -} -downloadFeed :: URLString -> Annex (Maybe Feed) +downloadFeed :: URLString -> Annex (Maybe String) downloadFeed url | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" | otherwise = Url.withUrlOptions $ \uo -> liftIO $ withTmpFile "feed" $ \f h -> do hClose h ifM (Url.download nullMeterUpdate url f uo) - ( parseFeedString <$> readFileStrict f + ( Just <$> readFileStrict f , return Nothing ) diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -38,9 +38,9 @@ ( long "largefiles" <> help "parse as annex.largefiles expression" ) - <*> (addkeysize <$> dataparser) + <*> (MatchingInfo . addkeysize <$> dataparser) where - dataparser = MatchingInfo + dataparser = ProvidedInfo <$> optinfo "file" (strOption ( long "file" <> metavar paramFile <> help "specify filename to match against" @@ -57,15 +57,20 @@ ( long "mimetype" <> metavar paramValue <> help "specify mime type to match against" )) + <*> optinfo "mimeencoding" (strOption + ( long "mimeencoding" <> metavar paramValue + <> help "specify mime encoding to match against" + )) optinfo datadesc mk = (Right <$> mk) <|> (pure $ Left $ missingdata datadesc) missingdata datadesc = bail $ "cannot match this expression without " ++ datadesc ++ " data" - -- When a key is provided, use its size. - addkeysize i@(MatchingInfo f (Right k) _ m) = case keySize k of - Just sz -> MatchingInfo f (Right k) (Right sz) m - Nothing -> i - addkeysize i = i + -- When a key is provided, make its size also be provided. + addkeysize p = case providedKey p of + Right k -> case keySize k of + Just sz -> p { providedFileSize = Right sz } + Nothing -> p + Left _ -> p seek :: MatchExpressionOptions -> CommandSeek seek o = do diff --git a/Command/RenameRemote.hs b/Command/RenameRemote.hs new file mode 100644 --- /dev/null +++ b/Command/RenameRemote.hs @@ -0,0 +1,51 @@ +{- git-annex command + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Command.RenameRemote where + +import Command +import qualified Annex.SpecialRemote +import qualified Logs.Remote +import qualified Types.Remote as R +import qualified Remote + +import qualified Data.Map as M + +cmd :: Command +cmd = command "renameremote" SectionSetup + "changes name of special remote" + (paramPair paramName paramName) + (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withWords (commandAction . start) + +start :: [String] -> CommandStart +start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case + Just (u, cfg) -> Annex.SpecialRemote.findExisting newname >>= \case + Just _ -> giveup $ "The name " ++ newname ++ " is already used by a special remote." + Nothing -> go u cfg + -- Support lookup by uuid or description as well as remote name, + -- as a fallback when there is nothing with the name in the + -- special remote log. + Nothing -> Remote.nameToUUID' oldname >>= \case + Left e -> giveup e + Right u -> do + m <- Logs.Remote.readRemoteLog + case M.lookup u m of + Nothing -> giveup "That is not a special remote." + Just cfg -> go u cfg + where + go u cfg = do + showStart' "rename" Nothing + next $ perform u cfg newname +start _ = giveup "Specify an old name (or uuid or description) and a new name." + +perform :: UUID -> R.RemoteConfig -> String -> CommandPerform +perform u cfg newname = do + Logs.Remote.configSet u (M.insert "name" newname cfg) + next $ return True diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -592,6 +592,7 @@ - When concurrency is enabled, files are processed concurrently. -} seekSyncContent :: SyncOptions -> [Remote] -> CurrBranch -> Annex Bool +seekSyncContent _ [] _ = return False seekSyncContent o rs currbranch = do mvar <- liftIO newEmptyMVar bloom <- case keyOptions o of @@ -755,7 +756,7 @@ fillexport _ _ [] _ = return False fillexport r db (t:[]) mtbcommitsha = Command.Export.fillExport r db t mtbcommitsha fillexport r _ _ _ = do - warnExportConflict r + warnExportImportConflict r return False cleanupLocal :: CurrBranch -> CommandStart diff --git a/Creds.hs b/Creds.hs --- a/Creds.hs +++ b/Creds.hs @@ -50,7 +50,7 @@ - - The remote's configuration should have already had a cipher stored in it - if that's going to be done, so that the creds can be encrypted using the - - cipher. The EncryptionIsSetup phantom type ensures that is the case. + - cipher. The EncryptionIsSetup is witness to that being the case. -} setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig setRemoteCredPair encsetup c gc storage mcreds = case mcreds of diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -6,7 +6,7 @@ -} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} @@ -51,9 +51,6 @@ remote UUID cid ContentIdentifier key IKey - ContentIdentifiersIndexRemoteKey remote key - ContentIdentifiersIndexRemoteCID remote cid - UniqueRemoteCidKey remote cid key -- The last git-annex branch tree sha that was used to update -- ContentIdentifiers AnnexBranch @@ -93,7 +90,7 @@ -- Be sure to also update the git-annex branch when using this. recordContentIdentifier :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> Key -> IO () recordContentIdentifier h u cid k = queueDb h $ do - void $ insertUnique $ ContentIdentifiers u cid (toIKey k) + void $ insert_ $ ContentIdentifiers u cid (toIKey k) getContentIdentifiers :: ContentIdentifierHandle -> UUID -> Key -> IO [ContentIdentifier] getContentIdentifiers (ContentIdentifierHandle h) u k = H.queryDbQueue h $ do diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -47,7 +47,7 @@ {- Runs a git command and returns its output, lazily. - - Also returns an action that should be used when the output is all - - read (or no more is needed), that will wait on the command, and + - read, that will wait on the command, and - return True if it succeeded. Failure to wait will result in zombies. -} pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) diff --git a/Git/History.hs b/Git/History.hs new file mode 100644 --- /dev/null +++ b/Git/History.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BangPatterns #-} + +{- git commit history interface + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Git.History where + +import Common +import Git +import Git.Command +import Git.Sha + +import qualified Data.Set as S + +data History t = History t (S.Set (History t)) + deriving (Show, Eq, Ord) + +mapHistory :: (Ord a, Ord b) => (a -> b) -> History a -> History b +mapHistory f (History t s) = History (f t) (S.map (mapHistory f) s) + +historyDepth :: History t -> Integer +historyDepth (History _ s) + | S.null s = 1 + | otherwise = 1 + maximum (map historyDepth (S.toList s)) + +truncateHistoryToDepth :: Ord t => Integer -> History t -> History t +truncateHistoryToDepth n (History t ps) = History t (go 1 ps) + where + go depth s + | depth >= n = S.empty + | otherwise = + let depth' = succ depth + in flip S.map s $ \(History t' s') -> + History t' (go depth' s') + + +data HistoryCommit = HistoryCommit + { historyCommit :: Sha + , historyCommitTree :: Sha + , historyCommitParents :: [Sha] + } deriving (Show, Eq, Ord) + +{- Gets a History starting with the provided commit, and down to the + - requested depth. -} +getHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History HistoryCommit)) +getHistoryToDepth n commit r = do + (_, Just inh, _, pid) <- createProcess (gitCreateProcess params r) + { std_out = CreatePipe } + !h <- fmap (truncateHistoryToDepth n) + . build Nothing + . map parsehistorycommit + . lines + <$> hGetContents inh + hClose inh + void $ waitForProcess pid + return h + where + build h [] = fmap (mapHistory fst) h + build _ (Nothing:_) = Nothing + build Nothing (Just v:rest) = + build (Just (History v S.empty)) rest + build (Just h) (Just v:rest) = + let h' = traverseadd v h + in build (Just h') $ + -- detect when all parents down to desired depth + -- have been found, and avoid processing any more, + -- this makes it much faster when there is a lot of + -- history. + if parentsfound h' then [] else rest + + traverseadd v@(hc, _ps) (History v'@(hc', ps') s) + | historyCommit hc `elem` ps' = + let ps'' = filter (/= historyCommit hc) ps' + in History (hc', ps'') (S.insert (History v S.empty) s) + | otherwise = History v' (S.map (traverseadd v) s) + + parentsfound = parentsfound' 1 + parentsfound' depth (History (_hc, ps) s) + | not (null ps) = False + | null ps && depth == n = True + | depth >= n = True + | otherwise = all (parentsfound' (succ depth)) (S.toList s) + + params = + [ Param "log" + , Param (fromRef commit) + , Param "--full-history" + , Param "--no-abbrev" + , Param "--format=%T %H %P" + ] + + parsehistorycommit l = case map extractSha (splitc ' ' l) of + (Just t:Just c:ps) -> Just $ + ( HistoryCommit + { historyCommit = c + , historyCommitTree = t + , historyCommitParents = catMaybes ps + } + , catMaybes ps + ) + _ -> Nothing diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -90,20 +90,22 @@ where cglob = compileGlob glob CaseSensative -- memoized go (MatchingFile fi) = pure $ matchGlob cglob (matchFile fi) - go (MatchingInfo af _ _ _) = matchGlob cglob <$> getInfo af + go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p) go (MatchingKey _ (AssociatedFile Nothing)) = pure False go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob af -matchMagic :: Maybe Magic -> MkLimit Annex -matchMagic (Just magic) glob = Right $ const go +matchMagic :: String -> (Magic -> FilePath -> IO (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex +matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $ const go where cglob = compileGlob glob CaseSensative -- memoized go (MatchingKey _ _) = pure False go (MatchingFile fi) = liftIO $ catchBoolIO $ maybe False (matchGlob cglob) - <$> getMagicMimeType magic (currFile fi) - go (MatchingInfo _ _ _ mimeval) = matchGlob cglob <$> getInfo mimeval -matchMagic Nothing _ = Left "unable to load magic database; \"mimetype\" cannot be used" + <$> querymagic magic (currFile fi) + go (MatchingInfo p) = + matchGlob cglob <$> getInfo (selectprovidedinfo p) +matchMagic limitname _ _ Nothing _ = + Left $ "unable to load magic database; \""++limitname++"\" cannot be used" {- Adds a limit to skip files not believed to be present - in a specfied repository. Optionally on a prior date. -} @@ -149,7 +151,7 @@ go (MatchingFile fi) = checkf $ matchFile fi go (MatchingKey _ (AssociatedFile Nothing)) = return False go (MatchingKey _ (AssociatedFile (Just af))) = checkf af - go (MatchingInfo af _ _ _) = checkf =<< getInfo af + go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p) checkf = return . elem dir . splitPath . takeDirectory {- Adds a limit to skip files not believed to have the specified number @@ -197,7 +199,7 @@ else case mi of MatchingFile fi -> getGlobalFileNumCopies $ matchFile fi MatchingKey _ _ -> approxNumCopies - MatchingInfo _ _ _ _ -> approxNumCopies + MatchingInfo {} -> approxNumCopies us <- filter (`S.notMember` notpresent) <$> (trustExclude UnTrusted =<< Remote.keyLocations key) return $ numcopies - length us >= needed @@ -211,8 +213,8 @@ limitUnused :: MatchFiles Annex limitUnused _ (MatchingFile _) = return False limitUnused _ (MatchingKey k _) = S.member k <$> unusedKeys -limitUnused _ (MatchingInfo _ ak _ _) = do - k <- getInfo ak +limitUnused _ (MatchingInfo p) = do + k <- getInfo (providedKey p) S.member k <$> unusedKeys {- Limit that matches any version of any file or key. -} @@ -274,8 +276,9 @@ where go sz _ (MatchingFile fi) = lookupFileKey fi >>= check fi sz go sz _ (MatchingKey key _) = checkkey sz key - go sz _ (MatchingInfo _ _ as _) = - getInfo as >>= \sz' -> return (Just sz' `vs` Just sz) + go sz _ (MatchingInfo p) = + getInfo (providedFileSize p) + >>= \sz' -> return (Just sz' `vs` Just sz) checkkey sz key = return $ keySize key `vs` Just sz check _ sz (Just key) = checkkey sz key check fi sz Nothing = do @@ -326,4 +329,5 @@ checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a checkKey a (MatchingKey k _) = a k -checkKey a (MatchingInfo _ ak _ _) = a =<< getInfo ak +checkKey a (MatchingInfo p) = a =<< getInfo (providedKey p) + diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -369,7 +369,7 @@ putMVar v $ RelayToPeer (L.fromChunks bs) loop - -- Waiit for the first available chunk. Then, without blocking, + -- Wait for the first available chunk. Then, without blocking, -- try to get more chunks, in case a stream of chunks is being -- written in close succession. -- diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -1,18 +1,17 @@ {- Remote on Android device accessed using adb. - - - Copyright 2018 Joey Hess + - Copyright 2018-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Adb (remote) where -import qualified Data.Map as M - import Annex.Common import Types.Remote import Types.Creds import Types.Export +import Types.Import import qualified Git import Config.Cost import Remote.Helper.Special @@ -21,6 +20,9 @@ import Annex.UUID import Utility.Metered +import qualified Data.Map as M +import qualified System.FilePath.Posix as Posix + -- | Each Android device has a serial number. newtype AndroidSerial = AndroidSerial { fromAndroidSerial :: String } deriving (Show, Eq) @@ -35,7 +37,7 @@ , generate = gen , setup = adbSetup , exportSupported = exportIsSupported - , importSupported = importUnsupported + , importSupported = importIsSupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -62,7 +64,14 @@ , removeExportDirectory = Just $ removeExportDirectoryM serial adir , renameExport = renameExportM serial adir } - , importActions = importUnsupported + , importActions = ImportActions + { listImportableContents = listImportableContentsM serial adir + , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM serial adir + , storeExportWithContentIdentifier = storeExportWithContentIdentifierM serial adir + , removeExportWithContentIdentifier = removeExportWithContentIdentifierM serial adir + , removeExportDirectoryWhenEmpty = Nothing + , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM serial adir + } , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -136,14 +145,22 @@ in store' serial dest src store' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool -store' serial dest src = do +store' serial dest src = store'' serial dest src (return True) + +store'' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool -> Annex Bool +store'' serial dest src canoverwrite = do let destdir = takeDirectory $ fromAndroidPath dest liftIO $ void $ adbShell serial [Param "mkdir", Param "-p", File destdir] showOutput -- make way for adb push output - let tmpdest = fromAndroidPath dest ++ ".tmp" + let tmpdest = fromAndroidPath dest ++ ".annextmp" ifM (liftIO $ boolSystem "adb" (mkAdbCommand serial [Param "push", File src, File tmpdest])) - -- move into place atomically - ( liftIO $ adbShellBool serial [Param "mv", File tmpdest, File (fromAndroidPath dest)] + ( ifM canoverwrite + -- move into place atomically + ( liftIO $ adbShellBool serial [Param "mv", File tmpdest, File (fromAndroidPath dest)] + , do + void $ remove' serial (AndroidPath tmpdest) + return False + ) , return False ) @@ -175,16 +192,16 @@ checkKey' :: Remote -> AndroidSerial -> AndroidPath -> Annex Bool checkKey' r serial aloc = do showChecking r - (out, st) <- liftIO $ adbShellRaw serial $ unwords + out <- liftIO $ adbShellRaw serial $ unwords [ "if test -e ", shellEscape (fromAndroidPath aloc) , "; then echo y" , "; else echo n" , "; fi" ] - case (out, st) of - (["y"], ExitSuccess) -> return True - (["n"], ExitSuccess) -> return False - _ -> giveup $ "unable to access Android device" ++ show out + case out of + Just ["y"] -> return True + Just ["n"] -> return False + _ -> giveup "unable to access Android device" androidLocation :: AndroidPath -> Key -> AndroidPath androidLocation adir k = AndroidPath $ @@ -229,6 +246,86 @@ oldloc = fromAndroidPath $ androidExportLocation adir old newloc = fromAndroidPath $ androidExportLocation adir new +listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsM serial adir = liftIO $ + process <$> adbShell serial + [ Param "find" + -- trailing slash is needed, or android's find command + -- won't recurse into the directory + , File $ fromAndroidPath adir ++ "/" + , Param "-type", Param "f" + , Param "-exec", Param "stat" + , Param "-c", Param statformat + , Param "{}", Param "+" + ] + where + process Nothing = Nothing + process (Just ls) = Just $ ImportableContents (mapMaybe mk ls) [] + + statformat = adbStatFormat ++ "\t%n" + + mk ('S':'T':'\t':l) = + let (stat, fn) = separate (== '\t') l + sz = fromMaybe 0 (readish (takeWhile (/= ' ') stat)) + cid = ContentIdentifier (encodeBS' stat) + loc = mkImportLocation $ + Posix.makeRelative (fromAndroidPath adir) fn + in Just (loc, (cid, sz)) + mk _ = Nothing + +-- This does not guard against every possible race. As long as the adb +-- connection is resonably fast, it's probably as good as +-- git's handling of similar situations with files being modified while +-- it's updating the working tree for a merge. +retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key) +retrieveExportWithContentIdentifierM serial adir loc cid dest mkkey _p = catchDefaultIO Nothing $ + ifM (retrieve' serial src dest) + ( do + k <- mkkey + currcid <- liftIO $ getExportContentIdentifier serial adir loc + return $ if currcid == Right (Just cid) + then k + else Nothing + , return Nothing + ) + where + src = androidExportLocation adir loc + +storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier) +storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p = catchDefaultIO Nothing $ + -- Check if overwrite is safe before sending, because sending the + -- file is expensive and don't want to do it unncessarily. + ifM checkcanoverwrite + ( ifM (store'' serial dest src checkcanoverwrite) + ( liftIO $ either (const Nothing) id + <$> getExportContentIdentifier serial adir loc + , return Nothing + ) + , return Nothing + ) + where + dest = androidExportLocation adir loc + checkcanoverwrite = liftIO $ + getExportContentIdentifier serial adir loc >>= return . \case + Right (Just cid) | cid `elem` overwritablecids -> True + Right Nothing -> True + _ -> False + +removeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +removeExportWithContentIdentifierM serial adir k loc removeablecids = catchBoolIO $ + liftIO (getExportContentIdentifier serial adir loc) >>= \case + Right Nothing -> return True + Right (Just cid) | cid `elem` removeablecids -> + removeExportM serial adir k loc + _ -> return False + +checkPresentExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +checkPresentExportWithContentIdentifierM serial adir _k loc knowncids = + liftIO $ getExportContentIdentifier serial adir loc >>= \case + Right (Just cid) | cid `elem` knowncids -> return True + Right _ -> return False + Left _ -> giveup "unable to access Android device" + androidExportLocation :: AndroidPath -> ExportLocation -> AndroidPath androidExportLocation adir loc = AndroidPath $ fromAndroidPath adir ++ "/" ++ fromExportLocation loc @@ -246,39 +343,60 @@ -- | Runs a command on the android device with the given serial number. -- --- adb shell does not propigate the exit code of the command, so --- it is echoed out in a trailing line, and the output is read to determine --- it. Any stdout from the command is returned, separated into lines. -adbShell :: AndroidSerial -> [CommandParam] -> IO ([String], ExitCode) +-- Any stdout from the command is returned, separated into lines. +adbShell :: AndroidSerial -> [CommandParam] -> IO (Maybe [String]) adbShell serial cmd = adbShellRaw serial $ unwords $ map shellEscape (toCommand cmd) adbShellBool :: AndroidSerial -> [CommandParam] -> IO Bool -adbShellBool serial cmd = do - (_ , ec) <- adbShell serial cmd - return (ec == ExitSuccess) +adbShellBool serial cmd = + adbShellRaw serial cmd' >>= return . \case + Just l -> end l == ["y"] + Nothing -> False + where + cmd' = "if " ++ unwords (map shellEscape (toCommand cmd)) + ++ "; then echo y; else echo n; fi" -- | Runs a raw shell command on the android device. -- Any necessary shellEscaping must be done by caller. -adbShellRaw :: AndroidSerial -> String -> IO ([String], ExitCode) -adbShellRaw serial cmd = processoutput <$> readProcess "adb" - [ "-s" - , fromAndroidSerial serial - , "shell" - -- The extra echo is in case cmd does not output a trailing - -- newline after its other output. - , cmd ++ "; echo; echo $?" - ] +adbShellRaw :: AndroidSerial -> String -> IO (Maybe [String]) +adbShellRaw serial cmd = catchMaybeIO $ + processoutput <$> readProcess "adb" + [ "-s" + , fromAndroidSerial serial + , "shell" + , cmd + ] where - processoutput s = case reverse (map trimcr (lines s)) of - (c:"":rest) -> case readish c of - Just 0 -> (reverse rest, ExitSuccess) - Just n -> (reverse rest, ExitFailure n) - Nothing -> (reverse rest, ExitFailure 1) - ls -> (reverse ls, ExitFailure 1) + processoutput s = map trimcr (lines s) -- For some reason, adb outputs lines with \r\n on linux, -- despite both linux and android being unix systems. trimcr = takeWhile (/= '\r') mkAdbCommand :: AndroidSerial -> [CommandParam] -> [CommandParam] mkAdbCommand serial cmd = [Param "-s", Param (fromAndroidSerial serial)] ++ cmd + +-- Gets the current content identifier for a file on the android device. +getExportContentIdentifier :: AndroidSerial -> AndroidPath -> ExportLocation -> IO (Either ExitCode (Maybe ContentIdentifier)) +getExportContentIdentifier serial adir loc = liftIO $ do + ls <- adbShellRaw serial $ unwords + [ "if test -e ", shellEscape aloc + , "; then stat -c" + , shellEscape adbStatFormat + , shellEscape aloc + , "; else echo n" + , "; fi" + ] + return $ case ls of + Just ["n"] -> Right Nothing + Just (('S':'T':'\t':stat):[]) -> Right $ Just $ + ContentIdentifier (encodeBS' stat) + _ -> Left (ExitFailure 1) + where + aloc = fromAndroidPath $ androidExportLocation adir loc + +-- Includes size, modificiation time, and inode. +-- Device not included because the adb interface ensures we're talking to +-- the same android device. +adbStatFormat :: String +adbStatFormat = "ST\t%s %Y %i" diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -367,10 +367,9 @@ -- being copied. -- -- When possible (not on Windows), check the same handle - -- Check the same handle that the file was copied from. - -- Avoids some race cases where the file is modified while - -- it's copied but then gets restored to the original content - -- afterwards. + -- that the file was copied from. Avoids some race cases where + -- the file is modified while it's copied but then gets restored + -- to the original content afterwards. -- -- This does not guard against every possible race, but neither -- can InodeCaches detect every possible modification to a file. diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -177,6 +177,9 @@ then checkPresent r' else \k -> anyM (checkpresent k) =<< getexportlocs exportdbv k + , getInfo = do + is <- getInfo r' + return (is++[("import", "yes")]) } isexport dbv = return $ r @@ -308,7 +311,7 @@ Just () -> Export.updateExportTreeFromLog db >>= \case Export.ExportUpdateSuccess -> return () Export.ExportUpdateConflict -> do - warnExportConflict r + warnExportImportConflict r liftIO $ atomically $ writeTVar exportinconflict True Nothing -> return () diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -40,12 +40,14 @@ import Types.Remote import Types.Export import qualified Git +import qualified Annex import Config import Config.Cost import Remote.Helper.Special import Remote.Helper.Http import Remote.Helper.Messages import Remote.Helper.ExportImport +import Types.Import import qualified Remote.Helper.AWS as AWS import Creds import Annex.UUID @@ -71,7 +73,7 @@ , generate = gen , setup = s3Setup , exportSupported = exportIsSupported - , importSupported = importUnsupported + , importSupported = importIsSupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -79,7 +81,7 @@ cst <- remoteCost gc expensiveRemoteCost info <- extractS3Info c hdl <- mkS3HandleVar c gc u - magic <- liftIO initMagicMimeType + magic <- liftIO initMagicMime return $ new cst info hdl magic where new cst info hdl magic = Just $ specialRemote c @@ -112,7 +114,14 @@ , removeExportDirectory = Nothing , renameExport = renameExportS3 hdl this info } - , importActions = importUnsupported + , importActions = ImportActions + { listImportableContents = listImportableContentsS3 hdl this info + , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this info + , storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this info magic + , removeExportWithContentIdentifier = removeExportWithContentIdentifierS3 hdl this info + , removeExportDirectoryWhenEmpty = Nothing + , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierS3 hdl this info + } , whereisKey = Just (getPublicWebUrls u info c) , remoteFsck = Nothing , repairRepo = Nothing @@ -150,8 +159,8 @@ , ("bucket", defbucket) ] - use fullconfig = do - enableBucketVersioning ss fullconfig gc u + use fullconfig info = do + enableBucketVersioning ss info fullconfig gc u gitConfigSpecialRemote u fullconfig [("s3", "true")] return (fullconfig, u) @@ -159,10 +168,12 @@ (c', encsetup) <- encryptionSetup c gc c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds let fullconfig = c'' `M.union` defaults + info <- extractS3Info fullconfig + checkexportimportsafe fullconfig info case ss of Init -> genBucket fullconfig gc u _ -> return () - use fullconfig + use fullconfig info archiveorg = do showNote "Internet Archive mode" @@ -182,10 +193,26 @@ -- special constraints on key names M.insert "mungekeys" "ia" defaults info <- extractS3Info archiveconfig + checkexportimportsafe archiveconfig info hdl <- mkS3HandleVar archiveconfig gc u withS3HandleOrFail u hdl $ writeUUIDFile archiveconfig u info - use archiveconfig + use archiveconfig info + + checkexportimportsafe c' info = + unlessM (Annex.getState Annex.force) $ + checkexportimportsafe' c' info + checkexportimportsafe' c' info + | versioning info = return () + | otherwise = when (exportTree c' && importTree c') $ + giveup $ unwords + [ "Combining exporttree=yes and importtree=yes" + , "with an unversioned S3 bucket is not safe;" + , "exporting can overwrite other modifications" + , "to files in the bucket." + , "Recommend you add versioning=yes." + , "(Or use --force if you don't mind possibly losing data.)" + ] store :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> Storer store mh r info magic = fileStorer $ \k f p -> withS3HandleOrFail (uuid r) mh $ \h -> do @@ -195,7 +222,7 @@ setUrlPresent k (iaPublicUrl info (bucketObject info k)) return True -storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID) +storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) storeHelper info h magic f object p = liftIO $ case partSize info of Just partsz | partsz > 0 -> do fsz <- getFileSize f @@ -209,8 +236,16 @@ rbody <- liftIO $ httpBodyStorer f p let req = (putObject info object rbody) { S3.poContentType = encodeBS <$> contenttype } - vid <- S3.porVersionId <$> sendS3Handle h req - return (mkS3VersionID object vid) + resp <- sendS3Handle h req + let vid = mkS3VersionID object (S3.porVersionId resp) + -- FIXME Actual aws version that supports this is not known, + -- patch not merged yet. + -- https://github.com/aristidb/aws/issues/258 +#if MIN_VERSION_aws(0,99,0) + return (Just (S3.porETag resp), vid) +#else + return (Nothing, vid) +#endif multipartupload fsz partsz = runResourceT $ do #if MIN_VERSION_aws(0,16,0) contenttype <- liftIO getcontenttype @@ -249,9 +284,9 @@ sendparts (offsetMeterUpdate meter (toBytesProcessed sz)) (etag:etags) (partnum + 1) sendparts p [] 1 - r <- sendS3Handle h $ S3.postCompleteMultipartUpload + resp <- sendS3Handle h $ S3.postCompleteMultipartUpload (bucket info) object uploadid (zip [1..] etags) - return (mkS3VersionID object (S3.cmurVersionId r)) + return (Just (S3.cmurETag resp), mkS3VersionID object (S3.cmurVersionId resp)) #else warningIO $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library." singlepartupload @@ -278,11 +313,14 @@ giveup "failed to download content" retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex () -retrieveHelper info h loc f p = liftIO $ runResourceT $ do - let req = case loc of +retrieveHelper info h loc f p = retrieveHelper' h f p $ + case loc of Left o -> S3.getObject (bucket info) o Right (S3VersionID o vid) -> (S3.getObject (bucket info) o) { S3.goVersionId = Just vid } + +retrieveHelper' :: S3Handle -> FilePath -> MeterUpdate -> S3.GetObject -> Annex () +retrieveHelper' h f p req = liftIO $ runResourceT $ do S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle h req Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp @@ -316,47 +354,37 @@ anyM check us checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool -checkKeyHelper info h loc = liftIO $ runResourceT $ do -#if MIN_VERSION_aws(0,10,0) - rsp <- go - return (isJust $ S3.horMetadata rsp) -#else - catchMissingException $ do - void go - return True -#endif +checkKeyHelper info h loc = checkKeyHelper' info h o limit where - go = sendS3Handle h req - req = case loc of - Left o -> S3.headObject (bucket info) o - Right (S3VersionID o vid) -> (S3.headObject (bucket info) o) - { S3.hoVersionId = Just vid } + (o, limit) = case loc of + Left obj -> + (obj, id) + Right (S3VersionID obj vid) -> + (obj, \ho -> ho { S3.hoVersionId = Just vid }) -#if ! MIN_VERSION_aws(0,10,0) - {- Catch exception headObject returns when an object is not present - - in the bucket, and returns False. All other exceptions indicate a - - check error and are let through. -} - catchMissingException :: Annex Bool -> Annex Bool - catchMissingException a = catchJust missing a (const $ return False) - where - missing :: AWS.HeaderException -> Maybe () - missing e - | AWS.headerErrorMessage e == "ETag missing" = Just () - | otherwise = Nothing -#endif +checkKeyHelper' :: S3Info -> S3Handle -> S3.Object -> (S3.HeadObject -> S3.HeadObject) -> Annex Bool +checkKeyHelper' info h o limit = liftIO $ runResourceT $ do + rsp <- sendS3Handle h req + return (isJust $ S3.horMetadata rsp) + where + req = limit $ S3.headObject (bucket info) o storeExportS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -storeExportS3 hv r info magic f k loc p = withS3Handle hv $ \case - Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return False) +storeExportS3 hv r info magic f k loc p = fst + <$> storeExportS3' hv r info magic f k loc p + +storeExportS3' :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Bool, (Maybe S3Etag, Maybe S3VersionID)) +storeExportS3' hv r info magic f k loc p = withS3Handle hv $ \case + Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return (False, (Nothing, Nothing))) Nothing -> do warning $ needS3Creds (uuid r) - return False + return (False, (Nothing, Nothing)) where go h = do let o = T.pack $ bucketExportLocation info loc - storeHelper info h magic f o p - >>= setS3VersionID info (uuid r) k - return True + (metag, mvid) <- storeHelper info h magic f o p + setS3VersionID info (uuid r) k mvid + return (True, (metag, mvid)) retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportS3 hv r info _k loc f p = @@ -420,6 +448,183 @@ srcobject = T.pack $ bucketExportLocation info src dstobject = T.pack $ bucketExportLocation info dest +listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsS3 hv r info = + withS3Handle hv $ \case + Nothing -> do + warning $ needS3Creds (uuid r) + return Nothing + Just h -> catchMaybeIO $ liftIO $ runResourceT $ startlist h + where + startlist h + | versioning info = do + rsp <- sendS3Handle h $ + S3.getBucketObjectVersions (bucket info) + continuelistversioned h [] rsp + | otherwise = do + rsp <- sendS3Handle h $ + S3.getBucket (bucket info) + continuelistunversioned h [] rsp + + continuelistunversioned h l rsp + | S3.gbrIsTruncated rsp = do + rsp' <- sendS3Handle h $ + (S3.getBucket (bucket info)) + { S3.gbMarker = S3.gbrNextMarker rsp + } + continuelistunversioned h (rsp:l) rsp' + | otherwise = return $ + mkImportableContentsUnversioned info (reverse (rsp:l)) + + continuelistversioned h l rsp + | S3.gbovrIsTruncated rsp = do + rsp' <- sendS3Handle h $ + (S3.getBucketObjectVersions (bucket info)) + { S3.gbovKeyMarker = S3.gbovrNextKeyMarker rsp + , S3.gbovVersionIdMarker = S3.gbovrNextVersionIdMarker rsp + } + continuelistversioned h (rsp:l) rsp' + | otherwise = return $ + mkImportableContentsVersioned info (reverse (rsp:l)) + +mkImportableContentsUnversioned :: S3Info -> [S3.GetBucketResponse] -> ImportableContents (ContentIdentifier, ByteSize) +mkImportableContentsUnversioned info l = ImportableContents + { importableContents = concatMap (mapMaybe extract . S3.gbrContents) l + , importableHistory = [] + } + where + extract oi = do + loc <- bucketImportLocation info $ + T.unpack $ S3.objectKey oi + let sz = S3.objectSize oi + let cid = mkS3UnversionedContentIdentifier $ S3.objectETag oi + return (loc, (cid, sz)) + +mkImportableContentsVersioned :: S3Info -> [S3.GetBucketObjectVersionsResponse] -> ImportableContents (ContentIdentifier, ByteSize) +mkImportableContentsVersioned info = build . groupfiles + where + build [] = ImportableContents [] [] + build l = + let (l', v) = latestversion l + in ImportableContents + { importableContents = mapMaybe extract v + , importableHistory = case build l' of + ImportableContents [] [] -> [] + h -> [h] + } + + extract ovi@(S3.ObjectVersion {}) = do + loc <- bucketImportLocation info $ + T.unpack $ S3.oviKey ovi + let sz = S3.oviSize ovi + let cid = mkS3VersionedContentIdentifier' ovi + return (loc, (cid, sz)) + extract (S3.DeleteMarker {}) = Nothing + + -- group files so all versions of a file are in a sublist, + -- with the newest first. S3 uses such an order, so it's just a + -- matter of breaking up the response list into sublists. + groupfiles = groupBy (\a b -> S3.oviKey a == S3.oviKey b) + . concatMap S3.gbovrContents + + latestversion [] = ([], []) + latestversion ([]:rest) = latestversion rest + latestversion l@((first:_old):remainder) = + go (S3.oviLastModified first) [first] remainder + where + go mtime c [] = (removemostrecent mtime l, reverse c) + go mtime c ([]:rest) = go mtime c rest + go mtime c ((latest:_old):rest) = + let !mtime' = max mtime (S3.oviLastModified latest) + in go mtime' (latest:c) rest + + removemostrecent _ [] = [] + removemostrecent mtime ([]:rest) = removemostrecent mtime rest + removemostrecent mtime (i@(curr:old):rest) + | S3.oviLastModified curr == mtime = + old : removemostrecent mtime rest + | otherwise = + i : removemostrecent mtime rest + +retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key) +retrieveExportWithContentIdentifierS3 hv r info loc cid dest mkkey p = withS3Handle hv $ \case + Nothing -> do + warning $ needS3Creds (uuid r) + return Nothing + Just h -> flip catchNonAsync (\e -> warning (show e) >> return Nothing) $ do + rewritePreconditionException $ retrieveHelper' h dest p $ + limitGetToContentIdentifier cid $ + S3.getObject (bucket info) o + mk <- mkkey + case (mk, extractContentIdentifier cid o) of + (Just k, Right vid) -> + setS3VersionID info (uuid r) k vid + _ -> noop + return mk + where + o = T.pack $ bucketExportLocation info loc + +{- Catch exception getObject returns when a precondition is not met, + - and replace with a more understandable message for the user. -} +rewritePreconditionException :: Annex a -> Annex a +rewritePreconditionException a = catchJust (Url.matchStatusCodeException want) a $ + const $ giveup "requested version of object is not available in S3 bucket" + where + want st = statusCode st == 412 && + statusMessage st == "Precondition Failed" + +-- Does not check if content on S3 is safe to overwrite, because there +-- is no atomic way to do so. When the bucket is versioned, this is +-- acceptable because listImportableContentsS3 will find versions +-- of files that were overwritten by this and no data is lost. +-- +-- When the bucket is not versioned, data loss can result. +-- This is why that configuration requires --force to enable. +storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier) +storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p + | versioning info = go + -- FIXME Actual aws version that supports getting Etag for a store + -- is not known; patch not merged yet. + -- https://github.com/aristidb/aws/issues/258 +#if MIN_VERSION_aws(0,99,0) + | otherwise = go +#else + | otherwise = do + warning "git-annex is built with too old a version of the aws library to support this operation" + return Nothing +#endif + where + go = storeExportS3' hv r info magic src k loc p >>= \case + (False, _) -> return Nothing + (True, (_, Just vid)) -> return $ Just $ + mkS3VersionedContentIdentifier vid + (True, (Just etag, Nothing)) -> return $ Just $ + mkS3UnversionedContentIdentifier etag + (True, (Nothing, Nothing)) -> do + warning "did not get ETag for store to S3 bucket" + return Nothing + +-- Does not guarantee that the removed object has the content identifier, +-- but when the bucket is versioned, the removed object content can still +-- be recovered (and listImportableContentsS3 will find it). +-- +-- When the bucket is not versioned, data loss can result. +-- This is why that configuration requires --force to enable. +removeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +removeExportWithContentIdentifierS3 hv r info k loc _removeablecids = + removeExportS3 hv r info k loc + +checkPresentExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +checkPresentExportWithContentIdentifierS3 hv r info _k loc knowncids = + withS3Handle hv $ \case + Just h -> flip anyM knowncids $ + checkKeyHelper' info h o . limitHeadToContentIdentifier + Nothing -> do + warning $ needS3Creds (uuid r) + giveup "No S3 credentials configured" + where + o = T.pack $ bucketExportLocation info loc + {- Generate the bucket if it does not already exist, including creating the - UUID file within the bucket. - @@ -447,21 +652,17 @@ (S3.putBucket (bucket info)) { S3.pbCannedAcl = acl info , S3.pbLocationConstraint = locconstraint -#if MIN_VERSION_aws(0,13,0) , S3.pbXStorageClass = storageclass -#endif } writeUUIDFile c u info h locconstraint = mkLocationConstraint $ T.pack datacenter datacenter = fromJust $ M.lookup "datacenter" c -#if MIN_VERSION_aws(0,13,0) -- "NEARLINE" as a storage class when creating a bucket is a -- nonstandard extension of Google Cloud Storage. storageclass = case getStorageClass c of sc@(S3.OtherStorageClass "NEARLINE") -> Just sc _ -> Nothing -#endif {- Writes the UUID to an annex-uuid file within the bucket. - @@ -611,6 +812,7 @@ , storageClass :: S3.StorageClass , bucketObject :: Key -> BucketObject , bucketExportLocation :: ExportLocation -> BucketObject + , bucketImportLocation :: BucketObject -> Maybe ImportLocation , metaHeaders :: [(T.Text, T.Text)] , partSize :: Maybe Integer , isIA :: Bool @@ -631,6 +833,7 @@ , storageClass = getStorageClass c , bucketObject = getBucketObject c , bucketExportLocation = getBucketExportLocation c + , bucketImportLocation = getBucketImportLocation c , metaHeaders = getMetaHeaders c , partSize = getPartSize c , isIA = configIA c @@ -661,9 +864,7 @@ getStorageClass :: RemoteConfig -> S3.StorageClass getStorageClass c = case M.lookup "storageclass" c of Just "REDUCED_REDUNDANCY" -> S3.ReducedRedundancy -#if MIN_VERSION_aws(0,13,0) Just s -> S3.OtherStorageClass (T.pack s) -#endif _ -> S3.Standard getPartSize :: RemoteConfig -> Maybe Integer @@ -690,6 +891,19 @@ getBucketExportLocation :: RemoteConfig -> ExportLocation -> BucketObject getBucketExportLocation c loc = getFilePrefix c ++ fromExportLocation loc +getBucketImportLocation :: RemoteConfig -> BucketObject -> Maybe ImportLocation +getBucketImportLocation c obj + -- The uuidFile should not be imported. + | obj == uuidfile = Nothing + -- Only import files that are under the fileprefix, when + -- one is configured. + | prefix `isPrefixOf` obj = Just $ mkImportLocation $ drop prefixlen obj + | otherwise = Nothing + where + prefix = getFilePrefix c + prefixlen = length prefix + uuidfile = uuidFile c + {- 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. -} @@ -764,9 +978,7 @@ ] where s3c = s3Configuration c -#if MIN_VERSION_aws(0,13,0) showstorageclass (S3.OtherStorageClass t) = T.unpack t -#endif showstorageclass sc = show sc getPublicWebUrls :: UUID -> S3Info -> RemoteConfig -> Key -> Annex [URLString] @@ -804,7 +1016,11 @@ Just (iaPublicUrl info) _ -> Nothing - +-- S3 uses a unique version id for each object stored on it. +-- +-- The Object is included in this because retrieving a particular +-- version id involves a request for an object, so this keeps track of what +-- the object is. data S3VersionID = S3VersionID S3.Object T.Text deriving (Show) @@ -834,6 +1050,58 @@ o <- eitherToMaybe $ T.decodeUtf8' $ BS.drop 1 rest mkS3VersionID o (eitherToMaybe $ T.decodeUtf8' v) +-- For a versioned bucket, the S3VersionID is used as the +-- ContentIdentifier. +mkS3VersionedContentIdentifier :: S3VersionID -> ContentIdentifier +mkS3VersionedContentIdentifier (S3VersionID _ v) = + ContentIdentifier $ T.encodeUtf8 v + +mkS3VersionedContentIdentifier' :: S3.ObjectVersionInfo -> ContentIdentifier +mkS3VersionedContentIdentifier' = + ContentIdentifier . T.encodeUtf8 . S3.oviVersionId + +-- S3 returns etags surrounded by double quotes, and the quotes may +-- be included here. +type S3Etag = T.Text + +-- For an unversioned bucket, the S3Etag is instead used as the +-- ContentIdentifier. Prefixed by '#' since that cannot appear in a S3 +-- version id. +mkS3UnversionedContentIdentifier :: S3Etag -> ContentIdentifier +mkS3UnversionedContentIdentifier t = + ContentIdentifier $ T.encodeUtf8 $ "#" <> T.filter (/= '"') t + +-- Makes a GetObject request be guaranteed to get the object version +-- matching the ContentIdentifier, or fail. +limitGetToContentIdentifier :: ContentIdentifier -> S3.GetObject -> S3.GetObject +limitGetToContentIdentifier cid req = + limitToContentIdentifier cid + (\etag -> req { S3.goIfMatch = etag }) + (\versionid -> req { S3.goVersionId = versionid }) + +limitHeadToContentIdentifier :: ContentIdentifier -> S3.HeadObject -> S3.HeadObject +limitHeadToContentIdentifier cid req = + limitToContentIdentifier cid + (\etag -> req { S3.hoIfMatch = etag }) + (\versionid -> req { S3.hoVersionId = versionid }) + +limitToContentIdentifier :: ContentIdentifier -> (Maybe S3Etag -> a) -> (Maybe T.Text -> a) -> a +limitToContentIdentifier (ContentIdentifier v) limitetag limitversionid = + let t = either mempty id (T.decodeUtf8' v) + in case T.take 1 t of + "#" -> + let etag = T.drop 1 t + in limitetag (Just etag) + _ -> limitversionid (Just t) + +-- A ContentIdentifier contains either a etag or a S3 version id. +extractContentIdentifier :: ContentIdentifier -> S3.Object -> Either S3Etag (Maybe S3VersionID) +extractContentIdentifier (ContentIdentifier v) o = + let t = either mempty id (T.decodeUtf8' v) + in case T.take 1 t of + "#" -> Left (T.drop 1 t) + _ -> Right (mkS3VersionID o (Just t)) + setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex () setS3VersionID info u k vid | versioning info = maybe noop (setS3VersionID' u k) vid @@ -881,13 +1149,12 @@ -- Enable versioning on the bucket can only be done at init time; -- setting versioning in a bucket that git-annex has already exported -- files to risks losing the content of those un-versioned files. -enableBucketVersioning :: SetupStage -> RemoteConfig -> RemoteGitConfig -> UUID -> Annex () +enableBucketVersioning :: SetupStage -> S3Info -> RemoteConfig -> RemoteGitConfig -> UUID -> Annex () #if MIN_VERSION_aws(0,21,1) -enableBucketVersioning ss c gc u = do +enableBucketVersioning ss info c gc u = do #else -enableBucketVersioning ss c _ _ = do +enableBucketVersioning ss info _ _ _ = do #endif - info <- extractS3Info c case ss of Init -> when (versioning info) $ enableversioning (bucket info) diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matcher types - - - Copyright 2013-2016 Joey Hess + - Copyright 2013-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,6 +9,7 @@ import Types.UUID (UUID) import Types.Key (Key, AssociatedFile) +import Types.Mime import Utility.Matcher (Matcher, Token) import Utility.FileSize @@ -16,18 +17,27 @@ import qualified Data.Map as M import qualified Data.Set as S +-- Information about a file or a key that can be matched on. data MatchInfo = MatchingFile FileInfo | MatchingKey Key AssociatedFile - | MatchingInfo (OptInfo FilePath) (OptInfo Key) (OptInfo FileSize) (OptInfo MimeType) - -type MimeType = String + | MatchingInfo ProvidedInfo data FileInfo = FileInfo { currFile :: FilePath -- ^ current path to the file, for operations that examine it , matchFile :: FilePath -- ^ filepath to match on; may be relative to top of repo or cwd + } + +-- This is used when testing a matcher, with values to match against +-- provided by the user, rather than queried from files. +data ProvidedInfo = ProvidedInfo + { providedFilePath :: OptInfo FilePath + , providedKey :: OptInfo Key + , providedFileSize :: OptInfo FileSize + , providedMimeType :: OptInfo MimeType + , providedMimeEncoding :: OptInfo MimeEncoding } type OptInfo a = Either (IO a) a diff --git a/Types/Mime.hs b/Types/Mime.hs new file mode 100644 --- /dev/null +++ b/Types/Mime.hs @@ -0,0 +1,12 @@ +{- git-annex mime types + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.Mime where + +type MimeType = String + +type MimeEncoding = String diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -18,7 +18,9 @@ import Data.Time.Clock.POSIX import Data.Ratio import System.Posix.Types +#if MIN_VERSION_QuickCheck(2,10,0) import Data.List.NonEmpty (NonEmpty(..)) +#endif import Prelude {- Times before the epoch are excluded. Half with decimal and half without. -} diff --git a/doc/git-annex-dead.mdwn b/doc/git-annex-dead.mdwn --- a/doc/git-annex-dead.mdwn +++ b/doc/git-annex-dead.mdwn @@ -32,6 +32,8 @@ [[git-annex-untrust]](1) +[[git-annex-renameremote]](1) + [[git-annex-expire]](1) [[git-annex-fsck]](1) diff --git a/doc/git-annex-export.mdwn b/doc/git-annex-export.mdwn --- a/doc/git-annex-export.mdwn +++ b/doc/git-annex-export.mdwn @@ -55,9 +55,10 @@ You can combine using `git annex export` to send changes to a special remote with `git annex import` to fetch changes from a special remote. -When a file on a special remote has been modified, exporting to it will -not overwrite the modified file, and the export will not succeed. -You can resolve this conflict by using `git annex import`. +When a file on a special remote has been modified by software other than +git-annex, exporting to it will not overwrite the modified file, and the +export will not succeed. You can resolve this conflict by using +`git annex import`. (Some types of special remotes such as S3 with versioning may instead let an export overwrite the modified file; then `git annex import` diff --git a/doc/git-annex-info.mdwn b/doc/git-annex-info.mdwn --- a/doc/git-annex-info.mdwn +++ b/doc/git-annex-info.mdwn @@ -4,16 +4,16 @@ # SYNOPSIS -git annex info `[directory|file|treeish|remote|uuid ...]` +git annex info `[directory|file|treeish|remote|description|uuid ...]` # DESCRIPTION Displays statistics and other information for the specified item, which can be a directory, or a file, or a treeish, or a remote, -or the uuid of a repository. +or the description or uuid of a repository. When no item is specified, displays statistics and information -for the repository as a whole. +for the local repository and all known annexed files. # OPTIONS diff --git a/doc/git-annex-initremote.mdwn b/doc/git-annex-initremote.mdwn --- a/doc/git-annex-initremote.mdwn +++ b/doc/git-annex-initremote.mdwn @@ -19,25 +19,19 @@ The remote's configuration is specified by the parameters passed to this command. Different types of special remotes need different -configuration values. The command will prompt for parameters as needed. - -All special remotes support encryption. You can specify -`encryption=none` to disable encryption, or specify -`encryption=hybrid keyid=$keyid ...` to specify a GPG key id (or an email -address associated with a key). For details about ways to configure -encryption, see +configuration values. The command will prompt for parameters as needed. A +few parameters that are supported by all special remotes are documented in +the next section below. -If you anticipate using the new special remote in other clones of the -repository, you can pass "autoenable=true". Then when [[git-annex-init]](1) -is run in a new clone, it will attempt to enable the special remote. Of -course, this works best when the special remote does not need anything -special to be done to get it enabled. +Once a special remote has been initialized once with this command, +other clones of the repository can also be set up to access it using +`git annex enableremote`. -Normally, git-annex generates a new UUID for the new special remote. -If you want to, you can specify a UUID for it to use, by passing a -uuid=whatever parameter. This can be useful in some situations, eg when the -same data can be accessed via two different special remote backends. -But if in doubt, don't do this. +The name you provide for the remote can't be one that's been used for any +other special remote before, because `git-annex enableremote` uses the name +to identify which special remote to enable. If some old special remote +that's no longer used has taken the name you want to reuse, you might +want to use `git annex renameremote`. # OPTIONS @@ -49,11 +43,43 @@ and re-run with `--fast`, which causes it to use a lower-quality source of randomness. (Ie, /dev/urandom instead of /dev/random) +# COMMON CONFIGURATION PARAMETERS + +* `encryption` + + All special remotes support encryption. You will need to specify + what encryption, if any, to use. + + If you do not want any encryption, use `encryption=none` + + To encrypt to a GPG key, use `encryption=hybrid keyid=$keyid ...` + and fill in the GPG key id (or an email address associated with a GPG key). + + For details about this and other encrpytion settings, see + + +* `autoenable` + + To avoid `git annex enableremote` needing to be run, + you can pass "autoenable=true". Then when [[git-annex-init]](1) + is run in a new clone, it will attempt to enable the special remote. Of + course, this works best when the special remote does not need anything + special to be done to get it enabled. + +* `uuid` + + Normally, git-annex initremote generates a new UUID for the new special + remote. If you want to, you can specify a UUID for it to use, by passing a + uuid=whatever parameter. This can be useful in some unusual situations. + But if in doubt, don't do this. + # SEE ALSO [[git-annex]](1) [[git-annex-enableremote]](1) + +[[git-annex-renameremote]](1) # AUTHOR diff --git a/doc/git-annex-matchexpression.mdwn b/doc/git-annex-matchexpression.mdwn --- a/doc/git-annex-matchexpression.mdwn +++ b/doc/git-annex-matchexpression.mdwn @@ -48,6 +48,11 @@ Tell what the mime type of the file is. Only needed when using --largefiles with a mimetype= expression. +* `--mimeencoding=` + + Tell what the mime encoding of the file is. Only needed when using + --largefiles with a mimeencoding= expression. + # SEE ALSO [[git-annex]](1) diff --git a/doc/git-annex-metadata.mdwn b/doc/git-annex-metadata.mdwn --- a/doc/git-annex-metadata.mdwn +++ b/doc/git-annex-metadata.mdwn @@ -22,18 +22,12 @@ this cannot be directly modified by this command. It is updated automatically. -Note that the metadata is attached to the particular content of a file, -not to a particular filename on a particular git branch. More precisely, -metadata is attached to the key used for the file, which can reflect -file contents and/or name, depending on the key-value backend used for the file. +Note that the metadata is attached to git-annex key corresponding to the +content of a file, not to a particular filename on a particular git branch. All files with the same key share the same metadata, which is -stored in the git-annex branch. If a file is edited, old -metadata will be copied to the new key when you [[git-annex-add]] -the edited file. Note also that changes to a file's git-annex metadata will -not be reflected in the git log of the file, since they are stored on the -git-annex branch. To attach metadata to a particular path, -rather than a particular key, use .gitattributes . - +stored in the git-annex branch. If a file is modified, the metadata +of the previous version will be copied to the new key when git-annex adds +the modified file. # OPTIONS diff --git a/doc/git-annex-renameremote.mdwn b/doc/git-annex-renameremote.mdwn new file mode 100644 --- /dev/null +++ b/doc/git-annex-renameremote.mdwn @@ -0,0 +1,41 @@ +# NAME + +git-annex renameremote - changes name of a special remote + +# SYNOPSIS + +git annex renameremote `name|uuid|desc newname` + +# DESCRIPTION + +Changes the name that is used to enable a special remote. + +Normally the current name is used to identify the special remote, +but its uuid or description can also be used. + +This is especially useful when an old special remote used a name, and now you +want to use that name for a new special remote. `git annex initremote` +won't let you create a remote with a conflicting name, so rename the old +remote first. + + git annex renameremote phone lost-phone + git annex initremote phone ... + +This only updates the name that git-annex has stored for use +by `git annex enableremote`. It does not update the git config stanza +for the special remote to use the new name, but of course you can edit +the git config if you want to rename it there. + +# SEE ALSO + +[[git-annex]](1) + +[[git-annex-initremote]](1) + +[[git-annex-enableremote]](1) + +# AUTHOR + +Joey Hess + +Warning: Automatically converted into a man page by mdwn2man. Edit with care. diff --git a/doc/git-annex-unused.mdwn b/doc/git-annex-unused.mdwn --- a/doc/git-annex-unused.mdwn +++ b/doc/git-annex-unused.mdwn @@ -64,7 +64,7 @@ For example, "+HEAD^" adds "HEAD^". Each - is matched against the set of refs accumulated so far. -Any matching refs are removed from the set. +Any refs with names that match are removed from the set. "reflog" adds all the refs from the reflog. This will make past versions of files not be considered to be unused until the ref expires from the diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -225,6 +225,12 @@ See [[git-annex-enableremote]](1) for details. +* `renameremote` + + Renames a special remote. + + See [[git-annex-renameremote]](1) for details. + * `enable-tor` Sets up tor hidden service. @@ -794,7 +800,7 @@ The repository should be specified using the name of a configured remote, or the UUID or description of a repository. -* `--trust-glacier-inventory` +* `--trust-glacier` Amazon Glacier inventories take hours to retrieve, and may not represent the current state of a repository. So git-annex does not trust that 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: 7.20190322 +Version: 7.20190503 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess @@ -104,6 +104,7 @@ doc/git-annex-reinject.mdwn doc/git-annex-rekey.mdwn doc/git-annex-remotedaemon.mdwn + doc/git-annex-renameremote.mdwn doc/git-annex-repair.mdwn doc/git-annex-required.mdwn doc/git-annex-resolvemerge.mdwn @@ -401,7 +402,7 @@ Build-Depends: network (< 3.0.0.0), network (>= 2.6.3.0) if flag(S3) - Build-Depends: aws (>= 0.9.2) + Build-Depends: aws (>= 0.14) CPP-Options: -DWITH_S3 Other-Modules: Remote.S3 @@ -766,6 +767,7 @@ Command.Reinit Command.Reinject Command.RemoteDaemon + Command.RenameRemote Command.Repair Command.Required Command.ResolveMerge @@ -842,6 +844,7 @@ Git.Fsck Git.GCrypt Git.HashObject + Git.History Git.Hook Git.Index Git.LockFile @@ -984,6 +987,7 @@ Types.LockCache Types.Messages Types.MetaData + Types.Mime Types.NumCopies Types.RefSpec Types.Remote