diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports, BangPatterns #-} @@ -96,7 +96,8 @@ MonadMask, Fail.MonadFail, Functor, - Applicative + Applicative, + Alternative ) -- internal state storage diff --git a/Annex/Action.hs b/Annex/Action.hs --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.AutoMerge diff --git a/Annex/BloomFilter.hs b/Annex/BloomFilter.hs --- a/Annex/BloomFilter.hs +++ b/Annex/BloomFilter.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.BloomFilter where diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Branch ( @@ -24,7 +24,7 @@ forceCommit, getBranch, files, - graftTreeish, + rememberTreeish, performTransitions, withIndex, ) where @@ -51,6 +51,7 @@ import qualified Git.UnionMerge import qualified Git.UpdateIndex import qualified Git.Tree +import qualified Git.LsTree import Git.LsTree (lsTreeParams) import qualified Git.HashObject import Annex.HashObject @@ -366,7 +367,7 @@ branchFiles' :: Git.Repo -> IO [FilePath] branchFiles' = Git.Command.pipeNullSplitZombie - (lsTreeParams fullname [Param "--name-only"]) + (lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"]) {- Populates the branch's index file with the current branch contents. - @@ -645,16 +646,15 @@ - 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 +rememberTreeish :: Git.Ref -> TopFilePath -> Annex () +rememberTreeish 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 + origtree <- fromMaybe (giveup "unable to determine git-annex branch tree") <$> + inRepo (Git.Ref.tree branchref) + addedt <- inRepo $ Git.Tree.graftTree treeish graftpoint origtree c <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit - "graft" [branchref] t' - origtree <- inRepo $ Git.Tree.recordTree (Git.Tree.Tree t) + "graft" [branchref] addedt c' <- inRepo $ Git.Branch.commitTree Git.Branch.AutomaticCommit "graft cleanup" [c] origtree inRepo $ Git.Branch.update' fullname c' diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Branch.Transitions ( @@ -40,15 +40,15 @@ dropDead :: FilePath -> L.ByteString -> TrustMap -> FileTransition dropDead f content trustmap = case getLogVariety f of - Just UUIDBasedLog + Just OldUUIDBasedLog -- Don't remove the dead repo from the trust log, -- because git remotes may still exist, and they need -- to still know it's dead. | f == trustLog -> PreserveFile | otherwise -> ChangeFile $ - UUIDBased.buildLog byteString $ + UUIDBased.buildLogOld byteString $ dropDeadFromMapLog trustmap id $ - UUIDBased.parseLog A.takeByteString content + UUIDBased.parseLogOld A.takeByteString content Just NewUUIDBasedLog -> ChangeFile $ UUIDBased.buildLogNew byteString $ dropDeadFromMapLog trustmap id $ diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs --- a/Annex/BranchState.hs +++ b/Annex/BranchState.hs @@ -4,7 +4,7 @@ - - Copyright 2011-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.BranchState where diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.CatFile ( diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -2,7 +2,7 @@ - - Copyright 2014-216 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.ChangedRefs diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs --- a/Annex/CheckAttr.hs +++ b/Annex/CheckAttr.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.CheckAttr ( diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs --- a/Annex/CheckIgnore.hs +++ b/Annex/CheckIgnore.hs @@ -3,7 +3,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.CheckIgnore ( diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Concurrent where diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -5,7 +5,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Content.Direct ( diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/Difference.hs b/Annex/Difference.hs --- a/Annex/Difference.hs +++ b/Annex/Difference.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Difference ( diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.DirHashes ( diff --git a/Annex/Direct.hs b/Annex/Direct.hs --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -5,7 +5,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Direct where diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Drop where @@ -16,7 +16,6 @@ import qualified Command.Drop import Command import Annex.Wanted -import Annex.Export import Config import Annex.Content.Direct import qualified Database.Keys diff --git a/Annex/Environment.hs b/Annex/Environment.hs --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Environment where diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Export where @@ -13,11 +13,9 @@ import Types.Key import qualified Git import qualified Types.Remote as Remote -import Config import Messages import Utility.FileSystemEncoding -import qualified Data.Map as M import Control.Applicative import Data.Maybe import Prelude @@ -43,9 +41,6 @@ , keyChunkSize = Nothing , keyChunkNum = Nothing } - -exportTree :: Remote.RemoteConfig -> Bool -exportTree c = fromMaybe False $ yesNo =<< M.lookup "exporttree" c warnExportConflict :: Remote -> Annex () warnExportConflict r = toplevelWarning True $ diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Fixup where diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.GitOverlay where diff --git a/Annex/HashObject.hs b/Annex/HashObject.hs --- a/Annex/HashObject.hs +++ b/Annex/HashObject.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.HashObject ( diff --git a/Annex/Hook.hs b/Annex/Hook.hs --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -6,7 +6,7 @@ - - Copyright 2013-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Hook where diff --git a/Annex/Import.hs b/Annex/Import.hs new file mode 100644 --- /dev/null +++ b/Annex/Import.hs @@ -0,0 +1,339 @@ +{- git-annex import from remotes + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Annex.Import ( + importTree, + ImportTreeConfig(..), + ImportCommitConfig(..), + buildImportCommit, + buildImportTrees, + downloadImport +) where + +import Annex.Common +import Types.Import +import qualified Types.Remote as Remote +import Git.Types +import Git.Tree +import Git.Sha +import Git.FilePath +import qualified Git.Ref +import qualified Git.Branch +import qualified Annex +import Annex.Link +import Annex.LockFile +import Annex.Content +import Annex.Export +import Command +import Backend +import Config +import Types.Key +import Types.KeySource +import Messages.Progress +import Utility.DataUnits +import Logs.Export +import Logs.Location +import qualified Database.Export as Export +import qualified Database.ContentIdentifier as CIDDb +import qualified Logs.ContentIdentifier as CIDLog + +import Control.Concurrent.STM +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +{- Configures how to build an import tree. -} +data ImportTreeConfig + = ImportTree + -- ^ Import the tree as-is from the remote. + | ImportSubTree TopFilePath Sha + -- ^ Import a tree from the remote and graft it into a subdirectory + -- of the existing tree whose Sha is provided, replacing anything + -- that was there before. + deriving (Show) + +{- Configures how to build an import commit. -} +data ImportCommitConfig = ImportCommitConfig + { importCommitParent :: Maybe Sha + -- ^ Commit to use as a parent of the import commit. + , 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. + - + - When there are no changes to commit (ie, the imported tree is the same + - as the tree in the importCommitParent), 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 + - updated to reflect the imported tree. + - + - This does not download any content from a remote. But since it needs the + - Key of imported files to be known, its caller will have to first download + - new files in order to generate keys for them. + -} +buildImportCommit + :: Remote + -> ImportTreeConfig + -> ImportCommitConfig + -> 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) + where + basetree = case importtreeconfig of + ImportTree -> emptyTree + ImportSubTree _ sha -> sha + subdir = case importtreeconfig of + ImportTree -> Nothing + ImportSubTree dir _ -> Just dir + + go origtree basecommit = do + imported@(History finaltree _) <- + buildImportTrees basetree subdir importable + mkcommits origtree basecommit imported >>= \case + Nothing -> return Nothing + 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) + + updatestate committedtree = do + importedtree <- case subdir of + Nothing -> pure committedtree + Just dir -> + let subtreeref = Ref $ + fromRef committedtree ++ ":" ++ getTopFilePath dir + in fromMaybe emptyTree + <$> inRepo (Git.Ref.tree subtreeref) + updateexportdb importedtree + oldexport <- updateexportlog importedtree + updatelocationlog oldexport importedtree + + updateexportdb importedtree = do + db <- Export.openDb (Remote.uuid remote) + Export.writeLockDbWhile db $ do + prevtree <- liftIO $ fromMaybe emptyTree + <$> Export.getExportTreeCurrent db + when (importedtree /= prevtree) $ do + Export.updateExportDb db prevtree importedtree + liftIO $ Export.recordExportTreeCurrent db importedtree + Export.closeDb db + + updateexportlog importedtree = do + oldexport <- getExport (Remote.uuid remote) + recordExport (Remote.uuid remote) $ ExportChange + { oldTreeish = exportedTreeishes oldexport + , newTreeish = importedtree + } + return oldexport + + -- downloadImport takes care of updating the location log + -- for the local repo when keys are downloaded, and also updates + -- the location log for the remote for keys that are present in it. + -- That leaves updating the location log for the remote for keys + -- that have had the last copy of their content removed from it. + -- + -- This must run after the export database has been updated + -- and flushed to disk, so it can query it. + updatelocationlog oldexport finaltree = do + let stillpresent db k = liftIO $ not . null + <$> Export.getExportedLocation db k + let updater db oldkey _newkey _ = case oldkey of + Just (AnnexKey k) -> unlessM (stillpresent db k) $ + logChange k (Remote.uuid remote) InfoMissing + Just (GitKey _) -> noop + Nothing -> noop + db <- Export.openDb (Remote.uuid remote) + forM_ (exportedTreeishes oldexport) $ \oldtree -> + Export.runExportDiffUpdater updater db oldtree finaltree + Export.closeDb db + +data History t = History t [History t] + deriving (Show) + +{- Builds a history of git trees reflecting the ImportableContents. + - + - When a subdir is provided, imported tree is grafted into the basetree at + - that location, replacing any object that was there. + -} +buildImportTrees + :: Ref + -> Maybe TopFilePath + -> ImportableContents Key + -> Annex (History Sha) +buildImportTrees basetree msubdir importable = History + <$> (go (importableContents importable) =<< Annex.gitRepo) + <*> mapM (buildImportTrees basetree msubdir) (importableHistory importable) + where + go ls repo = withMkTreeHandle repo $ \hdl -> do + importtree <- liftIO . recordTree' hdl + . treeItemsToTree + =<< mapM mktreeitem ls + case msubdir of + Nothing -> return importtree + Just subdir -> liftIO $ + graftTree' importtree subdir basetree repo hdl + mktreeitem (loc, k) = do + let lf = fromImportLocation loc + let treepath = asTopFilePath lf + let topf = asTopFilePath $ + maybe lf (\sd -> getTopFilePath sd lf) msubdir + relf <- fromRepo $ fromTopFilePath topf + symlink <- calcRepo $ gitAnnexLink relf k + linksha <- hashSymlink symlink + return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha + +{- 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. + -} +downloadImport :: Remote -> ImportTreeConfig -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (Maybe (ImportableContents Key)) +downloadImport remote importtreeconfig importablecontents = do + -- This map is used to remember content identifiers that + -- were just downloaded, before they have necessarily been + -- stored in the database. This way, if the same content + -- identifier appears multiple times in the + -- importablecontents (eg when it has a history), + -- they will only be downloaded once. + cidmap <- liftIO $ newTVarIO M.empty + -- When concurrency is enabled, this set is needed to + -- avoid two threads both downloading the same content identifier. + downloading <- liftIO $ newTVarIO S.empty + withExclusiveLock gitAnnexContentIdentifierLock $ + bracket CIDDb.openDb CIDDb.closeDb $ \db -> do + CIDDb.needsUpdateFromLog db + >>= maybe noop (CIDDb.updateFromLog db) + go cidmap downloading importablecontents db + where + go cidmap downloading (ImportableContents l h) db = do + jobs <- forM l $ \i -> + startdownload cidmap downloading db i + 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 + if any isNothing h' + then return Nothing + else return $ Just $ + ImportableContents + (catMaybes l') + (catMaybes h') + + waitstart downloading cid = liftIO $ atomically $ do + s <- readTVar downloading + if S.member cid s + then retry + else writeTVar downloading $ S.insert cid s + + signaldone downloading cid = liftIO $ atomically $ do + s <- readTVar downloading + writeTVar downloading $ S.delete cid s + + startdownload cidmap downloading db i@(loc, (cid, _sz)) = 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) + next $ tryNonAsync (download cidmap db i) >>= \case + Left e -> next $ do + warning (show e) + liftIO $ atomically $ + putTMVar job Nothing + return False + Right r -> next $ do + liftIO $ atomically $ + putTMVar job r + return True + commandAction $ bracket_ + (waitstart downloading cid) + (signaldone downloading cid) + downloadaction + return (Right job) + + download cidmap db (loc, (cid, sz)) = do + let rundownload tmpfile p = + Remote.retrieveExportWithContentIdentifier ia loc cid tmpfile (mkkey loc tmpfile) p >>= \case + Just k -> tryNonAsync (moveAnnex k tmpfile) >>= \case + Right True -> do + recordcidkey cidmap db cid k + logStatus k InfoPresent + logChange k (Remote.uuid remote) InfoPresent + return $ Just (loc, k) + _ -> return Nothing + Nothing -> return Nothing + checkDiskSpaceToGet tmpkey Nothing $ + withTmp tmpkey $ \tmpfile -> + metered Nothing tmpkey (return Nothing) $ + const (rundownload tmpfile) + where + ia = Remote.importActions remote + tmpkey = importKey cid sz + + mkkey loc tmpfile = do + f <- fromRepo $ fromTopFilePath $ locworktreefilename loc + backend <- chooseBackend f + let ks = KeySource + { keyFilename = f + , contentLocation = tmpfile + , inodeCache = Nothing + } + fmap fst <$> genKey ks backend + + locworktreefilename loc = asTopFilePath $ case importtreeconfig of + ImportTree -> fromImportLocation loc + ImportSubTree subdir _ -> + getTopFilePath subdir fromImportLocation loc + + getcidkey cidmap db cid = liftIO $ + CIDDb.getContentIdentifierKeys db (Remote.uuid remote) cid >>= \case + [] -> atomically $ + maybeToList . M.lookup cid <$> readTVar cidmap + l -> return l + + recordcidkey cidmap db cid k = do + liftIO $ atomically $ modifyTVar' cidmap $ + M.insert cid k + liftIO $ CIDDb.recordContentIdentifier db (Remote.uuid remote) cid k + CIDLog.recordContentIdentifier (Remote.uuid remote) cid k + +{- Temporary key used for import of a ContentIdentifier while downloading + - content, before generating its real key. -} +importKey :: ContentIdentifier -> Integer -> Key +importKey (ContentIdentifier cid) size = stubKey + { keyName = cid + , keyVariety = OtherKey "CID" + , keySize = Just size + } diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Ingest ( diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/InodeSentinal.hs b/Annex/InodeSentinal.hs --- a/Annex/InodeSentinal.hs +++ b/Annex/InodeSentinal.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/Journal.hs b/Annex/Journal.hs --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -6,7 +6,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Journal where diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -9,7 +9,7 @@ - - Copyright 2013-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP, BangPatterns #-} diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} @@ -48,6 +48,9 @@ gitAnnexSmudgeLock, gitAnnexExportDbDir, gitAnnexExportLock, + gitAnnexExportUpdateLock, + gitAnnexContentIdentifierDbDir, + gitAnnexContentIdentifierLock, gitAnnexScheduleState, gitAnnexTransferDir, gitAnnexCredsDir, @@ -347,6 +350,18 @@ {- Lock file for export state for a special remote. -} gitAnnexExportLock :: UUID -> Git.Repo -> FilePath gitAnnexExportLock u r = gitAnnexExportDbDir u r ++ ".lck" + +{- Lock file for updating the export state for a special remote. -} +gitAnnexExportUpdateLock :: UUID -> Git.Repo -> FilePath +gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r ++ ".upl" + +{- Directory containing database used to record remote content ids. -} +gitAnnexContentIdentifierDbDir :: Git.Repo -> FilePath +gitAnnexContentIdentifierDbDir r = gitAnnexDir r "cid" + +{- Lock file for writing to the content id database. -} +gitAnnexContentIdentifierLock :: Git.Repo -> FilePath +gitAnnexContentIdentifierLock r = gitAnnexContentIdentifierDbDir r ++ ".lck" {- .git/annex/schedulestate is used to store information about when - scheduled jobs were last run. -} diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -14,6 +14,7 @@ fromLockCache, withSharedLock, withExclusiveLock, + takeExclusiveLock, tryExclusiveLock, ) where @@ -77,11 +78,18 @@ {- Runs an action with an exclusive lock held. If the lock is already - held, blocks until it becomes free. -} withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a -withExclusiveLock getlockfile a = debugLocks $ do +withExclusiveLock getlockfile a = bracket + (takeExclusiveLock getlockfile) + (liftIO . dropLock) + (const a) + +{- Takes an exclusive lock, blocking until it's free. -} +takeExclusiveLock :: (Git.Repo -> FilePath) -> Annex LockHandle +takeExclusiveLock getlockfile = debugLocks $ do lockfile <- fromRepo getlockfile createAnnexDirectory $ takeDirectory lockfile mode <- annexFileMode - bracket (lock mode lockfile) (liftIO . dropLock) (const a) + lock mode lockfile where #ifndef mingw32_HOST_OS lock mode = noUmask mode . lockExclusive (Just mode) diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs --- a/Annex/LockPool.hs +++ b/Annex/LockPool.hs @@ -3,7 +3,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/LockPool/PosixOrPid.hs b/Annex/LockPool/PosixOrPid.hs --- a/Annex/LockPool/PosixOrPid.hs +++ b/Annex/LockPool/PosixOrPid.hs @@ -3,7 +3,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.LockPool.PosixOrPid ( diff --git a/Annex/Magic.hs b/Annex/Magic.hs --- a/Annex/Magic.hs +++ b/Annex/Magic.hs @@ -2,7 +2,7 @@ - - Copyright 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/MakeRepo.hs b/Annex/MakeRepo.hs --- a/Annex/MakeRepo.hs +++ b/Annex/MakeRepo.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.MakeRepo where diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.MetaData ( diff --git a/Annex/MetaData/StandardFields.hs b/Annex/MetaData/StandardFields.hs --- a/Annex/MetaData/StandardFields.hs +++ b/Annex/MetaData/StandardFields.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} diff --git a/Annex/Multicast.hs b/Annex/Multicast.hs --- a/Annex/Multicast.hs +++ b/Annex/Multicast.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/Notification.hs b/Annex/Notification.hs --- a/Annex/Notification.hs +++ b/Annex/Notification.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} diff --git a/Annex/Path.hs b/Annex/Path.hs --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Path where diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Perms ( diff --git a/Annex/Queue.hs b/Annex/Queue.hs --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -2,7 +2,7 @@ - - Copyright 2011, 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Annex/RemoteTrackingBranch.hs b/Annex/RemoteTrackingBranch.hs new file mode 100644 --- /dev/null +++ b/Annex/RemoteTrackingBranch.hs @@ -0,0 +1,34 @@ +{- git-annex remote tracking branches + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.RemoteTrackingBranch + ( RemoteTrackingBranch + , mkRemoteTrackingBranch + , fromRemoteTrackingBranch + , setRemoteTrackingBranch + ) where + +import Annex.Common +import Git.Types +import qualified Git.Ref +import qualified Git.Branch +import qualified Types.Remote as Remote + +newtype RemoteTrackingBranch = RemoteTrackingBranch + { fromRemoteTrackingBranch :: Ref } + deriving (Show, Eq) + +{- Makes a remote tracking branch corresponding to a local branch. + - Note that the local branch does not need to exist yet. -} +mkRemoteTrackingBranch :: Remote -> Branch -> RemoteTrackingBranch +mkRemoteTrackingBranch remote ref = RemoteTrackingBranch $ + Git.Ref.underBase ("refs/remotes/" ++ Remote.name remote) ref + +{- Set remote tracking branch to point to a commit. -} +setRemoteTrackingBranch :: RemoteTrackingBranch -> Sha -> Annex () +setRemoteTrackingBranch tb commit = + inRepo $ Git.Branch.update' (fromRemoteTrackingBranch tb) commit diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.SpecialRemote where diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs --- a/Annex/TaggedPush.hs +++ b/Annex/TaggedPush.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.TaggedPush where diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -2,7 +2,7 @@ - - Copyright 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Tmp where diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP, BangPatterns #-} diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -8,7 +8,7 @@ - - Copyright 2010-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.UUID ( diff --git a/Annex/UpdateInstead.hs b/Annex/UpdateInstead.hs --- a/Annex/UpdateInstead.hs +++ b/Annex/UpdateInstead.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.UpdateInstead where diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -3,7 +3,7 @@ - - Copyright 2013-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Url ( diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.VariantFile where diff --git a/Annex/VectorClock.hs b/Annex/VectorClock.hs --- a/Annex/VectorClock.hs +++ b/Annex/VectorClock.hs @@ -5,7 +5,7 @@ - - Copyright 2017-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.VectorClock where diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.View where diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs --- a/Annex/View/ViewedFile.hs +++ b/Annex/View/ViewedFile.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs --- a/Annex/Wanted.hs +++ b/Annex/Wanted.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Wanted where diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.WorkTree where @@ -83,7 +83,7 @@ showSideAction "scanning for unlocked files" Database.Keys.runWriter $ liftIO . Database.Keys.SQL.dropAllAssociatedFiles - (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.Ref.headRef + (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive Git.Ref.headRef forM_ l $ \i -> when (isregfile i) $ maybe noop (add i) diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -2,7 +2,7 @@ - - Copyright 2017-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Annex.YoutubeDl ( diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-} diff --git a/Assistant/Alert/Utility.hs b/Assistant/Alert/Utility.hs --- a/Assistant/Alert/Utility.hs +++ b/Assistant/Alert/Utility.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Alert.Utility where diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs --- a/Assistant/BranchChange.hs +++ b/Assistant/BranchChange.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.BranchChange where diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Changes where diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs --- a/Assistant/Commits.hs +++ b/Assistant/Commits.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Commits where diff --git a/Assistant/Common.hs b/Assistant/Common.hs --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Common (module X) where diff --git a/Assistant/CredPairCache.hs b/Assistant/CredPairCache.hs --- a/Assistant/CredPairCache.hs +++ b/Assistant/CredPairCache.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} @@ -19,8 +19,8 @@ import Utility.TimeStamp import qualified Remote import qualified Types.Remote as Remote +import Config import Config.DynamicConfig -import Annex.Export import Control.Concurrent.STM import System.Posix.Types diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs --- a/Assistant/DeleteRemote.hs +++ b/Assistant/DeleteRemote.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Drop ( diff --git a/Assistant/Fsck.hs b/Assistant/Fsck.hs --- a/Assistant/Fsck.hs +++ b/Assistant/Fsck.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Fsck where diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs --- a/Assistant/Gpg.hs +++ b/Assistant/Gpg.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Gpg where diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs --- a/Assistant/Install/Menu.hs +++ b/Assistant/Install/Menu.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.MakeRemote where diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Pairing where diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Pairing.MakeRemote where diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -6,7 +6,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Pairing.Network where diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs --- a/Assistant/Pushes.hs +++ b/Assistant/Pushes.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Pushes where diff --git a/Assistant/RemoteControl.hs b/Assistant/RemoteControl.hs --- a/Assistant/RemoteControl.hs +++ b/Assistant/RemoteControl.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.RemoteControl ( diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/RepoProblem.hs b/Assistant/RepoProblem.hs --- a/Assistant/RepoProblem.hs +++ b/Assistant/RepoProblem.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.RepoProblem where diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs --- a/Assistant/ScanRemotes.hs +++ b/Assistant/ScanRemotes.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.ScanRemotes where diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Ssh where diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Sync where diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.ConfigMonitor where diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs --- a/Assistant/Threads/DaemonStatus.hs +++ b/Assistant/Threads/DaemonStatus.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.DaemonStatus where diff --git a/Assistant/Threads/Exporter.hs b/Assistant/Threads/Exporter.hs --- a/Assistant/Threads/Exporter.hs +++ b/Assistant/Threads/Exporter.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.Exporter where @@ -64,7 +64,7 @@ forM rs $ \r -> do Annex.changeState $ \st -> st { Annex.errcounter = 0 } start <- liftIO getCurrentTime - void $ Command.Sync.seekExportContent rs + void $ Command.Sync.seekExportContent Nothing rs =<< getCurrentBranch -- Look at command error counter to see if the export -- didn't work. diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.Merger where diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.PairListener where diff --git a/Assistant/Threads/ProblemFixer.hs b/Assistant/Threads/ProblemFixer.hs --- a/Assistant/Threads/ProblemFixer.hs +++ b/Assistant/Threads/ProblemFixer.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.ProblemFixer ( diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.Pusher where diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.RemoteControl where diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.TransferPoller where diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.TransferScanner where diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.TransferWatcher where diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Threads.Transferrer where diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Threads/Upgrader.hs b/Assistant/Threads/Upgrader.hs --- a/Assistant/Threads/Upgrader.hs +++ b/Assistant/Threads/Upgrader.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE DeriveDataTypeable, CPP #-} diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.TransferrerPool where diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs --- a/Assistant/Types/Alert.hs +++ b/Assistant/Types/Alert.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.Alert where diff --git a/Assistant/Types/BranchChange.hs b/Assistant/Types/BranchChange.hs --- a/Assistant/Types/BranchChange.hs +++ b/Assistant/Types/BranchChange.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.BranchChange where diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs --- a/Assistant/Types/Changes.hs +++ b/Assistant/Types/Changes.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Assistant/Types/Commits.hs b/Assistant/Types/Commits.hs --- a/Assistant/Types/Commits.hs +++ b/Assistant/Types/Commits.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.Commits where diff --git a/Assistant/Types/CredPairCache.hs b/Assistant/Types/CredPairCache.hs --- a/Assistant/Types/CredPairCache.hs +++ b/Assistant/Types/CredPairCache.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.CredPairCache where diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.DaemonStatus where diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs --- a/Assistant/Types/NamedThread.hs +++ b/Assistant/Types/NamedThread.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.NamedThread where diff --git a/Assistant/Types/Pushes.hs b/Assistant/Types/Pushes.hs --- a/Assistant/Types/Pushes.hs +++ b/Assistant/Types/Pushes.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.Pushes where diff --git a/Assistant/Types/RemoteControl.hs b/Assistant/Types/RemoteControl.hs --- a/Assistant/Types/RemoteControl.hs +++ b/Assistant/Types/RemoteControl.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.RemoteControl where diff --git a/Assistant/Types/RepoProblem.hs b/Assistant/Types/RepoProblem.hs --- a/Assistant/Types/RepoProblem.hs +++ b/Assistant/Types/RepoProblem.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.RepoProblem where diff --git a/Assistant/Types/ScanRemotes.hs b/Assistant/Types/ScanRemotes.hs --- a/Assistant/Types/ScanRemotes.hs +++ b/Assistant/Types/ScanRemotes.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.ScanRemotes where diff --git a/Assistant/Types/ThreadName.hs b/Assistant/Types/ThreadName.hs --- a/Assistant/Types/ThreadName.hs +++ b/Assistant/Types/ThreadName.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.ThreadName where diff --git a/Assistant/Types/ThreadedMonad.hs b/Assistant/Types/ThreadedMonad.hs --- a/Assistant/Types/ThreadedMonad.hs +++ b/Assistant/Types/ThreadedMonad.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.ThreadedMonad where diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs --- a/Assistant/Types/TransferQueue.hs +++ b/Assistant/Types/TransferQueue.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.TransferQueue where diff --git a/Assistant/Types/TransferSlots.hs b/Assistant/Types/TransferSlots.hs --- a/Assistant/Types/TransferSlots.hs +++ b/Assistant/Types/TransferSlots.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs --- a/Assistant/Types/TransferrerPool.hs +++ b/Assistant/Types/TransferrerPool.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Assistant.Types.TransferrerPool where diff --git a/Assistant/Types/UrlRenderer.hs b/Assistant/Types/UrlRenderer.hs --- a/Assistant/Types/UrlRenderer.hs +++ b/Assistant/Types/UrlRenderer.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Backend ( diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Backend/URL.hs b/Backend/URL.hs --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Backend.URL ( diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Backend.Utilities where diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Backend.WORM (backends) where diff --git a/Build/BundledPrograms.hs b/Build/BundledPrograms.hs --- a/Build/BundledPrograms.hs +++ b/Build/BundledPrograms.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -24,14 +24,7 @@ -} extraBundledPrograms :: [FilePath] extraBundledPrograms = catMaybes - -- The system gpg is probably better, because it may better - -- integrate with the system gpg-agent, etc. - -- On Windows, gpg is bundled with git for windows. -#ifndef mingw32_HOST_OS - [ BuildInfo.gpg -#else - [ -#endif + [ Nothing #ifndef darwin_HOST_OS #ifndef mingw32_HOST_OS -- OS X has ssh installed by default. diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -3,7 +3,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -29,12 +29,12 @@ systemwideInstall :: IO Bool #ifndef mingw32_HOST_OS -systemwideInstall = isroot <||> destdirset +systemwideInstall = isroot <||> (not <$> userdirset) where isroot = do uid <- fromIntegral <$> getRealUserID return $ uid == (0 :: Int) - destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR") + userdirset = isJust <$> catchMaybeIO (getEnv "USERDIR") #else systemwideInstall = return False #endif diff --git a/Build/Mans.hs b/Build/Mans.hs --- a/Build/Mans.hs +++ b/Build/Mans.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/BuildInfo.hs b/BuildInfo.hs --- a/BuildInfo.hs +++ b/BuildInfo.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,47 @@ +git-annex (7.20190322) upstream; urgency=medium + + * New feature allows importing from special remotes, using + git annex import branch:subdir --from remote + * Directory special remote supports being configured with importree=yes, + to allow git-annex import of files from the directory. This can be + combined with exporttree=yes and git-annex export used to send changes + back to the same directory. + * Remote tracking branches are updated when importing and exporting to + special remotes, in ways analagous to how git fetch and git push do. + * export: Deprecated the --tracking option. + Instead, users can configure remote..annex-tracking-branch + themselves. + * sync --content: When remote..annex-tracking-branch is configured, + import from special remotes. + * sync, assistant: --no-push and remote..annex-push prevent exporting + trees to special remotes. + * Fix storage of metadata values containing newlines. + (Reversion introduced in version 7.20190122.) + * Sped up git-annex export in repositories with lots of keys. + * S3: Support enabling bucket versioning when built with aws-0.21.1. + * stack.yaml: Build with aws-0.21.1 + * Fix cleanup of git-annex:export.log after git-annex forget --drop-dead. + * Makefile: Added install-home target which installs git-annex into + the HOME directory. + * addurl --file: Fix a bug that made youtube-dl be used unneccessarily + when adding an html url that does not contain any media. + * Add -- before %f in the smudge/clean filter configuration, + to support filenames starting with dashes. + (To update the config of existing repositories, you can + re-run git-annex init.) + * fsck: Detect situations where annex.thin has caused data loss + to the content of locked files. + * Removed bundled gpg from the Linux standalone build and OSX dmg, + because gpg now always wants to use gpg-agent, and shipping such a daemon + in those is not a good idea. + * import: Let --force overwrite symlinks, not only regular files. + * Android: Fix typo of name of armv7l in installation script. + Thanks, 4omecha. + * S3: Added protocol= initremote setting, to allow https to be used + on a non-standard port. + + -- Joey Hess Fri, 22 Mar 2019 13:56:51 -0400 + git-annex (7.20190219) upstream; urgency=medium * init: Fix bug when direct mode needs to be enabled on a crippled diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -3,21 +3,17 @@ Files: * Copyright: © 2010-2019 Joey Hess -License: GPL-3+ +License: AGPL-3+ Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/* Copyright: © 2012-2017 Joey Hess © 2014 Sören Brunk License: AGPL-3+ -Files: Annex/AdjustedBranch.hs Annex/AdjustedBranch/Name.hs Annex/CurrentBranch.hs Annex/Version.hs Benchmark.hs Logs/File.hs Logs/Line.hs Logs/Smudge.hs Remote/Git.hs Remote/Helper/Ssh.hs Remote/Adb.hs Remote/External.hs Remote/Extermal/Types.hs Types/AdjustedBranch.hs Types/RepoVersion.hs Upgrade/V6.hs -Copyright: © 2011-2019 Joey Hess -License: AGPL-3+ - Files: Remote/Ddar.hs Copyright: © 2011 Joey Hess © 2014 Robie Basak -License: GPL-3+ +License: AGPL-3+ Files: Utility/ThreadScheduler.hs Copyright: 2011 Bas van Dijk & Roel van Dijk @@ -43,7 +39,7 @@ Files: Annex/DirHashes.hs Copyright: 2001 Ian Lynagh 2010-2015 Joey Hess -License: GPL-3+ +License: AGPL-3+ Files: doc/tips/automatically_adding_metadata/pre-commit-annex Copyright: 2014 Joey Hess diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine ( diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.Batch where diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP, OverloadedStrings #-} diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.GitAnnexShell where diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.GitAnnexShell.Checks where diff --git a/CmdLine/GitAnnexShell/Fields.hs b/CmdLine/GitAnnexShell/Fields.hs --- a/CmdLine/GitAnnexShell/Fields.hs +++ b/CmdLine/GitAnnexShell/Fields.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.GitAnnexShell.Fields where diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.GitRemoteTorAnnex where diff --git a/CmdLine/GlobalSetter.hs b/CmdLine/GlobalSetter.hs --- a/CmdLine/GlobalSetter.hs +++ b/CmdLine/GlobalSetter.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.GlobalSetter where diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.Option where diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -6,7 +6,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.Seek where @@ -228,7 +228,7 @@ runbranchkeys bs = do keyaction <- mkkeyaction forM_ bs $ \b -> do - (l, cleanup) <- inRepo $ LsTree.lsTree b + (l, cleanup) <- inRepo $ LsTree.lsTree LsTree.LsTreeRecursive b forM_ l $ \i -> do let bfp = mkActionItem $ BranchFilePath b (LsTree.file i) maybe noop (\k -> keyaction (k, bfp)) diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module CmdLine.Usage where diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command ( diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Add where diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.AddUnused where diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.AddUrl where @@ -218,7 +218,7 @@ performWeb o url file urlinfo = ifAnnexed file addurl geturl where geturl = next $ isJust <$> addUrlFile (downloadOptions o) url urlinfo file - addurl = addUrlChecked o url file webUUID $ \k -> + addurl = addUrlChecked o url file webUUID $ \k -> ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url) ( return (True, True, setDownloader url YoutubeDownloader) , return (Url.urlExists urlinfo, Url.urlSize urlinfo == keySize k, url) @@ -277,7 +277,6 @@ liftIO $ createDirectoryIfMissing True (parentDir file) finishDownloadWith tmp webUUID url file tryyoutubedl tmp - | isJust (fileOption o) = dl file -- Ask youtube-dl what filename it will download -- first, and check if that is already an annexed file, -- to avoid unnecessary work in that case. @@ -285,6 +284,12 @@ Right dest -> ifAnnexed dest (alreadyannexed dest) (dl dest) + Left _ -> normalfinish tmp + -- Ask youtube-dl what filename it will download + -- fist, so it's only used when the file contains embedded + -- media. + | isJust (fileOption o) = youtubeDlFileNameHtmlOnly url >>= \case + Right _ -> dl file Left _ -> normalfinish tmp where dl dest = withTmpWorkDir mediakey $ \workdir -> do diff --git a/Command/Adjust.hs b/Command/Adjust.hs --- a/Command/Adjust.hs +++ b/Command/Adjust.hs @@ -2,7 +2,7 @@ - - Copyright 2016-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Adjust where diff --git a/Command/Assistant.hs b/Command/Assistant.hs --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Assistant where diff --git a/Command/Benchmark.hs b/Command/Benchmark.hs --- a/Command/Benchmark.hs +++ b/Command/Benchmark.hs @@ -2,7 +2,7 @@ - - Copyright 2016-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs --- a/Command/CalcKey.hs +++ b/Command/CalcKey.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.CalcKey where diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.CheckPresentKey where diff --git a/Command/Commit.hs b/Command/Commit.hs --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Commit where diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Config where diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.ConfigList where diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.ContentLocation where diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Copy where diff --git a/Command/Dead.hs b/Command/Dead.hs --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -2,7 +2,7 @@ - - Copyright 2011, 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Dead where diff --git a/Command/Describe.hs b/Command/Describe.hs --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Describe where diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.DiffDriver where diff --git a/Command/Direct.hs b/Command/Direct.hs --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Direct where diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Drop where diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -2,7 +2,7 @@ - - Copyright 2010,2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.DropKey where diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -2,7 +2,7 @@ - - Copyright 2010,2012,2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.DropUnused where diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.EnableRemote where diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.ExamineKey where diff --git a/Command/Expire.hs b/Command/Expire.hs --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Expire where diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -1,8 +1,8 @@ {- git-annex command - - - Copyright 2017 Joey Hess + - Copyright 2017-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TupleSections, BangPatterns #-} @@ -24,7 +24,7 @@ import Annex.Content import Annex.Transfer import Annex.CatFile -import Annex.LockFile +import Annex.RemoteTrackingBranch import Logs.Location import Logs.Export import Database.Export @@ -43,6 +43,7 @@ data ExportOptions = ExportOptions { exportTreeish :: Git.Ref + -- ^ can be a tree, a branch, a commit, or a tag , exportRemote :: DeferredParse Remote , exportTracking :: Bool } @@ -58,7 +59,7 @@ ) parsetracking = switch ( long "tracking" - <> help ("track changes to the " ++ paramTreeish) + <> help ("track changes to the " ++ paramTreeish ++ " (deprecated)") ) -- To handle renames which swap files, the exported file is first renamed @@ -72,20 +73,43 @@ r <- getParsed (exportRemote o) unlessM (isExportSupported r) $ giveup "That remote does not support exports." + + -- handle deprecated option when (exportTracking o) $ - setConfig (remoteConfig r "export-tracking") + setConfig (remoteConfig r "annex-tracking-branch") (fromRef $ exportTreeish o) - new <- fromMaybe (giveup "unknown tree") <$> - -- Dereference the tree pointed to by the branch, commit, - -- or tag. + + tree <- fromMaybe (giveup "unknown tree") <$> inRepo (Git.Ref.tree (exportTreeish o)) - withExclusiveLock (gitAnnexExportLock (uuid r)) $ do - db <- openDb (uuid r) - changeExport r db new - unlessM (Annex.getState Annex.fast) $ - void $ fillExport r db new - closeDb db + + mtbcommitsha <- getExportCommit r (exportTreeish o) + db <- openDb (uuid r) + writeLockDbWhile db $ do + changeExport r db tree + unlessM (Annex.getState Annex.fast) $ do + void $ fillExport r db tree mtbcommitsha + closeDb db + +-- | When the treeish is a branch like master or refs/heads/master +-- (but not refs/remotes/...), find the commit it points to +-- and the corresponding remote tracking branch. +-- +-- The treeish may also be a subdir within a branch, like master:subdir, +-- that results in this returning the same thing it does for the master +-- branch. +getExportCommit :: Remote -> Git.Ref -> Annex (Maybe (RemoteTrackingBranch, Sha)) +getExportCommit r treeish + | '/' `notElem` fromRef baseref = do + let tb = mkRemoteTrackingBranch r baseref + commitsha <- inRepo $ Git.Ref.sha $ Git.Ref.underBase refsheads baseref + return (fmap (tb, ) commitsha) + | otherwise = return Nothing + where + baseref = Ref $ takeWhile (/= ':') $ fromRef $ + Git.Ref.removeBase refsheads treeish + refsheads = "refs/heads" + -- | 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 -> ExportHandle -> Git.Ref -> CommandSeek @@ -189,26 +213,42 @@ | 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 -> ExportHandle -> Git.Ref -> Annex Bool -fillExport r db new = do - (l, cleanup) <- inRepo $ Git.LsTree.lsTree new - cvar <- liftIO $ newMVar False - commandActions $ map (startExport r db cvar) l +newtype FileUploaded = FileUploaded { fromFileUploaded :: Bool } + +newtype AllFilled = AllFilled { fromAllFilled :: Bool } + +-- | Upload all exported files that are not yet in the remote. +-- +-- Returns True when some files were uploaded (perhaps not all of them). +-- +-- Once all exported files have reached the remote, updates the +-- remote tracking branch. +fillExport :: Remote -> ExportHandle -> Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> Annex Bool +fillExport r db newtree mtbcommitsha = do + (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive newtree + cvar <- liftIO $ newMVar (FileUploaded False) + allfilledvar <- liftIO $ newMVar (AllFilled True) + commandActions $ map (startExport r db cvar allfilledvar) l void $ liftIO $ cleanup - liftIO $ takeMVar cvar -startExport :: Remote -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart -startExport r db cvar ti = do + case mtbcommitsha of + Nothing -> noop + Just (tb, commitsha) -> + whenM (liftIO $ fromAllFilled <$> takeMVar allfilledvar) $ + setRemoteTrackingBranch tb commitsha + + liftIO $ fromFileUploaded <$> takeMVar cvar + +startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart +startExport r db cvar allfilledvar ti = do ek <- exportKey (Git.LsTree.sha ti) stopUnless (notrecordedpresent ek) $ do showStart ("export " ++ name r) f ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc)) ( next $ next $ cleanupExport r db ek loc False , do - liftIO $ modifyMVar_ cvar (pure . const True) - next $ performExport r db ek af (Git.LsTree.sha ti) loc + liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True)) + next $ performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar ) where loc = mkExportLocation f @@ -220,10 +260,10 @@ -- will still list it, so also check location tracking. <*> (notElem (uuid r) <$> loggedLocations (asKey ek)) -performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform -performExport r db ek af contentsha loc = do +performExport :: Remote -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform +performExport r db ek af contentsha loc allfilledvar = do let storer = storeExport (exportActions r) - sent <- case ek of + sent <- tryNonAsync $ case ek of AnnexKey k -> ifM (inAnnex k) ( notifyTransfer Upload af $ -- Using noRetry here because interrupted @@ -244,9 +284,15 @@ liftIO $ L.hPut h b liftIO $ hClose h storer tmp sha1k loc nullMeterUpdate - if sent - then next $ cleanupExport r db ek loc True - else stop + let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False)) + case sent of + Right True -> next $ cleanupExport r db ek loc True + Right False -> do + failedsend + stop + Left err -> do + failedsend + throwM err cleanupExport :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> Bool -> CommandCleanup cleanupExport r db ek loc sent = do @@ -339,15 +385,16 @@ f' = getTopFilePath f performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform -performRename r db ek src dest = do - ifM (renameExport (exportActions r) (asKey ek) src dest) - ( next $ cleanupRename r db ek src dest - -- In case the special remote does not support renaming, - -- unexport the src instead. - , do +performRename r db ek src dest = + renameExport (exportActions r) (asKey ek) src dest >>= \case + Just True -> next $ cleanupRename r db ek src dest + Just False -> do warning "rename failed; deleting instead" - performUnexport r db [ek] src - ) + fallbackdelete + -- Remote does not support renaming, so don't warn about it. + Nothing -> fallbackdelete + where + fallbackdelete = performUnexport r db [ek] src cleanupRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup cleanupRename r db ek src dest = do diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Find where diff --git a/Command/FindRef.hs b/Command/FindRef.hs --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.FindRef where diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/Forget.hs b/Command/Forget.hs --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Forget where diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -1,8 +1,8 @@ {- git-annex command - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -227,7 +227,7 @@ verifyLocationLog key keystatus ai = do direct <- isDirect obj <- calcRepo $ gitAnnexLocation key - present <- if not direct && isKeyUnlocked keystatus + present <- if not direct && isKeyUnlockedThin keystatus then liftIO (doesFileExist obj) else inAnnex key u <- getUUID @@ -235,9 +235,10 @@ {- Since we're checking that a key's object file is present, throw - in a permission fixup here too. -} when (present && not direct) $ do - void $ tryIO $ if isKeyUnlocked keystatus - then thawContent obj - else freezeContent obj + void $ tryIO $ case keystatus of + KeyUnlockedThin -> thawContent obj + KeyLockedThin -> thawContent obj + _ -> freezeContent obj unlessM (isContentWritePermOk obj) $ warning $ "** Unable to set correct write mode for " ++ obj ++ " ; perhaps you don't own that file" whenM (liftIO $ doesDirectoryExist $ parentDir obj) $ @@ -326,13 +327,11 @@ forM_ fs $ \f -> unlessM (liftIO $ doesFileExist f) $ void $ Direct.removeAssociatedFile key f - goindirect = case keystatus of - KeyUnlocked -> do - f <- inRepo $ toTopFilePath file - afs <- Database.Keys.getAssociatedFiles key - unless (getTopFilePath f `elem` map getTopFilePath afs) $ - Database.Keys.addAssociatedFile key f - _ -> return () + goindirect = when (isKeyUnlockedThin keystatus) $ do + f <- inRepo $ toTopFilePath file + afs <- Database.Keys.getAssociatedFiles key + unless (getTopFilePath f `elem` map getTopFilePath afs) $ + Database.Keys.addAssociatedFile key f verifyWorkTree :: Key -> FilePath -> Annex Bool verifyWorkTree key file = do @@ -372,7 +371,7 @@ - Not checked when a file is unlocked, or in direct mode. -} checkKeySize :: Key -> KeyStatus -> ActionItem -> Annex Bool -checkKeySize _ KeyUnlocked _ = return True +checkKeySize _ KeyUnlockedThin _ = return True checkKeySize key _ ai = do file <- calcRepo $ gitAnnexLocation key ifM (liftIO $ doesFileExist file) @@ -450,7 +449,7 @@ where go False = do content <- calcRepo $ gitAnnexLocation key - ifM (pure (isKeyUnlocked keystatus) <&&> (not <$> isUnmodified key content)) + ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( nocheck , checkBackendOr badContent backend key content (mkActionItem afile) ) @@ -700,28 +699,42 @@ withFsckDb NonIncremental _ = noop withFsckDb (ScheduleIncremental _ _ i) a = withFsckDb i a -data KeyStatus = KeyLocked | KeyUnlocked | KeyMissing +data KeyStatus + = KeyMissing + | KeyPresent + | KeyUnlockedThin + -- ^ An annex.thin worktree file is hard linked to the object. + | KeyLockedThin + -- ^ The object has hard links, but the file being fscked + -- is not the one that hard links to it. + deriving (Show) -isKeyUnlocked :: KeyStatus -> Bool -isKeyUnlocked KeyUnlocked = True -isKeyUnlocked KeyLocked = False -isKeyUnlocked KeyMissing = False +isKeyUnlockedThin :: KeyStatus -> Bool +isKeyUnlockedThin KeyUnlockedThin = True +isKeyUnlockedThin KeyLockedThin = False +isKeyUnlockedThin KeyPresent = False +isKeyUnlockedThin KeyMissing = False getKeyStatus :: Key -> Annex KeyStatus getKeyStatus key = ifM isDirect - ( return KeyUnlocked + ( return KeyUnlockedThin , catchDefaultIO KeyMissing $ do - unlocked <- not . null <$> Database.Keys.getAssociatedFiles key - return $ if unlocked then KeyUnlocked else KeyLocked + afs <- not . null <$> Database.Keys.getAssociatedFiles key + obj <- calcRepo $ gitAnnexLocation key + multilink <- ((> 1) . linkCount <$> liftIO (getFileStatus obj)) + return $ if multilink && afs + then KeyUnlockedThin + else KeyPresent ) getKeyFileStatus :: Key -> FilePath -> Annex KeyStatus getKeyFileStatus key file = do s <- getKeyStatus key case s of - KeyLocked -> catchDefaultIO KeyLocked $ + KeyUnlockedThin -> catchDefaultIO KeyUnlockedThin $ ifM (isJust <$> isAnnexLink file) - ( return KeyLocked - , return KeyUnlocked + ( return KeyLockedThin + , return KeyUnlockedThin ) _ -> return s + diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.FuzzTest where diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.GCryptSetup where diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Get where diff --git a/Command/Group.hs b/Command/Group.hs --- a/Command/Group.hs +++ b/Command/Group.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Group where diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.GroupWanted where diff --git a/Command/Help.hs b/Command/Help.hs --- a/Command/Help.hs +++ b/Command/Help.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Help where diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -1,10 +1,12 @@ {- git-annex command - - - Copyright 2012-2017 Joey Hess + - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE ApplicativeDo #-} + module Command.Import where import Command @@ -12,6 +14,8 @@ import qualified Annex import qualified Command.Add import qualified Command.Reinject +import qualified Types.Remote as Remote +import qualified Git.Ref import Utility.CopyFile import Backend import Types.KeySource @@ -20,29 +24,52 @@ import Annex.FileMatcher import Annex.Ingest import Annex.InodeSentinal +import Annex.Import +import Annex.RemoteTrackingBranch import Utility.InodeCache import Logs.Location +import Git.FilePath +import Git.Types +import Git.Branch +import Types.Import cmd :: Command cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, fileMatchingOptions] $ command "import" SectionCommon - "move and add files from outside git working copy" - paramPaths (seek <$$> optParser) - -data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates | ReinjectDuplicates - deriving (Eq) + "import files from elsewhere into the repository" + (paramPaths ++ "|BRANCH[:SUBDIR]") + (seek <$$> optParser) -data ImportOptions = ImportOptions - { importFiles :: CmdParams - , duplicateMode :: DuplicateMode - } +data ImportOptions + = LocalImportOptions + { importFiles :: CmdParams + , duplicateMode :: DuplicateMode + } + | RemoteImportOptions + { importFromRemote :: DeferredParse Remote + , importToBranch :: Branch + , importToSubDir :: Maybe FilePath + } optParser :: CmdParamsDesc -> Parser ImportOptions -optParser desc = ImportOptions - <$> cmdParams desc - <*> (fromMaybe Default <$> optional duplicateModeParser) +optParser desc = do + ps <- cmdParams desc + mfromremote <- optional $ parseRemoteOption <$> parseFromOption + dupmode <- fromMaybe Default <$> optional duplicateModeParser + return $ case mfromremote of + Nothing -> LocalImportOptions ps dupmode + Just r -> case ps of + [bs] -> + let (branch, subdir) = separate (== ':') bs + in RemoteImportOptions r + (Ref branch) + (if null subdir then Nothing else Just subdir) + _ -> giveup "expected BRANCH[:SUBDIR]" +data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates | ReinjectDuplicates + deriving (Eq) + duplicateModeParser :: Parser DuplicateMode duplicateModeParser = flag' Duplicate @@ -67,17 +94,26 @@ ) seek :: ImportOptions -> CommandSeek -seek o = allowConcurrentOutput $ do +seek o@(LocalImportOptions {}) = allowConcurrentOutput $ do repopath <- liftIO . absPath =<< fromRepo Git.repoPath inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o) unless (null inrepops) $ do giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops largematcher <- largeFilesMatcher - (commandAction . start largematcher (duplicateMode o)) + (commandAction . startLocal largematcher (duplicateMode o)) `withPathContents` importFiles o +seek o@(RemoteImportOptions {}) = allowConcurrentOutput $ do + r <- getParsed (importFromRemote o) + unlessM (Remote.isImportSupported r) $ + giveup "That remote does not support imports." + subdir <- maybe + (pure Nothing) + (Just <$$> inRepo . toTopFilePath) + (importToSubDir o) + seekRemote r (importToBranch o) subdir -start :: GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart -start largematcher mode (srcfile, destfile) = +startLocal :: GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart +startLocal largematcher mode (srcfile, destfile) = ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) ( do showStart "import" destfile @@ -110,7 +146,12 @@ Nothing -> importfilechecked ld k Just s | isDirectory s -> notoverwriting "(is a directory)" - | isSymbolicLink s -> notoverwriting "(is a symlink)" + | isSymbolicLink s -> ifM (Annex.getState Annex.force) + ( do + liftIO $ nukeFile destfile + importfilechecked ld k + , notoverwriting "(is a symlink)" + ) | otherwise -> ifM (Annex.getState Annex.force) ( do liftIO $ nukeFile destfile @@ -209,3 +250,62 @@ (tocheck, preverified) <- verifiableCopies key [] verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck (const yes) no + +seekRemote :: Remote -> Branch -> Maybe TopFilePath -> CommandSeek +seekRemote remote branch msubdir = do + importtreeconfig <- case msubdir of + Nothing -> return ImportTree + Just subdir -> + let mk tree = pure $ ImportSubTree subdir tree + in fromtrackingbranch Git.Ref.tree >>= \case + Just tree -> mk tree + Nothing -> inRepo (Git.Ref.tree branch) >>= \case + 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 + + importable <- download importtreeconfig =<< listcontents + void $ includeCommandAction $ + commitRemote remote branch tb parentcommit importtreeconfig importcommitconfig importable + where + importmessage = "import from " ++ Remote.name remote + + tb = mkRemoteTrackingBranch remote branch + + 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 + +commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents Key -> CommandStart +commitRemote remote branch tb parentcommit importtreeconfig importcommitconfig importable = do + showStart' "update" (Just $ fromRef $ fromRemoteTrackingBranch tb) + next $ do + importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable + next $ updateremotetrackingbranch importcommit + + where + -- Update the tracking branch. Done even when there + -- is nothing new to import, to make sure it exists. + updateremotetrackingbranch importcommit = + case importcommit <|> parentcommit of + Just c -> do + setRemoteTrackingBranch tb c + return True + Nothing -> do + warning $ "Nothing to import and " ++ fromRef branch ++ " does not exist." + return False diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.InAnnex where diff --git a/Command/Indirect.hs b/Command/Indirect.hs --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Indirect where diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns, DeriveDataTypeable, CPP #-} @@ -597,7 +597,7 @@ getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo) getTreeStatInfo o r = do fast <- Annex.getState Annex.fast - (ls, cleanup) <- inRepo $ LsTree.lsTree r + (ls, cleanup) <- inRepo $ LsTree.lsTree LsTree.LsTreeRecursive r (presentdata, referenceddata, repodata) <- go fast ls initial ifM (liftIO cleanup) ( return $ Just $ diff --git a/Command/Init.hs b/Command/Init.hs --- a/Command/Init.hs +++ b/Command/Init.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Init where diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -2,7 +2,7 @@ - - Copyright 2011,2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.InitRemote where diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Inprogress where diff --git a/Command/List.hs b/Command/List.hs --- a/Command/List.hs +++ b/Command/List.hs @@ -3,7 +3,7 @@ - Copyright 2013 Joey Hess - Copyright 2013 Antoine Beaupré - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.List where diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -2,7 +2,7 @@ - - Copyright 2010,2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Lock where diff --git a/Command/LockContent.hs b/Command/LockContent.hs --- a/Command/LockContent.hs +++ b/Command/LockContent.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.LockContent where diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.LookupKey where diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Map where diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.MatchExpression where diff --git a/Command/Merge.hs b/Command/Merge.hs --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -2,7 +2,7 @@ - - Copyright 2011, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Merge where diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.MetaData where diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Migrate where @@ -70,7 +70,7 @@ go (Just (newkey, knowngoodcontent)) | knowngoodcontent = finish newkey | otherwise = stopUnless checkcontent $ finish newkey - checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked afile + checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyPresent afile finish newkey = ifM (Command.ReKey.linkKey file oldkey newkey) ( do _ <- copyMetaData oldkey newkey diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Mirror where diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Move where diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs --- a/Command/NotifyChanges.hs +++ b/Command/NotifyChanges.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.NotifyChanges where diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.NumCopies where diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.P2P where diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs --- a/Command/P2PStdIO.hs +++ b/Command/P2PStdIO.hs @@ -2,7 +2,7 @@ - - Copyright 2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.P2PStdIO where diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs --- a/Command/PostReceive.hs +++ b/Command/PostReceive.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.PostReceive where diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/Proxy.hs b/Command/Proxy.hs --- a/Command/Proxy.hs +++ b/Command/Proxy.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Proxy where diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.ReKey where diff --git a/Command/ReadPresentKey.hs b/Command/ReadPresentKey.hs --- a/Command/ReadPresentKey.hs +++ b/Command/ReadPresentKey.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.ReadPresentKey where diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.RecvKey where diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Command/Reinit.hs b/Command/Reinit.hs --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Reinit where diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Reinject where diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/Repair.hs b/Command/Repair.hs --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Repair where diff --git a/Command/Required.hs b/Command/Required.hs --- a/Command/Required.hs +++ b/Command/Required.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Required where diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.ResolveMerge where diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.RmUrl where diff --git a/Command/Schedule.hs b/Command/Schedule.hs --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Schedule where diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Semitrust where diff --git a/Command/SendKey.hs b/Command/SendKey.hs --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -2,7 +2,7 @@ - - Copyright 2010,2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.SendKey where diff --git a/Command/SetKey.hs b/Command/SetKey.hs --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.SetKey where diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.SetPresentKey where diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Smudge where diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Status where diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -1,11 +1,13 @@ {- git-annex command - - Copyright 2011 Joachim Breitner - - Copyright 2011-2017 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE FlexibleContexts #-} + module Command.Sync ( cmd, CurrBranch, @@ -37,6 +39,7 @@ import qualified Git.Types as Git import qualified Git.Ref import qualified Git +import Git.FilePath import qualified Remote.Git import Config import Config.GitConfig @@ -47,6 +50,7 @@ import Command.Get (getKey') import qualified Command.Move import qualified Command.Export +import qualified Command.Import import Annex.Drop import Annex.UUID import Logs.UUID @@ -57,7 +61,6 @@ import Annex.BloomFilter import Annex.UpdateInstead import Annex.Export -import Annex.LockFile import Annex.TaggedPush import Annex.CurrentBranch import qualified Database.Export as Export @@ -168,7 +171,8 @@ let gitremotes = filter Remote.gitSyncableRemote remotes dataremotes <- filter (\r -> Remote.uuid r /= NoUUID) <$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes - let exportremotes = filter (exportTree . Remote.config) dataremotes + let (exportremotes, keyvalueremotes) = partition (exportTree . Remote.config) dataremotes + let importremotes = filter (importTree . Remote.config) dataremotes if cleanupOption o then do @@ -185,13 +189,17 @@ , map (withbranch . pullRemote o mergeConfig) gitremotes , [ mergeAnnex ] ] - + whenM shouldsynccontent $ do - -- Send content to any exports first, in - -- case that lets content be dropped from - -- other repositories. - exportedcontent <- withbranch $ seekExportContent exportremotes - syncedcontent <- withbranch $ seekSyncContent o dataremotes + mapM_ (withbranch . importRemote o mergeConfig) importremotes + + -- Send content to any exports before other + -- repositories, in case that lets content + -- be dropped from other repositories. + exportedcontent <- withbranch $ + seekExportContent (Just o) exportremotes + syncedcontent <- withbranch $ + seekSyncContent o keyvalueremotes -- Transferring content can take a while, -- and other changes can be pushed to the -- git-annex branch on the remotes in the @@ -221,10 +229,11 @@ mergeConfig = [ Git.Merge.MergeNonInteractive -- In several situations, unrelated histories should be merged - -- together. This includes pairing in the assistant, and merging - -- from a remote into a newly created direct mode repo. + -- together. This includes pairing in the assistant, merging + -- from a remote into a newly created direct mode repo, + -- and an initial merge from an import from a special remote. -- (Once direct mode is removed, this could be changed, so only - -- the assistant uses it.) + -- the assistant and import from special remotes use it.) , Git.Merge.MergeUnrelatedHistories ] @@ -400,6 +409,23 @@ [Param "fetch", Param $ Remote.name remote] wantpull = remoteAnnexPull (Remote.gitconfig remote) +importRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek +importRemote o mergeconfig remote currbranch + | not (pullOption o) || not wantpull = noop + | otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of + Nothing -> noop + Just tb -> do + let (b, s) = separate (== ':') (Git.fromRef tb) + let branch = Git.Ref b + let subdir = if null s + then Nothing + else Just (asTopFilePath s) + Command.Import.seekRemote remote branch subdir + void $ mergeRemote remote currbranch mergeconfig + (resolveMergeOverride o) + where + wantpull = remoteAnnexPull (Remote.gitconfig remote) + {- The remote probably has both a master and a synced/master branch. - Which to merge from? Well, the master has whatever latest changes - were committed (or pushed changes, if this is a bare remote), @@ -680,32 +706,39 @@ put dest = includeCommandAction $ Command.Move.toStart' dest Command.Move.RemoveNever 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 +{- When a remote has an annex-tracking-branch configuration, change the export + - to contain 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] -> CurrBranch -> Annex Bool -seekExportContent rs (currbranch, _) = or <$> forM rs go +seekExportContent :: Maybe SyncOptions -> [Remote] -> CurrBranch -> Annex Bool +seekExportContent o rs (currbranch, _) = or <$> forM rs go where - go r = withExclusiveLock (gitAnnexExportLock (Remote.uuid r)) $ do - db <- Export.openDb (Remote.uuid r) - exported <- case remoteAnnexExportTracking (Remote.gitconfig r) of + go r + | not (maybe True pullOption o) = return False + | not (remoteAnnexPush (Remote.gitconfig r)) = return False + | otherwise = bracket + (Export.openDb (Remote.uuid r)) + Export.closeDb + (\db -> Export.writeLockDbWhile db (go' r db)) + go' r db = do + (exported, mtbcommitsha) <- case remoteAnnexTrackingBranch (Remote.gitconfig r) of Nothing -> nontracking r Just b -> do - mcur <- inRepo $ Git.Ref.tree b - case mcur of - Nothing -> nontracking r - Just cur -> do - Command.Export.changeExport r db cur - return [mkExported cur []] - Export.closeDb db `after` fillexport r db (exportedTreeishes exported) + mtree <- inRepo $ Git.Ref.tree b + mtbcommitsha <- Command.Export.getExportCommit r b + case (mtree, mtbcommitsha) of + (Just tree, Just _) -> do + Command.Export.changeExport r db tree + return ([mkExported tree []], mtbcommitsha) + _ -> nontracking r + fillexport r db (exportedTreeishes exported) mtbcommitsha nontracking r = do exported <- getExport (Remote.uuid r) maybe noop (warnnontracking r exported) currbranch - return exported + return (exported, Nothing) warnnontracking r exported currb = inRepo (Git.Ref.tree currb) >>= \case Just currt | not (any (== currt) (exportedTreeishes exported)) -> @@ -713,15 +746,15 @@ [ "Not updating export to " ++ Remote.name r , "to reflect changes to the tree, because export" , "tracking is not enabled. " - , "(Use git-annex export's --tracking option" - , "to enable it.)" + , "(Set " ++ gitconfig ++ " to enable it.)" ] _ -> noop - + where + gitconfig = show (remoteConfig r "tracking-branch") - fillexport _ _ [] = return False - fillexport r db (t:[]) = Command.Export.fillExport r db t - fillexport r _ _ = do + fillexport _ _ [] _ = return False + fillexport r db (t:[]) mtbcommitsha = Command.Export.fillExport r db t mtbcommitsha + fillexport r _ _ _ = do warnExportConflict r return False diff --git a/Command/Test.hs b/Command/Test.hs --- a/Command/Test.hs +++ b/Command/Test.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Test where diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.TestRemote where @@ -24,7 +24,7 @@ import Utility.CopyFile import Types.Messages import Types.Export -import Remote.Helper.Export +import Remote.Helper.ExportImport import Remote.Helper.Chunked import Git.Types diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.TransferInfo where diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.TransferKey where diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} diff --git a/Command/Trust.hs b/Command/Trust.hs --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Trust where diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Unannex where diff --git a/Command/Undo.hs b/Command/Undo.hs --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Undo where diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Ungroup where diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Uninit where diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Unlock where diff --git a/Command/Untrust.hs b/Command/Untrust.hs --- a/Command/Untrust.hs +++ b/Command/Untrust.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Untrust where diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Upgrade where diff --git a/Command/VAdd.hs b/Command/VAdd.hs --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.VAdd where diff --git a/Command/VCycle.hs b/Command/VCycle.hs --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.VCycle where diff --git a/Command/VFilter.hs b/Command/VFilter.hs --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.VFilter where diff --git a/Command/VPop.hs b/Command/VPop.hs --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.VPop where diff --git a/Command/Version.hs b/Command/Version.hs --- a/Command/Version.hs +++ b/Command/Version.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Version where diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE RankNTypes #-} diff --git a/Command/View.hs b/Command/View.hs --- a/Command/View.hs +++ b/Command/View.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.View where diff --git a/Command/Wanted.hs b/Command/Wanted.hs --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Wanted where diff --git a/Command/Watch.hs b/Command/Watch.hs --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Watch where diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Command.Whereis where diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} @@ -93,6 +93,12 @@ setRemoteBare :: Git.Repo -> Bool -> Annex () setRemoteBare r b = setConfig (remoteConfig r "bare") (Git.Config.boolConfig b) + +exportTree :: Remote.RemoteConfig -> Bool +exportTree c = fromMaybe False $ yesNo =<< M.lookup "exporttree" c + +importTree :: Remote.RemoteConfig -> Bool +importTree c = fromMaybe False $ yesNo =<< M.lookup "importtree" c isBareRepo :: Annex Bool isBareRepo = fromRepo Git.repoIsLocalBare diff --git a/Config/Cost.hs b/Config/Cost.hs --- a/Config/Cost.hs +++ b/Config/Cost.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Config.Cost where diff --git a/Config/DynamicConfig.hs b/Config/DynamicConfig.hs --- a/Config/DynamicConfig.hs +++ b/Config/DynamicConfig.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Config.DynamicConfig where diff --git a/Config/Files.hs b/Config/Files.hs --- a/Config/Files.hs +++ b/Config/Files.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -56,7 +56,7 @@ modifyAutoStartFile $ filter (not . equalFilePath path') -{- The path to git-annex is written here; which is useful when cabal +{- The path to git-annex is written here; which is useful when something - has installed it to some awful non-PATH location. -} programFile :: IO FilePath programFile = userConfigFile "program" diff --git a/Config/GitConfig.hs b/Config/GitConfig.hs --- a/Config/GitConfig.hs +++ b/Config/GitConfig.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Config.GitConfig where diff --git a/Config/Smudge.hs b/Config/Smudge.hs --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Config.Smudge where @@ -24,8 +24,8 @@ -- Avoid that problem by running git status now. inRepo $ Git.Command.runQuiet [Param "status", Param "--porcelain"] - setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge %f" - setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean %f" + setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge -- %f" + setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean -- %f" lf <- Annex.fromRepo Git.attributesLocal gf <- Annex.fromRepo Git.attributes lfs <- readattr lf diff --git a/Creds.hs b/Creds.hs --- a/Creds.hs +++ b/Creds.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Creds ( diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -5,7 +5,7 @@ - - Copyright 2011-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE FlexibleInstances #-} diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs new file mode 100644 --- /dev/null +++ b/Database/ContentIdentifier.hs @@ -0,0 +1,154 @@ +{- Sqlite database of ContentIdentifiers imported from special remotes. + - + - Copyright 2019 Joey Hess + -: + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} + +module Database.ContentIdentifier ( + ContentIdentifierHandle, + openDb, + closeDb, + flushDbQueue, + recordContentIdentifier, + getContentIdentifiers, + getContentIdentifierKeys, + recordAnnexBranchTree, + getAnnexBranchTree, + needsUpdateFromLog, + updateFromLog, + ContentIdentifiersId, + AnnexBranchId, +) where + +import Database.Types +import qualified Database.Queue as H +import Database.Init +import Annex.Locations +import Annex.Common hiding (delete) +import qualified Annex.Branch +import Types.Import +import Git.Types +import Git.Sha +import Git.FilePath +import qualified Git.Ref +import qualified Git.DiffTree as DiffTree +import Logs +import qualified Logs.ContentIdentifier as Log + +import Database.Persist.Sql hiding (Key) +import Database.Persist.TH + +data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue + +share [mkPersist sqlSettings, mkMigrate "migrateContentIdentifier"] [persistLowerCase| +ContentIdentifiers + 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 + tree SRef + UniqueTree tree +|] + +{- Opens the database, creating it if it doesn't exist yet. + - + - Only a single process should write to the database at a time, so guard + - any writes with the gitAnnexContentIdentifierLock. + -} +openDb :: Annex ContentIdentifierHandle +openDb = do + dbdir <- fromRepo gitAnnexContentIdentifierDbDir + let db = dbdir "db" + unlessM (liftIO $ doesFileExist db) $ do + initDb db $ void $ + runMigrationSilent migrateContentIdentifier + h <- liftIO $ H.openDbQueue H.SingleWriter db "content_identifiers" + return $ ContentIdentifierHandle h + +closeDb :: ContentIdentifierHandle -> Annex () +closeDb (ContentIdentifierHandle h) = liftIO $ H.closeDbQueue h + +queueDb :: ContentIdentifierHandle -> SqlPersistM () -> IO () +queueDb (ContentIdentifierHandle h) = H.queueDb h checkcommit + where + -- commit queue after 1000 changes + checkcommit sz _lastcommittime + | sz > 1000 = return True + | otherwise = return False + +flushDbQueue :: ContentIdentifierHandle -> IO () +flushDbQueue (ContentIdentifierHandle h) = H.flushDbQueue h + +-- 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) + +getContentIdentifiers :: ContentIdentifierHandle -> UUID -> Key -> IO [ContentIdentifier] +getContentIdentifiers (ContentIdentifierHandle h) u k = H.queryDbQueue h $ do + l <- selectList + [ ContentIdentifiersKey ==. toIKey k + , ContentIdentifiersRemote ==. u + ] [] + return $ map (contentIdentifiersCid . entityVal) l + +getContentIdentifierKeys :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> IO [Key] +getContentIdentifierKeys (ContentIdentifierHandle h) u cid = + H.queryDbQueue h $ do + l <- selectList + [ ContentIdentifiersCid ==. cid + , ContentIdentifiersRemote ==. u + ] [] + return $ map (fromIKey . contentIdentifiersKey . entityVal) l + +recordAnnexBranchTree :: ContentIdentifierHandle -> Sha -> IO () +recordAnnexBranchTree h s = queueDb h $ do + deleteWhere ([] :: [Filter AnnexBranch]) + void $ insertUnique $ AnnexBranch $ toSRef s + +getAnnexBranchTree :: ContentIdentifierHandle -> IO Sha +getAnnexBranchTree (ContentIdentifierHandle h) = H.queryDbQueue h $ do + l <- selectList ([] :: [Filter AnnexBranch]) [] + case l of + (s:[]) -> return $ fromSRef $ annexBranchTree $ entityVal s + _ -> return emptyTree + +{- Check if the git-annex branch has been updated and the database needs + - to be updated with any new content identifiers in it. -} +needsUpdateFromLog :: ContentIdentifierHandle -> Annex (Maybe (Sha, Sha)) +needsUpdateFromLog db = do + oldtree <- liftIO $ getAnnexBranchTree db + inRepo (Git.Ref.tree Annex.Branch.fullname) >>= \case + Just currtree | currtree /= oldtree -> + return $ Just (oldtree, currtree) + _ -> return Nothing + +{- The database should be locked for write when calling this. -} +updateFromLog :: ContentIdentifierHandle -> (Sha, Sha) -> Annex () +updateFromLog db (oldtree, currtree) = do + (l, cleanup) <- inRepo $ + DiffTree.diffTreeRecursive oldtree currtree + mapM_ go l + void $ liftIO $ cleanup + liftIO $ do + recordAnnexBranchTree db currtree + flushDbQueue db + where + go ti = case extLogFileKey remoteContentIdentifierExt (getTopFilePath (DiffTree.file ti)) of + Nothing -> return () + Just k -> do + l <- Log.getContentIdentifiers k + liftIO $ forM_ l $ \(u, cids) -> + forM_ cids $ \cid -> + recordContentIdentifier db u cid k diff --git a/Database/Export.hs b/Database/Export.hs --- a/Database/Export.hs +++ b/Database/Export.hs @@ -1,8 +1,8 @@ {- Sqlite database used for exports to special remotes. - - - Copyright 2017 Joey Hess + - Copyright 2017-2019 Joey Hess -: - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} @@ -15,6 +15,7 @@ ExportHandle, openDb, closeDb, + writeLockDbWhile, flushDbQueue, addExportedLocation, removeExportedLocation, @@ -23,16 +24,20 @@ getExportTreeCurrent, recordExportTreeCurrent, getExportTree, + getExportTreeKey, addExportTree, removeExportTree, updateExportTree, updateExportTree', updateExportTreeFromLog, + updateExportDb, ExportedId, ExportedDirectoryId, ExportTreeId, ExportTreeCurrentId, ExportUpdateResult(..), + ExportDiffUpdater, + runExportDiffUpdater, ) where import Database.Types @@ -44,6 +49,7 @@ import Annex.Export import qualified Logs.Export as Log import Annex.LockFile +import Annex.LockPool import Git.Types import Git.Sha import Git.FilePath @@ -167,6 +173,20 @@ where ik = toIKey k +{- Get keys that might be currently exported to a location. + - + - Note that the database does not currently have an index to make this + - fast. + - + - Note that this does not see recently queued changes. + -} +getExportTreeKey :: ExportHandle -> ExportLocation -> IO [Key] +getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do + map (fromIKey . exportTreeKey . entityVal) + <$> selectList [ExportTreeFile ==. ef] [] + where + ef = toSFilePath (fromExportLocation el) + addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $ void $ insertUnique $ ExportTree ik ef @@ -181,48 +201,131 @@ 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 +-- An action that is passed the old and new values that were exported, +-- and updates state. +type ExportDiffUpdater + = ExportHandle + -> Maybe ExportKey + -- ^ old exported key + -> Maybe ExportKey + -- ^ new exported key + -> Git.DiffTree.DiffTreeItem + -> Annex () + +mkExportDiffUpdater + :: (ExportHandle -> Key -> ExportLocation -> IO ()) + -> (ExportHandle -> Key -> ExportLocation -> IO ()) + -> ExportDiffUpdater +mkExportDiffUpdater removeold addnew h srcek dstek i = do + case srcek of + Nothing -> return () + Just k -> liftIO $ removeold h (asKey k) loc + case dstek of + Nothing -> return () + Just k -> liftIO $ addnew h (asKey k) loc + where + loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i + +runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex () +runExportDiffUpdater updater 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 + updater 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 +{- Diff from the old to the new tree and update the ExportTree table. -} +updateExportTree :: ExportHandle -> Sha -> Sha -> Annex () +updateExportTree = runExportDiffUpdater updateExportTree' + +updateExportTree' :: ExportDiffUpdater +updateExportTree' = mkExportDiffUpdater removeExportTree addExportTree + +{- Diff from the old to the new tree and update all tables in the export + - database. Should only be used when all the files in the new tree have + - been verified to already be present in the export remote. -} +updateExportDb :: ExportHandle -> Sha -> Sha -> Annex () +updateExportDb = runExportDiffUpdater $ mkExportDiffUpdater removeold addnew where - loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i + removeold h k loc = liftIO $ do + removeExportTree h k loc + removeExportedLocation h k loc + addnew h k loc = liftIO $ do + addExportTree h k loc + addExportedLocation h k loc +{- Runs an action with the database locked for write. Waits for any other + - writers to finish first. The queue is flushed at the end. + - + - This first updates the ExportTree table with any new information + - from the git-annex branch export log. + -} +writeLockDbWhile :: ExportHandle -> Annex a -> Annex a +writeLockDbWhile db@(ExportHandle _ u) a = do + updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u) + withExclusiveLock (gitAnnexExportLock u) $ do + bracket_ (setup updatelck) cleanup a + where + setup updatelck = do + void $ updateExportTreeFromLog' db + -- flush the update so it's available immediately to + -- anything waiting on the updatelck + liftIO $ flushDbQueue db + liftIO $ dropLock updatelck + cleanup = liftIO $ flushDbQueue db + data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict deriving (Eq) +{- Updates the ExportTree table with information from the + - git-annex branch export log. + - + - This can safely be called whether the database is locked for write or + - not. Either way, it will block until the update is complete. + -} updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult -updateExportTreeFromLog db@(ExportHandle _ u) = - withExclusiveLock (gitAnnexExportLock u) $ do - old <- liftIO $ fromMaybe emptyTree - <$> getExportTreeCurrent db - l <- Log.getExport u - case Log.exportedTreeishes l of - [] -> return ExportUpdateSuccess - (new:[]) - | new /= old -> do - updateExportTree db old new - liftIO $ recordExportTreeCurrent db new - liftIO $ flushDbQueue db - return ExportUpdateSuccess - | new == old -> return ExportUpdateSuccess - _ts -> return ExportUpdateConflict +updateExportTreeFromLog db@(ExportHandle _ u) = + -- If another process or thread is performing the update, + -- this will block until it's done. + withExclusiveLock (gitAnnexExportUpdateLock u) $ do + -- If the database is locked by something else, + -- this will not run the update. But, in that case, + -- writeLockDbWhile is running, and has already + -- completed the update, so we don't need to do anything. + mr <- tryExclusiveLock (gitAnnexExportLock u) $ + updateExportTreeFromLog' db + case mr of + Just r -> return r + Nothing -> do + old <- liftIO $ fromMaybe emptyTree + <$> getExportTreeCurrent db + l <- Log.getExport u + return $ case Log.exportedTreeishes l of + [] -> ExportUpdateSuccess + (new:[]) + | new /= old -> ExportUpdateSuccess + | new == old -> ExportUpdateSuccess + _ts -> ExportUpdateConflict + +{- The database should be locked when calling this. -} +updateExportTreeFromLog' :: ExportHandle -> Annex ExportUpdateResult +updateExportTreeFromLog' db@(ExportHandle _ u) = do + old <- liftIO $ fromMaybe emptyTree + <$> getExportTreeCurrent db + l <- Log.getExport u + case Log.exportedTreeishes l of + [] -> return ExportUpdateSuccess + (new:[]) + | new /= old -> do + updateExportTree db old new + liftIO $ recordExportTreeCurrent db new + liftIO $ flushDbQueue db + return ExportUpdateSuccess + | new == old -> return ExportUpdateSuccess + _ts -> return ExportUpdateConflict diff --git a/Database/Fsck.hs b/Database/Fsck.hs --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess -: - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} diff --git a/Database/Handle.hs b/Database/Handle.hs --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Database.Handle ( diff --git a/Database/Init.hs b/Database/Init.hs --- a/Database/Init.hs +++ b/Database/Init.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/Database/Keys/Handle.hs b/Database/Keys/Handle.hs --- a/Database/Keys/Handle.hs +++ b/Database/Keys/Handle.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess -: - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Database.Keys.Handle ( diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} diff --git a/Database/Queue.hs b/Database/Queue.hs --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Database/Types.hs b/Database/Types.hs --- a/Database/Types.hs +++ b/Database/Types.hs @@ -1,22 +1,29 @@ {- types for SQL databases - - - Copyright 2015-2017 Joey Hess + - Copyright 2015-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Types where import Database.Persist.TH +import Database.Persist.Class hiding (Key) +import Database.Persist.Sql hiding (Key) import Data.Maybe import Data.Char +import qualified Data.ByteString as S +import qualified Data.Text as T import Utility.PartialPrelude import Key import Utility.InodeCache import Git.Types (Ref(..)) +import Types.UUID +import Types.Import -- A serialized Key newtype SKey = SKey String @@ -112,3 +119,26 @@ fromSRef :: SRef -> Ref fromSRef (SRef r) = r + +instance PersistField UUID where + toPersistValue u = toPersistValue b + where + b :: S.ByteString + b = fromUUID u + fromPersistValue v = toUUID <$> go + where + go :: Either T.Text S.ByteString + go = fromPersistValue v + +instance PersistFieldSql UUID where + sqlType _ = SqlBlob + +instance PersistField ContentIdentifier where + toPersistValue (ContentIdentifier b) = toPersistValue b + fromPersistValue v = ContentIdentifier <$> go + where + go :: Either T.Text S.ByteString + go = fromPersistValue v + +instance PersistFieldSql ContentIdentifier where + sqlType _ = SqlBlob diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -5,7 +5,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs --- a/Git/AutoCorrect.hs +++ b/Git/AutoCorrect.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.AutoCorrect where diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.BuildVersion where diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CatFile ( diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CheckAttr where diff --git a/Git/CheckIgnore.hs b/Git/CheckIgnore.hs --- a/Git/CheckIgnore.hs +++ b/Git/CheckIgnore.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CheckIgnore ( diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/Command/Batch.hs b/Git/Command/Batch.hs --- a/Git/Command/Batch.hs +++ b/Git/Command/Batch.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Command.Batch where diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Config where diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs --- a/Git/ConfigTypes.hs +++ b/Git/ConfigTypes.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.ConfigTypes where diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CurrentRepo where diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.DiffTree ( diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.DiffTreeItem ( diff --git a/Git/Env.hs b/Git/Env.hs --- a/Git/Env.hs +++ b/Git/Env.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Env where diff --git a/Git/FileMode.hs b/Git/FileMode.hs --- a/Git/FileMode.hs +++ b/Git/FileMode.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -7,7 +7,7 @@ - - Copyright 2012-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/Filename.hs b/Git/Filename.hs --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -3,7 +3,7 @@ - - Copyright 2010, 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Filename where diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns, CPP #-} diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -4,7 +4,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.GCrypt where diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/Index.hs b/Git/Index.hs --- a/Git/Index.hs +++ b/Git/Index.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Index where diff --git a/Git/LockFile.hs b/Git/LockFile.hs --- a/Git/LockFile.hs +++ b/Git/LockFile.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.LsFiles ( diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,14 +1,15 @@ {- git ls-tree interface - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} module Git.LsTree ( TreeItem(..), + LsTreeMode(..), lsTree, lsTree', lsTreeParams, @@ -34,26 +35,30 @@ , file :: TopFilePath } deriving Show -{- Lists the complete contents of a tree, recursing into sub-trees, - - with lazy output. -} -lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool) +data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive + +{- Lists the contents of a tree, with lazy output. -} +lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree = lsTree' [] -lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool) -lsTree' ps t repo = do - (l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo +lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree' ps lsmode t repo = do + (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo return (map parseLsTree l, cleanup) -lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] -lsTreeParams r ps = +lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] +lsTreeParams lsmode r ps = [ Param "ls-tree" , Param "--full-tree" , Param "-z" - , Param "-r" - ] ++ ps ++ + ] ++ recursiveparams ++ ps ++ [ Param "--" , File $ fromRef r ] + where + recursiveparams = case lsmode of + LsTreeRecursive -> [ Param "-r" ] + LsTreeNonRecursive -> [] {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] diff --git a/Git/Merge.hs b/Git/Merge.hs --- a/Git/Merge.hs +++ b/Git/Merge.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Merge ( @@ -10,6 +10,7 @@ CommitMode(..), merge, merge', + mergeUnrelatedHistoriesParam, stageMerge, ) where @@ -44,14 +45,20 @@ merge'' :: [CommandParam] -> [MergeConfig] -> Repo -> IO Bool merge'' ps mergeconfig r - | MergeUnrelatedHistories `elem` mergeconfig = - ifM (Git.Version.older "2.9.0") - ( go ps - , go (ps ++ [Param "--allow-unrelated-histories"]) - ) + | MergeUnrelatedHistories `elem` mergeconfig = do + up <- mergeUnrelatedHistoriesParam + go (ps ++ maybeToList up) | otherwise = go ps where go ps' = runBool ps' r + +{- Git used to default to merging unrelated histories; newer versions need + - an option. -} +mergeUnrelatedHistoriesParam :: IO (Maybe CommandParam) +mergeUnrelatedHistoriesParam = ifM (Git.Version.older "2.9.0") + ( return Nothing + , return (Just (Param "--allow-unrelated-histories")) + ) {- Stage the merge into the index, but do not commit it.-} stageMerge :: Ref -> [MergeConfig] -> Repo -> IO Bool diff --git a/Git/Objects.hs b/Git/Objects.hs --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Objects where diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP, BangPatterns #-} diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,8 +1,8 @@ {- git ref stuff - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Ref where @@ -33,11 +33,18 @@ - Converts such a fully qualified ref into a base ref - (eg: master or origin/master). -} base :: Ref -> Ref -base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef +base = removeBase "refs/heads/" . removeBase "refs/remotes/" + +{- Removes a directory such as "refs/heads/master" from a + - fully qualified ref. Any ref not starting with it is left as-is. -} +removeBase :: String -> Ref -> Ref +removeBase dir (Ref r) + | prefix `isPrefixOf` r = Ref (drop (length prefix) r) + | otherwise = Ref r where - remove prefix s - | prefix `isPrefixOf` s = drop (length prefix) s - | otherwise = s + prefix = case end dir of + ['/'] -> dir + _ -> dir ++ "/" {- Given a directory such as "refs/remotes/origin", and a ref such as - refs/heads/master, yields a version of that ref under the directory, @@ -88,9 +95,11 @@ sha :: Branch -> Repo -> IO (Maybe Sha) sha branch repo = process <$> showref repo where - showref = pipeReadStrict [Param "show-ref", - Param "--hash", -- get the hash - Param $ fromRef branch] + showref = pipeReadStrict + [ Param "show-ref" + , Param "--hash" -- get the hash + , Param $ fromRef branch + ] process [] = Nothing process s = Just $ Ref $ firstLine s diff --git a/Git/RefLog.hs b/Git/RefLog.hs --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.RefLog where diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/Remote/Remove.hs b/Git/Remote/Remove.hs --- a/Git/Remote/Remove.hs +++ b/Git/Remote/Remove.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Repair ( @@ -341,7 +341,7 @@ verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do - (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r + (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r let objshas = map (LsTree.sha . LsTree.parseLsTree) ls if any (`S.member` missing) objshas then do diff --git a/Git/Sha.hs b/Git/Sha.hs --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Sha where diff --git a/Git/Ssh.hs b/Git/Ssh.hs --- a/Git/Ssh.hs +++ b/Git/Ssh.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Ssh (module Git.Ssh, module Utility.SshHost) where diff --git a/Git/Status.hs b/Git/Status.hs --- a/Git/Status.hs +++ b/Git/Status.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Status where diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -1,8 +1,8 @@ {- git trees - - - Copyright 2016 Joey Hess + - Copyright 2016-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} @@ -12,8 +12,13 @@ TreeContent(..), getTree, recordTree, + recordTree', TreeItem(..), + treeItemsToTree, adjustTree, + graftTree, + graftTree', + withMkTreeHandle, treeMode, ) where @@ -47,15 +52,15 @@ deriving (Show, Eq, Ord) {- Gets the Tree for a Ref. -} -getTree :: Ref -> Repo -> IO Tree -getTree r repo = do - (l, cleanup) <- lsTreeWithObjects r repo +getTree :: LsTree.LsTreeMode -> Ref -> Repo -> IO Tree +getTree lstreemode r repo = do + (l, cleanup) <- lsTreeWithObjects lstreemode r repo let !t = either (\e -> error ("ls-tree parse error:" ++ e)) id (extractTree l) void cleanup return t -lsTreeWithObjects :: Ref -> Repo -> IO ([LsTree.TreeItem], IO Bool) +lsTreeWithObjects :: LsTree.LsTreeMode -> Ref -> Repo -> IO ([LsTree.TreeItem], IO Bool) lsTreeWithObjects = LsTree.lsTree' [Param "-t"] newtype MkTreeHandle = MkTreeHandle CoProcess.CoProcessHandle @@ -181,7 +186,7 @@ -> m Sha adjustTree adjusttreeitem addtreeitems removefiles r repo = withMkTreeHandle repo $ \h -> do - (l, cleanup) <- liftIO $ lsTreeWithObjects r repo + (l, cleanup) <- liftIO $ lsTreeWithObjects LsTree.LsTreeRecursive r repo (l', _, _) <- go h False [] 1 inTopTree l l'' <- adjustlist h 0 inTopTree (const True) l' sha <- liftIO $ mkTree h l'' @@ -228,6 +233,69 @@ removeset = S.fromList $ map (normalise . gitPath) removefiles removed (TreeBlob f _ _) = S.member (normalise (gitPath f)) removeset removed _ = False + +{- Grafts subtree into the basetree at the specified location, replacing + - anything that the basetree already had at that location. + - + - This is generally much more efficient than using getTree and recordTree, + - or adjustTree, since it only needs to traverse from the top of the tree + - down to the graft location. It does not buffer the whole tree in memory. + -} +graftTree + :: Sha + -> TopFilePath + -> Sha + -> Repo + -> IO Sha +graftTree subtree graftloc basetree repo = + withMkTreeHandle repo $ graftTree' subtree graftloc basetree repo + +graftTree' + :: Sha + -> TopFilePath + -> Sha + -> Repo + -> MkTreeHandle + -> IO Sha +graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs + where + go tsha (topmostgraphdir:restgraphdirs) = do + Tree t <- getTree LsTree.LsTreeNonRecursive tsha repo + t' <- case partition isabovegraft t of + ([], _) -> do + graft <- graftin (topmostgraphdir:restgraphdirs) + return (graft:t) + -- normally there can only be one matching item + -- in the tree, but it's theoretically possible + -- for a git tree to have multiple items with the + -- same name, so process them all + (matching, rest) -> do + newshas <- forM matching $ \case + RecordedSubTree tloc tsha' _ + | null restgraphdirs -> return $ + RecordedSubTree tloc subtree [] + | otherwise -> do + tsha'' <- go tsha' restgraphdirs + return $ RecordedSubTree tloc tsha'' [] + _ -> graftin (topmostgraphdir:restgraphdirs) + return (newshas ++ rest) + mkTree hdl t' + go _ [] = return subtree + + isabovegraft i = beneathSubTree i graftloc || gitPath i == gitPath graftloc + + graftin t = recordSubTree hdl $ graftin' t + graftin' [] = RecordedSubTree graftloc subtree [] + graftin' (d:rest) + | d == graftloc = graftin' [] + | otherwise = NewSubTree d [graftin' rest] + + -- For a graftloc of "foo/bar/baz", this generates + -- ["foo", "foo/bar", "foo/bar/baz"] + graftdirs = map (asTopFilePath . toInternalGitPath) $ + mkpaths [] $ splitDirectories $ gitPath graftloc + mkpaths _ [] = [] + mkpaths base (d:rest) = (joinPath base d) : mkpaths (base ++ [d]) rest {- Assumes the list is ordered, with tree objects coming right before their - contents. -} diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Types where diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.UnionMerge ( diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns, CPP #-} diff --git a/Git/Url.hs b/Git/Url.hs --- a/Git/Url.hs +++ b/Git/Url.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Url ( diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -2,7 +2,7 @@ - - Copyright 2011, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Limit where diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Limit.Wanted where diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -1,8 +1,8 @@ {- git-annex log file names - - - Copyright 2013-2018 Joey Hess + - Copyright 2013-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs where @@ -12,7 +12,7 @@ {- There are several varieties of log file formats. -} data LogVariety - = UUIDBasedLog + = OldUUIDBasedLog | NewUUIDBasedLog | ChunkLog Key | PresenceLog Key @@ -24,16 +24,18 @@ - of logs used by git-annex, if it's a known path. -} getLogVariety :: FilePath -> Maybe LogVariety getLogVariety f - | f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog + | f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog + | f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog | isRemoteStateLog f = Just NewUUIDBasedLog - | isChunkLog f = ChunkLog <$> chunkLogFileKey f + | isRemoteContentIdentifierLog f = Just NewUUIDBasedLog + | isChunkLog f = ChunkLog <$> extLogFileKey chunkLogExt f | isRemoteMetaDataLog f = Just RemoteMetaDataLog | isMetaDataLog f || f `elem` otherLogs = Just OtherLog | otherwise = PresenceLog <$> firstJust (presenceLogs f) -{- All the uuid-based logs stored in the top of the git-annex branch. -} -topLevelUUIDBasedLogs :: [FilePath] -topLevelUUIDBasedLogs = +{- All the old-format uuid-based logs stored in the top of the git-annex branch. -} +topLevelOldUUIDBasedLogs :: [FilePath] +topLevelOldUUIDBasedLogs = [ uuidLog , remoteLog , trustLog @@ -44,9 +46,15 @@ , activityLog , differenceLog , multicastLog - , exportLog ] +{- All the new-format uuid-based logs stored in the top of the git-annex branch. -} +topLevelNewUUIDBasedLogs :: [FilePath] +topLevelNewUUIDBasedLogs = + [ exportLog + ] + + {- All the ways to get a key from a presence log file -} presenceLogs :: FilePath -> [Maybe Key] presenceLogs f = @@ -54,7 +62,7 @@ , locationLogFileKey f ] -{- Logs that are neither UUID based nor presence logs. -} +{- Top-level logs that are neither UUID based nor presence logs. -} otherLogs :: [FilePath] otherLogs = [ numcopiesLog @@ -107,16 +115,6 @@ locationLogFile :: GitConfig -> Key -> String locationLogFile config key = branchHashDir config key keyFile key ++ ".log" -{- Converts a pathname into a key if it's a location log. -} -locationLogFileKey :: FilePath -> Maybe Key -locationLogFileKey path - | ["remote", "web"] `isPrefixOf` splitDirectories dir = Nothing - | ext == ".log" = fileKey base - | otherwise = Nothing - where - (dir, file) = splitFileName path - (base, ext) = splitAt (length file - 4) file - {- The filename of the url log for a given key. -} urlLogFile :: GitConfig -> Key -> FilePath urlLogFile config key = branchHashDir config key keyFile key ++ urlLogExt @@ -133,17 +131,6 @@ urlLogExt :: String urlLogExt = ".log.web" -{- Converts a url log file into a key. - - (Does not work on oldurlLogs.) -} -urlLogFileKey :: FilePath -> Maybe Key -urlLogFileKey path - | ext == urlLogExt = fileKey base - | otherwise = Nothing - where - file = takeFileName path - (base, ext) = splitAt (length file - extlen) file - extlen = length urlLogExt - {- Does not work on oldurllogs. -} isUrlLog :: FilePath -> Bool isUrlLog file = urlLogExt `isSuffixOf` file @@ -163,15 +150,6 @@ chunkLogFile :: GitConfig -> Key -> FilePath chunkLogFile config key = branchHashDir config key keyFile key ++ chunkLogExt -chunkLogFileKey :: FilePath -> Maybe Key -chunkLogFileKey path - | ext == chunkLogExt = fileKey base - | otherwise = Nothing - where - file = takeFileName path - (base, ext) = splitAt (length file - extlen) file - extlen = length chunkLogExt - chunkLogExt :: String chunkLogExt = ".log.cnk" @@ -197,3 +175,35 @@ isRemoteMetaDataLog :: FilePath -> Bool isRemoteMetaDataLog path = remoteMetaDataLogExt `isSuffixOf` path + +{- The filename of the remote content identifier log for a given key. -} +remoteContentIdentifierLogFile :: GitConfig -> Key -> FilePath +remoteContentIdentifierLogFile config key = branchHashDir config key keyFile key ++ remoteContentIdentifierExt + +remoteContentIdentifierExt :: String +remoteContentIdentifierExt = ".log.cid" + +isRemoteContentIdentifierLog :: FilePath -> Bool +isRemoteContentIdentifierLog path = remoteContentIdentifierExt `isSuffixOf` path + +{- From an extension and a log filename, get the key that it's a log for. -} +extLogFileKey :: String -> FilePath -> Maybe Key +extLogFileKey expectedext path + | ext == expectedext = fileKey base + | otherwise = Nothing + where + file = takeFileName path + (base, ext) = splitAt (length file - extlen) file + extlen = length expectedext + +{- Converts a url log file into a key. + - (Does not work on oldurlLogs.) -} +urlLogFileKey :: FilePath -> Maybe Key +urlLogFileKey = extLogFileKey urlLogExt + +{- Converts a pathname into a key if it's a location log. -} +locationLogFileKey :: FilePath -> Maybe Key +locationLogFileKey path + -- Want only xx/yy/foo.log, not .log files in other places. + | length (splitDirectories path) /= 3 = Nothing + | otherwise = extLogFileKey ".log" path diff --git a/Logs/Activity.hs b/Logs/Activity.hs --- a/Logs/Activity.hs +++ b/Logs/Activity.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Activity ( @@ -29,12 +29,12 @@ recordActivity act uuid = do c <- liftIO currentVectorClock Annex.Branch.change activityLog $ - buildLog buildActivity + buildLogOld buildActivity . changeLog c uuid (Right act) - . parseLog parseActivity + . parseLogOld parseActivity lastActivities :: Maybe Activity -> Annex (Log Activity) -lastActivities wantact = parseLog (onlywanted =<< parseActivity) +lastActivities wantact = parseLogOld (onlywanted =<< parseActivity) <$> Annex.Branch.get activityLog where onlywanted (Right a) | wanted a = pure a diff --git a/Logs/Chunk.hs b/Logs/Chunk.hs --- a/Logs/Chunk.hs +++ b/Logs/Chunk.hs @@ -12,7 +12,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Chunk ( diff --git a/Logs/Chunk/Pure.hs b/Logs/Chunk/Pure.hs --- a/Logs/Chunk/Pure.hs +++ b/Logs/Chunk/Pure.hs @@ -2,7 +2,7 @@ - - Copyright 2014, 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Chunk.Pure diff --git a/Logs/Config.hs b/Logs/Config.hs --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -2,7 +2,7 @@ - - Copyright 2017-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Config ( diff --git a/Logs/ContentIdentifier.hs b/Logs/ContentIdentifier.hs new file mode 100644 --- /dev/null +++ b/Logs/ContentIdentifier.hs @@ -0,0 +1,47 @@ +{- Remote content identifier logs. + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Logs.ContentIdentifier ( + module X, + recordContentIdentifier, + getContentIdentifiers, +) where + +import Annex.Common +import Logs +import Logs.MapLog +import Types.Import +import qualified Annex.Branch +import Logs.ContentIdentifier.Pure as X +import qualified Annex + +import qualified Data.Map as M +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + +-- | Records a remote's content identifier and the key that it corresponds to. +-- +-- A remote may use multiple content identifiers for the same key over time, +-- so ones that were recorded before are preserved. +recordContentIdentifier :: UUID -> ContentIdentifier -> Key -> Annex () +recordContentIdentifier u cid k = do + c <- liftIO currentVectorClock + config <- Annex.getGitConfig + Annex.Branch.change (remoteContentIdentifierLogFile config k) $ + buildLog . addcid c . parseLog + where + addcid c l = changeMapLog c u (cid :| contentIdentifierList (M.lookup u m)) l + where + m = simpleMap l + +-- | Get all known content identifiers for a key. +getContentIdentifiers :: Key -> Annex [(UUID, [ContentIdentifier])] +getContentIdentifiers k = do + config <- Annex.getGitConfig + map (\(u, l) -> (u, NonEmpty.toList l) ) + . M.toList . simpleMap . parseLog + <$> Annex.Branch.get (remoteContentIdentifierLogFile config k) diff --git a/Logs/ContentIdentifier/Pure.hs b/Logs/ContentIdentifier/Pure.hs new file mode 100644 --- /dev/null +++ b/Logs/ContentIdentifier/Pure.hs @@ -0,0 +1,75 @@ +{- Remote content identifier logs, pure operations. + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Logs.ContentIdentifier.Pure where + +import Annex.Common +import Logs.UUIDBased +import Types.Import +import Utility.Base64 + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Data.ByteString.Builder +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty + +-- A ContentIdentifier can contain "", so to avoid ambiguity +-- in parsing, the list of them in the log must be non-empty. +type ContentIdentifierLog = Log (NonEmpty ContentIdentifier) + +contentIdentifierList :: Maybe (NonEmpty ContentIdentifier) -> [ContentIdentifier] +contentIdentifierList (Just l) = Data.List.NonEmpty.toList l +contentIdentifierList Nothing = [] + +buildLog :: ContentIdentifierLog -> Builder +buildLog = buildLogNew buildContentIdentifierList + +buildContentIdentifierList :: (NonEmpty ContentIdentifier) -> Builder +buildContentIdentifierList l = case l of + c :| [] -> buildcid c + (c :| cs) -> go (c:cs) + where + buildcid (ContentIdentifier c) + | S8.any (`elem` [':', '\r', '\n']) c || "!" `S8.isPrefixOf` c = + charUtf8 '!' <> byteString (toB64' c) + | otherwise = byteString c + go [] = mempty + go (c:[]) = buildcid c + go (c:cs) = buildcid c <> charUtf8 ':' <> go cs + +parseLog :: L.ByteString -> ContentIdentifierLog +parseLog = parseLogNew parseContentIdentifierList + +parseContentIdentifierList :: A.Parser (NonEmpty ContentIdentifier) +parseContentIdentifierList = do + first <- cidparser + listparser first [] + where + cidparser = do + b <- A8.takeWhile (/= ':') + return $ if "!" `S8.isPrefixOf` b + then ContentIdentifier $ fromMaybe b (fromB64Maybe' (S.drop 1 b)) + else ContentIdentifier b + listparser first rest = ifM A8.atEnd + ( return (first :| reverse rest) + , do + _ <- A8.char ':' + cid <- cidparser + listparser first (cid:rest) + ) + +prop_parse_build_contentidentifier_log :: NonEmpty ContentIdentifier -> Bool +prop_parse_build_contentidentifier_log l = + let v = A.parseOnly parseContentIdentifierList $ L.toStrict $ + toLazyByteString $ buildContentIdentifierList l + in v == Right l diff --git a/Logs/Difference.hs b/Logs/Difference.hs --- a/Logs/Difference.hs +++ b/Logs/Difference.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Difference ( @@ -27,9 +27,9 @@ recordDifferences ds@(Differences {}) uuid = do c <- liftIO currentVectorClock Annex.Branch.change differenceLog $ - buildLog byteString + buildLogOld byteString . changeLog c uuid (encodeBS $ showDifferences ds) - . parseLog A.takeByteString + . parseLogOld A.takeByteString recordDifferences UnknownDifferences _ = return () -- Map of UUIDs that have Differences recorded. diff --git a/Logs/Difference/Pure.hs b/Logs/Difference/Pure.hs --- a/Logs/Difference/Pure.hs +++ b/Logs/Difference/Pure.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Difference.Pure ( @@ -20,7 +20,7 @@ parseDifferencesLog :: L.ByteString -> (M.Map UUID Differences) parseDifferencesLog = simpleMap - . parseLog (readDifferences . decodeBS <$> A.takeByteString) + . parseLogOld (readDifferences . decodeBS <$> A.takeByteString) -- The sum of all recorded differences, across all UUIDs. allDifferences :: M.Map UUID Differences -> Differences diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -2,7 +2,7 @@ - - Copyright 2017-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Export ( @@ -124,7 +124,7 @@ buildExportLog . changeMapLog c ep new . parseExportLog - Annex.Branch.graftTreeish newtree (asTopFilePath "export.tree") + Annex.Branch.rememberTreeish newtree (asTopFilePath "export.tree") parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported parseExportLog = parseMapLog exportParticipantsParser exportedParser diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.FsckResults ( diff --git a/Logs/Group.hs b/Logs/Group.hs --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Group ( @@ -40,7 +40,7 @@ curr <- lookupGroups uuid c <- liftIO currentVectorClock Annex.Branch.change groupLog $ - buildLog buildGroup . changeLog c uuid (modifier curr) . parseLog parseGroup + buildLogOld buildGroup . changeLog c uuid (modifier curr) . parseLogOld parseGroup -- The changed group invalidates the preferred content cache. Annex.changeState $ \s -> s @@ -76,7 +76,8 @@ {- Loads the map, updating the cache. -} groupMapLoad :: Annex GroupMap groupMapLoad = do - m <- makeGroupMap . simpleMap . parseLog parseGroup <$> Annex.Branch.get groupLog + m <- makeGroupMap . simpleMap . parseLogOld parseGroup + <$> Annex.Branch.get groupLog Annex.changeState $ \s -> s { Annex.groupmap = Just m } return m diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -10,7 +10,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Location ( diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -8,7 +8,7 @@ - - Copyright 2014, 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.MapLog ( @@ -20,6 +20,7 @@ import Common import Annex.VectorClock import Logs.Line +import Utility.QuickCheck import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as M @@ -31,6 +32,9 @@ { changed :: VectorClock , value :: v } deriving (Eq, Show) + +instance Arbitrary v => Arbitrary (LogEntry v) where + arbitrary = LogEntry <$> arbitrary <*> arbitrary type MapLog f v = M.Map f (LogEntry v) diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -20,7 +20,7 @@ - and so foo currently has no value. - - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.MetaData ( diff --git a/Logs/MetaData/Pure.hs b/Logs/MetaData/Pure.hs --- a/Logs/MetaData/Pure.hs +++ b/Logs/MetaData/Pure.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Logs/Multicast.hs b/Logs/Multicast.hs --- a/Logs/Multicast.hs +++ b/Logs/Multicast.hs @@ -2,7 +2,7 @@ - - Copyright 2017, 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Multicast ( @@ -27,12 +27,12 @@ recordFingerprint fp uuid = do c <- liftIO currentVectorClock Annex.Branch.change multicastLog $ - buildLog buildFindgerPrint + buildLogOld buildFindgerPrint . changeLog c uuid fp - . parseLog fingerprintParser + . parseLogOld fingerprintParser knownFingerPrints :: Annex (M.Map UUID Fingerprint) -knownFingerPrints = simpleMap . parseLog fingerprintParser +knownFingerPrints = simpleMap . parseLogOld fingerprintParser <$> Annex.Branch.get activityLog fingerprintParser :: A.Parser Fingerprint diff --git a/Logs/NumCopies.hs b/Logs/NumCopies.hs --- a/Logs/NumCopies.hs +++ b/Logs/NumCopies.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.PreferredContent ( @@ -74,7 +74,7 @@ groupmap <- groupMap configmap <- readRemoteLog let genmap l gm = simpleMap - . parseLogWithUUID (\u -> makeMatcher groupmap configmap gm u . decodeBS <$> A.takeByteString) + . parseLogOldWithUUID (\u -> makeMatcher groupmap configmap gm u . decodeBS <$> A.takeByteString) <$> Annex.Branch.get l pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw rc <- genmap requiredContentLog M.empty diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.PreferredContent.Raw where @@ -32,9 +32,9 @@ setLog logfile uuid@(UUID _) val = do c <- liftIO currentVectorClock Annex.Branch.change logfile $ - buildLog buildPreferredContentExpression + buildLogOld buildPreferredContentExpression . changeLog c uuid val - . parseLog parsePreferredContentExpression + . parseLogOld parsePreferredContentExpression Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing , Annex.requiredcontentmap = Nothing @@ -70,11 +70,11 @@ buildPreferredContentExpression = byteString . encodeBS preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) -preferredContentMapRaw = simpleMap . parseLog parsePreferredContentExpression +preferredContentMapRaw = simpleMap . parseLogOld parsePreferredContentExpression <$> Annex.Branch.get preferredContentLog requiredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) -requiredContentMapRaw = simpleMap . parseLog parsePreferredContentExpression +requiredContentMapRaw = simpleMap . parseLogOld parsePreferredContentExpression <$> Annex.Branch.get requiredContentLog groupPreferredContentMapRaw :: Annex (M.Map Group PreferredContentExpression) diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -8,7 +8,7 @@ - - Copyright 2010-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Presence ( diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Presence.Pure where @@ -122,6 +122,5 @@ arbinfo = (encodeBS <$> arbitrary) `suchThat` (\b -> C8.notElem '\n' b && C8.notElem '\r' b) -prop_parse_build_log :: [LogLine] -> Bool -prop_parse_build_log l = parseLog (toLazyByteString (buildLog l)) == l - +prop_parse_build_presence_log :: [LogLine] -> Bool +prop_parse_build_presence_log l = parseLog (toLazyByteString (buildLog l)) == l diff --git a/Logs/Remote.hs b/Logs/Remote.hs --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Remote ( @@ -33,13 +33,13 @@ configSet u cfg = do c <- liftIO currentVectorClock Annex.Branch.change remoteLog $ - buildLog (byteString . encodeBS . showConfig) + buildLogOld (byteString . encodeBS . showConfig) . changeLog c u cfg - . parseLog remoteConfigParser + . parseLogOld remoteConfigParser {- Map of remotes by uuid containing key/value config maps. -} readRemoteLog :: Annex (M.Map UUID RemoteConfig) -readRemoteLog = simpleMap . parseLog remoteConfigParser +readRemoteLog = simpleMap . parseLogOld remoteConfigParser <$> Annex.Branch.get remoteLog remoteConfigParser :: A.Parser RemoteConfig diff --git a/Logs/RemoteState.hs b/Logs/RemoteState.hs --- a/Logs/RemoteState.hs +++ b/Logs/RemoteState.hs @@ -2,7 +2,7 @@ - - Copyright 2014, 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.RemoteState ( diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Schedule ( @@ -34,15 +34,15 @@ scheduleSet uuid@(UUID _) activities = do c <- liftIO currentVectorClock Annex.Branch.change scheduleLog $ - buildLog byteString + buildLogOld byteString . changeLog c uuid (encodeBS val) - . parseLog A.takeByteString + . parseLogOld A.takeByteString where val = fromScheduledActivities activities scheduleSet NoUUID _ = error "unknown UUID; cannot modify" scheduleMap :: Annex (M.Map UUID [ScheduledActivity]) -scheduleMap = simpleMap . parseLog parser <$> Annex.Branch.get scheduleLog +scheduleMap = simpleMap . parseLogOld parser <$> Annex.Branch.get scheduleLog where parser = either fail pure . parseScheduledActivities . decodeBS =<< A.takeByteString diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -8,7 +8,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.SingleValue ( diff --git a/Logs/SingleValue/Pure.hs b/Logs/SingleValue/Pure.hs --- a/Logs/SingleValue/Pure.hs +++ b/Logs/SingleValue/Pure.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.SingleValue.Pure where diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -9,7 +9,7 @@ - - Copyright 2013-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Transitions where diff --git a/Logs/Trust.hs b/Logs/Trust.hs --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Trust ( diff --git a/Logs/Trust/Basic.hs b/Logs/Trust/Basic.hs --- a/Logs/Trust/Basic.hs +++ b/Logs/Trust/Basic.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Trust.Basic ( @@ -24,9 +24,9 @@ trustSet uuid@(UUID _) level = do c <- liftIO currentVectorClock Annex.Branch.change trustLog $ - buildLog buildTrustLevel . + buildLogOld buildTrustLevel . changeLog c uuid level . - parseLog trustLevelParser + parseLogOld trustLevelParser Annex.changeState $ \s -> s { Annex.trustmap = Nothing } trustSet NoUUID _ = error "unknown UUID; cannot modify" diff --git a/Logs/Trust/Pure.hs b/Logs/Trust/Pure.hs --- a/Logs/Trust/Pure.hs +++ b/Logs/Trust/Pure.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} @@ -19,7 +19,7 @@ import Data.ByteString.Builder calcTrustMap :: L.ByteString -> TrustMap -calcTrustMap = simpleMap . parseLog trustLevelParser +calcTrustMap = simpleMap . parseLogOld trustLevelParser trustLevelParser :: A.Parser TrustLevel trustLevelParser = (totrust <$> A8.anyChar <* A.endOfInput) diff --git a/Logs/UUID.hs b/Logs/UUID.hs --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -4,7 +4,7 @@ - - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.UUID ( @@ -32,7 +32,7 @@ describeUUID uuid desc = do c <- liftIO currentVectorClock Annex.Branch.change uuidLog $ - buildLog buildUUIDDesc . changeLog c uuid desc . parseUUIDLog + buildLogOld buildUUIDDesc . changeLog c uuid desc . parseUUIDLog {- The map is cached for speed. -} uuidDescMap :: Annex UUIDDescMap @@ -53,4 +53,4 @@ preferold = flip const parseUUIDLog :: L.ByteString -> Log UUIDDesc -parseUUIDLog = parseLog (UUIDDesc <$> A.takeByteString) +parseUUIDLog = parseLogOld (UUIDDesc <$> A.takeByteString) diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -3,15 +3,15 @@ - This is used to store information about UUIDs in a way that can - be union merged. - - - A line of the log will look like: "UUID[ INFO[ timestamp=foo]]" + - The old format looks like: "UUID[ INFO[ timestamp=foo]]" - The timestamp is last for backwards compatability reasons, - - and may not be present on old log lines. + - and may not be present on very old log lines. - - New uuid based logs instead use the form: "timestamp UUID INFO" - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings, TupleSections #-} @@ -21,10 +21,10 @@ LogEntry(..), VectorClock, currentVectorClock, - parseLog, + parseLogOld, parseLogNew, - parseLogWithUUID, - buildLog, + parseLogOldWithUUID, + buildLogOld, buildLogNew, changeLog, addLog, @@ -48,8 +48,8 @@ type Log v = MapLog UUID v -buildLog :: (v -> Builder) -> Log v -> Builder -buildLog builder = mconcat . map genline . M.toList +buildLogOld :: (v -> Builder) -> Log v -> Builder +buildLogOld builder = mconcat . map genline . M.toList where genline (u, LogEntry c@(VectorClock {}) v) = buildUUID u <> sp <> builder v <> sp <> @@ -59,15 +59,15 @@ sp = charUtf8 ' ' nl = charUtf8 '\n' -parseLog :: A.Parser a -> L.ByteString -> Log a -parseLog = parseLogWithUUID . const +parseLogOld :: A.Parser a -> L.ByteString -> Log a +parseLogOld = parseLogOldWithUUID . const -parseLogWithUUID :: (UUID -> A.Parser a) -> L.ByteString -> Log a -parseLogWithUUID parser = fromMaybe M.empty . A.maybeResult - . A.parse (logParser parser) +parseLogOldWithUUID :: (UUID -> A.Parser a) -> L.ByteString -> Log a +parseLogOldWithUUID parser = fromMaybe M.empty . A.maybeResult + . A.parse (logParserOld parser) -logParser :: (UUID -> A.Parser a) -> A.Parser (Log a) -logParser parser = M.fromListWith best <$> parseLogLines go +logParserOld :: (UUID -> A.Parser a) -> A.Parser (Log a) +logParserOld parser = M.fromListWith best <$> parseLogLines go where go = do u <- toUUID <$> A8.takeWhile1 (/= ' ') diff --git a/Logs/Unused.hs b/Logs/Unused.hs --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -12,7 +12,7 @@ - - Copyright 2010-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Unused ( diff --git a/Logs/View.hs b/Logs/View.hs --- a/Logs/View.hs +++ b/Logs/View.hs @@ -6,7 +6,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.View ( diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Web ( diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Messages ( diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs --- a/Messages/Concurrent.hs +++ b/Messages/Concurrent.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Messages/Internal.hs b/Messages/Internal.hs --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Messages.Internal where diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings, GADTs #-} diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Messages.Progress where diff --git a/P2P/Address.hs b/P2P/Address.hs --- a/P2P/Address.hs +++ b/P2P/Address.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module P2P.Address where diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -2,7 +2,7 @@ - - Copyright 2016-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE RankNTypes, FlexibleContexts #-} diff --git a/P2P/Auth.hs b/P2P/Auth.hs --- a/P2P/Auth.hs +++ b/P2P/Auth.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module P2P.Auth where diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -2,7 +2,7 @@ - - Copyright 2016-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-} diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -4,7 +4,7 @@ - - Copyright 2016-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -17,7 +17,7 @@ import Config.Cost import Remote.Helper.Special import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import Annex.UUID import Utility.Metered @@ -35,6 +35,7 @@ , generate = gen , setup = adbSetup , exportSupported = exportIsSupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -61,6 +62,7 @@ , removeExportDirectory = Just $ removeExportDirectoryM serial adir , renameExport = renameExportM serial adir } + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -220,9 +222,9 @@ where aloc = androidExportLocation adir loc -renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportM serial adir _k old new = liftIO $ adbShellBool serial - [Param "mv", Param "-f", File oldloc, File newloc] +renameExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM serial adir _k old new = liftIO $ Just <$> + adbShellBool serial [Param "mv", Param "-f", File oldloc, File newloc] where oldloc = fromAndroidPath $ androidExportLocation adir old newloc = fromAndroidPath $ androidExportLocation adir new diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -27,7 +27,7 @@ import Annex.Tmp import Annex.UUID import qualified Annex.Url as Url -import Remote.Helper.Export +import Remote.Helper.ExportImport import Network.URI @@ -43,6 +43,7 @@ , generate = gen , setup = error "not supported" , exportSupported = exportUnsupported + , importSupported = importUnsupported } -- There is only one bittorrent remote, and it always exists. @@ -68,6 +69,7 @@ , checkPresent = checkKey , checkPresentCheap = False , exportActions = exportUnsupported + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Bup (remote) where @@ -25,7 +25,7 @@ import qualified Remote.Helper.Ssh as Ssh import Remote.Helper.Special import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import Utility.Hash import Utility.UserInfo import Annex.UUID @@ -41,6 +41,7 @@ , generate = gen , setup = bupSetup , exportSupported = exportUnsupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -67,6 +68,7 @@ , checkPresent = checkPresentDummy , checkPresentCheap = bupLocal buprepo , exportActions = exportUnsupported + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -3,7 +3,7 @@ - Copyright 2011 Joey Hess - Copyright 2014 Robie Basak - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Ddar (remote) where @@ -19,7 +19,7 @@ import Config import Config.Cost import Remote.Helper.Special -import Remote.Helper.Export +import Remote.Helper.ExportImport import Annex.Ssh import Annex.UUID import Utility.SshHost @@ -36,6 +36,7 @@ , generate = gen , setup = ddarSetup , exportSupported = exportUnsupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -66,6 +67,7 @@ , checkPresent = checkPresentDummy , checkPresentCheap = ddarLocal ddarrepo , exportActions = exportUnsupported + , importActions = importUnsupported , 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,8 +1,8 @@ {- A "remote" that is just a filesystem directory. - - - Copyright 2011-2017 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -26,12 +26,14 @@ import Config import Utility.FileMode import Remote.Helper.Special -import Remote.Helper.Export +import Remote.Helper.ExportImport +import Types.Import import qualified Remote.Directory.LegacyChunked as Legacy import Annex.Content import Annex.UUID import Utility.Metered import Utility.Tmp +import Utility.InodeCache remote :: RemoteType remote = RemoteType @@ -40,6 +42,7 @@ , generate = gen , setup = directorySetup , exportSupported = exportIsSupported + , importSupported = importIsSupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -73,6 +76,14 @@ , removeExportDirectory = Nothing , renameExport = renameExportM dir } + , importActions = ImportActions + { listImportableContents = listImportableContentsM dir + , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM dir + , storeExportWithContentIdentifier = storeExportWithContentIdentifierM dir + , removeExportWithContentIdentifier = removeExportWithContentIdentifierM dir + , removeExportDirectoryWhenEmpty = Nothing + , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM dir + } , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -227,14 +238,17 @@ 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" - ) +checkPresentGeneric d ps = checkPresentGeneric' d $ + liftIO $ anyM doesFileExist ps + +checkPresentGeneric' :: FilePath -> Annex Bool -> Annex Bool +checkPresentGeneric' d check = ifM check + ( return True + , ifM (liftIO $ 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 @@ -265,13 +279,15 @@ 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 +renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM d _k oldloc newloc = liftIO $ Just <$> go where + go = catchBoolIO $ do + createDirectoryIfMissing True (takeDirectory dest) + renameFile src dest + removeExportLocation d oldloc + return True + src = exportPath d oldloc dest = exportPath d newloc @@ -288,3 +304,157 @@ go Nothing _ = return () go (Just loc') _ = go (upFrom loc') =<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation loc')) + +listImportableContentsM :: FilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsM dir = catchMaybeIO $ liftIO $ do + l <- dirContentsRecursive dir + l' <- mapM go l + return $ ImportableContents (catMaybes l') [] + where + go f = do + st <- getFileStatus f + mkContentIdentifier f st >>= \case + Nothing -> return Nothing + Just cid -> do + relf <- relPathDirToFile dir f + sz <- getFileSize' f st + return $ Just (mkImportLocation relf, (cid, sz)) + +-- Make a ContentIdentifier that contains an InodeCache. +-- +-- The InodeCache is generated without checking a sentinal file. +-- So in a case when a remount etc causes all the inodes to change, +-- files may appear to be modified when they are not, which will only +-- result in extra work to re-import them. +-- +-- If the file is not a regular file, this will return Nothing. +mkContentIdentifier :: FilePath -> FileStatus -> IO (Maybe ContentIdentifier) +mkContentIdentifier f st = + fmap (ContentIdentifier . encodeBS . showInodeCache) + <$> toInodeCache noTSDelta f st + +retrieveExportWithContentIdentifierM :: FilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key) +retrieveExportWithContentIdentifierM dir loc cid dest mkkey p = + catchDefaultIO Nothing $ precheck $ docopy postcheck + where + f = exportPath dir loc + + docopy cont = do +#ifndef mingw32_HOST_OS + -- Need a duplicate fd for the post check, since + -- hGetContentsMetered closes its handle. + fd <- liftIO $ openFd f ReadOnly Nothing defaultFileFlags + dupfd <- liftIO $ dup fd + h <- liftIO $ fdToHandle fd +#else + h <- liftIO $ openBinaryFile f ReadMode +#endif + liftIO $ hGetContentsMetered h p >>= L.writeFile dest + k <- mkkey +#ifndef mingw32_HOST_OS + cont dupfd (return k) +#else + cont (return k) +#endif + + -- Check before copy, to avoid expensive copy of wrong file + -- content. + precheck cont = comparecid cont + =<< liftIO . mkContentIdentifier f + =<< liftIO (getFileStatus f) + + -- Check after copy, in case the file was changed while it was + -- 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. + -- + -- This does not guard against every possible race, but neither + -- can InodeCaches detect every possible modification to a file. + -- It's probably as good or better than git's handling of similar + -- situations with files being modified while it's updating the + -- working tree for a merge. +#ifndef mingw32_HOST_OS + postcheck fd cont = do +#else + postcheck cont = do +#endif + currcid <- liftIO $ mkContentIdentifier f +#ifndef mingw32_HOST_OS + =<< getFdStatus fd +#else + =<< getFileStatus f +#endif + comparecid cont currcid + + comparecid cont currcid + | currcid == Just cid = cont + | otherwise = return Nothing + +storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Maybe ContentIdentifier) +storeExportWithContentIdentifierM dir src _k loc overwritablecids p = + catchDefaultIO Nothing $ do + liftIO $ createDirectoryIfMissing True destdir + withTmpFileIn destdir template $ \tmpf tmph -> do + liftIO $ withMeteredFile src p (L.hPut tmph) + liftIO $ hFlush tmph + liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf >>= \case + Nothing -> return Nothing + Just newcid -> + checkExportContent dir loc (newcid:overwritablecids) Nothing $ const $ do + liftIO $ rename tmpf dest + return (Just newcid) + where + dest = exportPath dir loc + (destdir, base) = splitFileName dest + template = relatedTemplate (base ++ ".tmp") + +removeExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +removeExportWithContentIdentifierM dir k loc removeablecids = + checkExportContent dir loc removeablecids False $ \case + DoesNotExist -> return True + KnownContentIdentifier -> removeExportM dir k loc + +checkPresentExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +checkPresentExportWithContentIdentifierM dir _k loc knowncids = + checkPresentGeneric' dir $ + checkExportContent dir loc knowncids False $ \case + DoesNotExist -> return False + KnownContentIdentifier -> return True + +data CheckResult = DoesNotExist | KnownContentIdentifier + +-- Checks if the content at an ExportLocation is in the knowncids, +-- and only runs the callback that modifies it if it's safe to do so. +-- +-- This should avoid races to the extent possible. However, +-- if something has the file open for write, it could write to the handle +-- after the callback has overwritten or deleted it, and its write would +-- be lost, and we don't need to detect that. +-- (In similar situations, git doesn't either!) +-- +-- It follows that if something is written to the destination file +-- shortly before, it's acceptable to run the callback anyway, as that's +-- nearly indistinguishable from the above case. +-- +-- So, it suffices to check if the destination file's current +-- content is known, and immediately run the callback. +checkExportContent :: FilePath -> ExportLocation -> [ContentIdentifier] -> a -> (CheckResult -> Annex a) -> Annex a +checkExportContent dir loc knowncids unsafe callback = + tryWhenExists (liftIO $ getFileStatus dest) >>= \case + Just destst + | not (isRegularFile destst) -> return unsafe + | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier dest destst) >>= \case + Just destcid + | destcid `elem` knowncids -> callback KnownContentIdentifier + -- dest exists with other content + | otherwise -> return unsafe + -- should never happen + Nothing -> return unsafe + -- dest does not exist + Nothing -> callback DoesNotExist + where + dest = exportPath dir loc diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -4,7 +4,7 @@ - - Copyright 2011-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Directory.LegacyChunked where diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -19,8 +19,7 @@ import Git.Config (isTrue, boolConfig) import Git.Env import Remote.Helper.Special -import Remote.Helper.Export -import Annex.Export +import Remote.Helper.ExportImport import Remote.Helper.ReadOnly import Remote.Helper.Messages import Utility.Metered @@ -48,6 +47,7 @@ , generate = gen , setup = externalSetup , exportSupported = checkExportSupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -119,6 +119,7 @@ , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = exportactions + , importActions = importUnsupported , whereisKey = towhereis , remoteFsck = Nothing , repairRepo = Nothing @@ -306,25 +307,28 @@ where req = REMOVEEXPORTDIRECTORY dir -renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportM external k src dest = safely $ +renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM external k src dest = safely' (Just False) $ handleRequestExport external src req k Nothing $ \resp -> case resp of RENAMEEXPORT_SUCCESS k' - | k' == k -> result True + | k' == k -> result (Just True) RENAMEEXPORT_FAILURE k' - | k' == k -> result False - UNSUPPORTED_REQUEST -> result False + | k' == k -> result (Just False) + UNSUPPORTED_REQUEST -> result Nothing _ -> Nothing where req sk = RENAMEEXPORT sk dest safely :: Annex Bool -> Annex Bool -safely a = go =<< tryNonAsync a +safely = safely' False + +safely' :: a -> Annex a -> Annex a +safely' onerr a = go =<< tryNonAsync a where go (Right r) = return r go (Left e) = do toplevelWarning False (show e) - return False + return onerr {- Sends a Request to the external remote, and waits for it to generate - a Response. That is fed into the responsehandler, which should return diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.GCrypt ( @@ -38,7 +38,7 @@ import Remote.Helper.Encryptable import Remote.Helper.Special import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import qualified Remote.Helper.Ssh as Ssh import Utility.Metered import Annex.UUID @@ -61,6 +61,7 @@ , generate = gen , setup = gCryptSetup , exportSupported = exportUnsupported + , importSupported = importUnsupported } chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -119,6 +120,7 @@ , checkPresent = checkPresentDummy , checkPresentCheap = repoCheap r , exportActions = exportUnsupported + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -48,7 +48,7 @@ import Utility.SimpleProtocol import Remote.Helper.Git import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt import qualified Remote.P2P @@ -72,6 +72,7 @@ , generate = gen , setup = gitSetup , exportSupported = exportUnsupported + , importSupported = importUnsupported } list :: Bool -> Annex [Git.Repo] @@ -165,6 +166,7 @@ , checkPresent = inAnnex new st , checkPresentCheap = repoCheap r , exportActions = exportUnsupported + , importActions = importUnsupported , 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 @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Glacier (remote, jobList, checkSaneGlacierCommand) where @@ -18,7 +18,7 @@ import Config.Cost import Remote.Helper.Special import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import qualified Remote.Helper.AWS as AWS import Creds import Utility.Metered @@ -36,6 +36,7 @@ , generate = gen , setup = glacierSetup , exportSupported = exportUnsupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -65,6 +66,7 @@ , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = exportUnsupported + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Helper.Chunked ( diff --git a/Remote/Helper/Chunked/Legacy.hs b/Remote/Helper/Chunked/Legacy.hs --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Helper.Chunked.Legacy where diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Helper.Encryptable ( diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs deleted file mode 100644 --- a/Remote/Helper/Export.hs +++ /dev/null @@ -1,215 +0,0 @@ -{- 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 Config -import Git.Types (fromRef) -import Logs.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 (ExportActions Annex) where - exportUnsupported = 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 - Nothing -> notexport - Just c -> case yesNo c of - Just True -> ifM (isExportSupported r) - ( isexport - , notexport - ) - Just False -> notexport - Nothing -> do - warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export" - notexport - where - notexport = return $ r - { exportActions = exportUnsupported - , remotetype = (remotetype r) - { exportSupported = exportUnsupported - } - } - isexport = do - db <- openDb (uuid r) - updateflag <- liftIO $ newTVarIO Nothing - - -- When multiple threads run this, all except the first - -- will block until the first runs doneupdateonce. - -- Returns True when an update should be done and False - -- when the update has already been done. - let startupdateonce = liftIO $ atomically $ - readTVar updateflag >>= \case - Nothing -> do - writeTVar updateflag (Just True) - return True - Just True -> retry - Just False -> return False - let doneupdateonce = \updated -> - when updated $ - liftIO $ atomically $ - writeTVar updateflag (Just False) - - exportinconflict <- liftIO $ newTVarIO 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 - bracket startupdateonce doneupdateonce $ \updatenow -> - when updatenow $ - updateExportTreeFromLog db >>= \case - ExportUpdateSuccess -> return () - ExportUpdateConflict -> do - warnExportConflict r - liftIO $ atomically $ - writeTVar exportinconflict True - 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 using retrieveExport, - -- but since that retrieves from a path in the - -- remote that another writer could have replaced - -- with content not of the requested key, - -- the content has to be strongly verified. - -- - -- appendonly remotes have a key/value store, - -- so don't need to use retrieveExport. However, - -- fall back to it if retrieveKeyFile fails. - , retrieveKeyFile = \k af dest p -> - let retrieveexport = retrieveKeyFileFromExport getexportlocs exportinconflict k af dest p - in if appendonly r - then do - ret@(ok, _v) <- retrieveKeyFile r k af dest p - if ok - then return ret - else retrieveexport - else retrieveexport - , retrieveKeyFileCheap = if appendonly r - then retrieveKeyFileCheap r - else \_ _ _ -> 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. - -- - -- (except for appendonly remotes) - , lockContent = if appendonly r - then lockContent r - else Nothing - -- Check if any of the files a key was exported to - -- are present. This doesn't guarantee the export - -- contains the right content, which is why export - -- remotes are untrusted. - -- - -- (but appendonly remotes work the same as any - -- non-export remote) - , checkPresent = if appendonly r - then checkPresent r - else \k -> anyM (checkPresentExport (exportActions r) k) - =<< getexportlocs k - -- checkPresent from an export is more expensive - -- than otherwise, so not cheap. Also, this - -- avoids things that look at checkPresentCheap and - -- silently skip non-present files from behaving - -- in confusing ways when there's an export - -- conflict. - , checkPresentCheap = False - , mkUnavailable = return Nothing - , getInfo = do - ts <- map fromRef . exportedTreeishes - <$> getExport (uuid r) - is <- getInfo r - return (is++[("export", "yes"), ("exportedtree", unwords ts)]) - } - retrieveKeyFileFromExport getexportlocs exportinconflict k _af dest p = unVerified $ - if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k)) - then do - locs <- getexportlocs k - case locs of - [] -> do - ifM (liftIO $ atomically $ readTVar exportinconflict) - ( warning "unknown export location, likely due to the export conflict" - , warning "unknown export location" - ) - return False - (l:_) -> retrieveExport (exportActions r) k l dest p - else do - warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend" - return False diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs new file mode 100644 --- /dev/null +++ b/Remote/Helper/ExportImport.hs @@ -0,0 +1,335 @@ +{- Helper to make remotes support export and import (or not). + - + - Copyright 2017-2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} + +module Remote.Helper.ExportImport where + +import Annex.Common +import Types.Remote +import Types.Backend +import Types.Key +import Backend +import Remote.Helper.Encryptable (isEncrypted) +import qualified Database.Export as Export +import qualified Database.ContentIdentifier as ContentIdentifier +import Annex.Export +import Annex.LockFile +import Config +import Git.Types (fromRef) +import Logs.Export +import Logs.ContentIdentifier (recordContentIdentifier) + +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 (ExportActions Annex) where + exportUnsupported = 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 Nothing + } + +-- | Use for remotes that do not support imports. +class HasImportUnsupported a where + importUnsupported :: a + +instance HasImportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where + importUnsupported = \_ _ -> return False + +instance HasImportUnsupported (ImportActions Annex) where + importUnsupported = ImportActions + { listImportableContents = return Nothing + , retrieveExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing + , storeExportWithContentIdentifier = \_ _ _ _ _ -> return Nothing + , removeExportWithContentIdentifier = \_ _ _ -> return False + , removeExportDirectoryWhenEmpty = Just $ \_ -> return False + , checkPresentExportWithContentIdentifier = \_ _ _ -> return False + } + +exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool +exportIsSupported = \_ _ -> return True + +importIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool +importIsSupported = \_ _ -> return True + +-- | Prevent or allow exporttree=yes and importtree=yes when +-- setting up a new remote, depending on exportSupported and importSupported. +adjustExportImportRemoteType :: RemoteType -> RemoteType +adjustExportImportRemoteType rt = rt { setup = setup' } + where + setup' st mu cp c gc = + let checkconfig supported configured setting cont = + ifM (supported rt c gc) + ( case st of + Init + | configured c && isEncrypted c -> + giveup $ "cannot enable both encryption and " ++ setting + | otherwise -> cont + Enable oldc + | configured c /= configured oldc -> + giveup $ "cannot change " ++ setting ++ " of existing special remote" + | otherwise -> cont + , if configured c + then giveup $ setting ++ " is not supported by this special remote" + else cont + ) + in checkconfig exportSupported exportTree "exporttree" $ + checkconfig importSupported importTree "importtree" $ + if importTree c && not (exportTree c) + then giveup "cannot enable importtree=yes without also enabling exporttree=yes" + else setup rt st mu cp c gc + +-- | Adjust a remote to support exporttree=yes and importree=yes. +-- +-- Note that all remotes with importree=yes also have exporttree=yes. +adjustExportImport :: Remote -> Annex Remote +adjustExportImport r = case M.lookup "exporttree" (config r) of + Nothing -> return $ notexport r + Just c -> case yesNo c of + Just True -> ifM (isExportSupported r) + ( do + exportdbv <- prepexportdb + r' <- isexport exportdbv + if importTree (config r) + then isimport r' exportdbv + else return r' + , return $ notexport r + ) + Just False -> return $ notexport r + Nothing -> do + warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export" + return $ notexport r + where + notexport r' = notimport r' + { exportActions = exportUnsupported + , remotetype = (remotetype r') + { exportSupported = exportUnsupported + } + } + + notimport r' = r' + { importActions = importUnsupported + , remotetype = (remotetype r') + { importSupported = importUnsupported + } + } + + isimport r' exportdbv = do + ciddbv <- prepciddb + + let keycids k = do + db <- getciddb ciddbv + liftIO $ ContentIdentifier.getContentIdentifiers db (uuid r') k + + let checkpresent k loc = + checkPresentExportWithContentIdentifier + (importActions r') + k loc + =<< keycids k + + return $ r' + { exportActions = (exportActions r') + { storeExport = \f k loc p -> do + db <- getciddb ciddbv + exportdb <- getexportdb exportdbv + updateexportdb exportdb exportdbv + oldks <- liftIO $ Export.getExportTreeKey exportdb loc + oldcids <- liftIO $ concat + <$> mapM (ContentIdentifier.getContentIdentifiers db (uuid r')) oldks + storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case + Nothing -> return False + Just newcid -> do + withExclusiveLock gitAnnexContentIdentifierLock $ do + liftIO $ ContentIdentifier.recordContentIdentifier db (uuid r') newcid k + liftIO $ ContentIdentifier.flushDbQueue db + recordContentIdentifier (uuid r') newcid k + return True + , removeExport = \k loc -> + removeExportWithContentIdentifier (importActions r') k loc + =<< keycids k + , removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r') + -- renameExport is optional, and the + -- remote's implementation may + -- lose modifications to the file + -- (by eg copying and then deleting) + -- so don't use it + , renameExport = \_ _ _ -> return Nothing + , checkPresentExport = checkpresent + } + , checkPresent = if appendonly r' + then checkPresent r' + else \k -> anyM (checkpresent k) + =<< getexportlocs exportdbv k + } + + isexport dbv = 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 using retrieveExport, + -- but since that retrieves from a path in the + -- remote that another writer could have replaced + -- with content not of the requested key, + -- the content has to be strongly verified. + -- + -- appendonly remotes have a key/value store, + -- so don't need to use retrieveExport. However, + -- fall back to it if retrieveKeyFile fails. + , retrieveKeyFile = \k af dest p -> + let retrieveexport = retrieveKeyFileFromExport dbv k af dest p + in if appendonly r + then do + ret@(ok, _v) <- retrieveKeyFile r k af dest p + if ok + then return ret + else retrieveexport + else retrieveexport + , retrieveKeyFileCheap = if appendonly r + then retrieveKeyFileCheap r + else \_ _ _ -> 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. + -- + -- (except for appendonly remotes) + , lockContent = if appendonly r + then lockContent r + else Nothing + -- Check if any of the files a key was exported to + -- are present. This doesn't guarantee the export + -- contains the right content, which is why export + -- remotes are untrusted. + -- + -- (but appendonly remotes work the same as any + -- non-export remote) + , checkPresent = if appendonly r + then checkPresent r + else \k -> anyM (checkPresentExport (exportActions r) k) + =<< getexportlocs dbv k + -- checkPresent from an export is more expensive + -- than otherwise, so not cheap. Also, this + -- avoids things that look at checkPresentCheap and + -- silently skip non-present files from behaving + -- in confusing ways when there's an export + -- conflict. + , checkPresentCheap = False + , mkUnavailable = return Nothing + , getInfo = do + ts <- map fromRef . exportedTreeishes + <$> getExport (uuid r) + is <- getInfo r + return (is++[("export", "yes"), ("exportedtree", unwords ts)]) + } + + prepciddb = do + lcklckv <- liftIO newEmptyTMVarIO + dbtv <- liftIO newEmptyTMVarIO + return (dbtv, lcklckv) + + prepexportdb = do + lcklckv <- liftIO newEmptyTMVarIO + dbv <- liftIO newEmptyTMVarIO + exportinconflict <- liftIO $ newTVarIO False + exportupdated <- liftIO $ newTMVarIO () + return (dbv, lcklckv, exportinconflict, exportupdated) + + -- Only open the database once it's needed. + getciddb (dbtv, lcklckv) = + liftIO (atomically (tryReadTMVar dbtv)) >>= \case + Just db -> return db + -- let only one thread take the lock + Nothing -> ifM (liftIO $ atomically $ tryPutTMVar lcklckv ()) + ( do + db <- ContentIdentifier.openDb + ContentIdentifier.needsUpdateFromLog db >>= \case + Just v -> withExclusiveLock gitAnnexContentIdentifierLock $ + ContentIdentifier.updateFromLog db v + Nothing -> noop + liftIO $ atomically $ putTMVar dbtv db + return db + -- loser waits for winner to open the db and + -- can then also use its handle + , liftIO $ atomically (readTMVar dbtv) + ) + + -- Only open the database once it's needed. + getexportdb (dbv, lcklckv, _, _) = + liftIO (atomically (tryReadTMVar dbv)) >>= \case + Just db -> return db + -- let only one thread take the lock + Nothing -> ifM (liftIO $ atomically $ tryPutTMVar lcklckv ()) + ( do + db <- Export.openDb (uuid r) + liftIO $ atomically $ putTMVar dbv db + return db + -- loser waits for winner to open the db and + -- can then also use its handle + , liftIO $ atomically (readTMVar dbv) + ) + + getexportinconflict (_, _, v, _) = v + + -- Check 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. + updateexportdb db (_, _, exportinconflict, exportupdated) = + liftIO (atomically (tryTakeTMVar exportupdated)) >>= \case + Just () -> Export.updateExportTreeFromLog db >>= \case + Export.ExportUpdateSuccess -> return () + Export.ExportUpdateConflict -> do + warnExportConflict r + liftIO $ atomically $ + writeTVar exportinconflict True + Nothing -> return () + + getexportlocs dbv k = do + db <- getexportdb dbv + updateexportdb db dbv + liftIO $ Export.getExportTree db k + + retrieveKeyFileFromExport dbv k _af dest p = unVerified $ + if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k)) + then do + locs <- getexportlocs dbv k + case locs of + [] -> do + ifM (liftIO $ atomically $ readTVar $ getexportinconflict dbv) + ( warning "unknown export location, likely due to the export conflict" + , warning "unknown export location" + ) + return False + (l:_) -> retrieveExport (exportActions r) k l dest p + else do + warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend" + return False diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Helper.Git where diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs --- a/Remote/Helper/Messages.hs +++ b/Remote/Helper/Messages.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -2,7 +2,7 @@ - - Copyright 2016-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE RankNTypes #-} diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -2,7 +2,7 @@ - - Copyright 2013, 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Helper.ReadOnly diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Helper.Special ( diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Hook (remote) where @@ -16,7 +16,7 @@ import Annex.UUID import Remote.Helper.Special import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import Utility.Env import Messages.Progress @@ -32,6 +32,7 @@ , generate = gen , setup = hookSetup , exportSupported = exportUnsupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -57,6 +58,7 @@ , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = exportUnsupported + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -4,7 +4,7 @@ - - Copyright 2011,2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.List where @@ -18,7 +18,7 @@ import Annex.UUID import Remote.Helper.Hooks import Remote.Helper.ReadOnly -import Remote.Helper.Export +import Remote.Helper.ExportImport import qualified Git import qualified Git.Config @@ -44,7 +44,7 @@ import qualified Remote.External remoteTypes :: [RemoteType] -remoteTypes = map adjustExportableRemoteType +remoteTypes = map adjustExportImportRemoteType [ Remote.Git.remote , Remote.GCrypt.remote , Remote.P2P.remote @@ -100,13 +100,13 @@ {- Generates a Remote. -} remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe Remote) -remoteGen m t r = do - u <- getRepoUUID r - gc <- Annex.getRemoteGitConfig r +remoteGen m t g = do + u <- getRepoUUID g + gc <- Annex.getRemoteGitConfig g let c = fromMaybe M.empty $ M.lookup u m - generate t r u c gc >>= maybe - (return Nothing) - (Just <$$> adjustExportable . adjustReadOnly . addHooks) + generate t g u c gc >>= \case + Nothing -> return Nothing + Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) {- 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 @@ -2,7 +2,7 @@ - - Copyright 2016-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.P2P ( @@ -23,7 +23,7 @@ import Config import Config.Cost import Remote.Helper.Git -import Remote.Helper.Export +import Remote.Helper.ExportImport import Remote.Helper.P2P import Utility.AuthToken @@ -38,6 +38,7 @@ , generate = \_ _ _ _ -> return Nothing , setup = error "P2P remotes are set up using git-annex p2p" , exportSupported = exportUnsupported + , importSupported = importUnsupported } chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -59,6 +60,7 @@ , checkPresent = checkpresent protorunner , checkPresentCheap = False , exportActions = exportUnsupported + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -28,7 +28,7 @@ import Annex.Ssh import Remote.Helper.Special import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import Types.Export import Remote.Rsync.RsyncUrl import Crypto @@ -51,6 +51,7 @@ , generate = gen , setup = rsyncSetup , exportSupported = exportIsSupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -85,6 +86,7 @@ , removeExportDirectory = Just (removeExportDirectoryM o) , renameExport = renameExportM o } + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -291,8 +293,8 @@ Nothing -> [] Just f' -> includes f' -renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportM _ _ _ _ = return False +renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportM _ _ _ _ = return Nothing {- Rsync params to enable resumes of sending files safely, - ensure that files are only moved into place once complete diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeFamilies #-} @@ -39,14 +39,13 @@ 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 Remote.Helper.ExportImport import qualified Remote.Helper.AWS as AWS import Creds import Annex.UUID @@ -72,6 +71,7 @@ , generate = gen , setup = s3Setup , exportSupported = exportIsSupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -112,6 +112,7 @@ , removeExportDirectory = Nothing , renameExport = renameExportS3 hdl this info } + , importActions = importUnsupported , whereisKey = Just (getPublicWebUrls u info c) , remoteFsck = Nothing , repairRepo = Nothing @@ -397,15 +398,17 @@ giveup "No S3 credentials configured" -- S3 has no move primitive; copy and delete. -renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool -renameExportS3 hv r info k src dest = withS3Handle hv $ \case - Just h -> checkVersioning info (uuid r) k $ - catchNonAsync (go h) (\_ -> return False) - Nothing -> do - warning $ needS3Creds (uuid r) - return False +renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportS3 hv r info k src dest = Just <$> go where - go h = liftIO $ runResourceT $ do + go = withS3Handle hv $ \case + Just h -> checkVersioning info (uuid r) k $ + catchNonAsync (go' h) (\_ -> return False) + Nothing -> do + warning $ needS3Creds (uuid r) + return False + + go' h = liftIO $ runResourceT $ do let co = S3.copyObject (bucket info) dstobject (S3.ObjectId (bucket info) srcobject Nothing) S3.CopyMetadata @@ -413,6 +416,7 @@ 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 @@ -567,9 +571,6 @@ Nothing -> S3.s3RequestStyle cfg } where - proto - | port == 443 = AWS.HTTPS - | otherwise = AWS.HTTP h = fromJust $ M.lookup "host" c datacenter = fromJust $ M.lookup "datacenter" c -- When the default S3 host is configured, connect directly to @@ -578,10 +579,31 @@ endpoint | h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter | otherwise = T.encodeUtf8 $ T.pack h - port = let s = fromJust $ M.lookup "port" c in - case reads s of - [(p, _)] -> p - _ -> giveup $ "bad S3 port value: " ++ s + port = case M.lookup "port" c of + Just s -> + case reads s of + [(p, _)] + -- Let protocol setting override + -- default port 80. + | p == 80 -> case cfgproto of + Just AWS.HTTPS -> 443 + _ -> p + | otherwise -> p + _ -> giveup $ "bad S3 port value: " ++ s + Nothing -> case cfgproto of + Just AWS.HTTPS -> 443 + Just AWS.HTTP -> 80 + Nothing -> 80 + cfgproto = case M.lookup "protocol" c of + Just "https" -> Just AWS.HTTPS + Just "http" -> Just AWS.HTTP + Just s -> giveup $ "bad S3 protocol value: " ++ s + Nothing -> Nothing + proto = case cfgproto of + Just v -> v + Nothing + | port == 443 -> AWS.HTTPS + | otherwise -> AWS.HTTP cfg = S3.s3 proto endpoint False data S3Info = S3Info @@ -731,6 +753,7 @@ [ Just ("bucket", fromMaybe "unknown" (getBucketName c)) , Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c))) , Just ("port", show (S3.s3Port s3c)) + , Just ("protocol", map toLower (show (S3.s3Protocol s3c))) , Just ("storage class", showstorageclass (getStorageClass c)) , if configIA c then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c) @@ -859,7 +882,7 @@ -- 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 () -#if MIN_VERSION_aws(0,22,0) +#if MIN_VERSION_aws(0,21,1) enableBucketVersioning ss c gc u = do #else enableBucketVersioning ss c _ _ = do @@ -874,7 +897,7 @@ giveup "Cannot change versioning= of existing S3 remote." where enableversioning b = do -#if MIN_VERSION_aws(0,22,0) +#if MIN_VERSION_aws(0,21,1) showAction "enabling bucket versioning" hdl <- mkS3HandleVar c gc u withS3HandleOrFail u hdl $ \h -> diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -15,7 +15,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} @@ -34,7 +34,7 @@ import Config import Config.Cost import Remote.Helper.Special -import Remote.Helper.Export +import Remote.Helper.ExportImport import Annex.UUID import Annex.Content import Logs.RemoteState @@ -58,6 +58,7 @@ , generate = gen , setup = tahoeSetup , exportSupported = exportUnsupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -80,6 +81,7 @@ , checkPresent = checkKey u hdl , checkPresentCheap = False , exportActions = exportUnsupported + , importActions = importUnsupported , 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 @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Remote.Web (remote, getWebUrls) where @@ -10,7 +10,7 @@ import Annex.Common import Types.Remote import Remote.Helper.Messages -import Remote.Helper.Export +import Remote.Helper.ExportImport import qualified Git import qualified Git.Construct import Annex.Content @@ -29,6 +29,7 @@ , generate = gen , setup = error "not supported" , exportSupported = exportUnsupported + , importSupported = importUnsupported } -- There is only one web remote, and it always exists. @@ -57,6 +58,7 @@ , checkPresent = checkKey , checkPresentCheap = False , exportActions = exportUnsupported + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -34,7 +34,7 @@ import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.Http -import Remote.Helper.Export +import Remote.Helper.ExportImport import qualified Remote.Helper.Chunked.Legacy as Legacy import Creds import Utility.Metered @@ -53,6 +53,7 @@ , generate = gen , setup = webdavSetup , exportSupported = exportIsSupported + , importSupported = importUnsupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -88,6 +89,7 @@ removeExportDirectoryDav this , renameExport = renameExportDav this } + , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -237,19 +239,21 @@ safely (inLocation d delContentM) >>= maybe (return False) (const $ return True) -renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool +renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) renameExportDav r _k src dest = case (exportLocation src, exportLocation dest) of (Right srcl, Right destl) -> withDAVHandle r $ \case Just h -- 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 destl) - moveDAV (baseURL dav) srcl destl - return True - Nothing -> return False - _ -> return False + | boxComUrl `isPrefixOf` baseURL h -> return Nothing + | otherwise -> do + v <- runExport (Just h) $ \dav -> do + maybe noop (void . mkColRecursive) (locationParent destl) + moveDAV (baseURL dav) srcl destl + return True + return (Just v) + Nothing -> return (Just False) + _ -> return (Just False) runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool runExport Nothing _ = return False diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/RemoteDaemon/Common.hs b/RemoteDaemon/Common.hs --- a/RemoteDaemon/Common.hs +++ b/RemoteDaemon/Common.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module RemoteDaemon.Common diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module RemoteDaemon.Core (runInteractive, runNonInteractive) where diff --git a/RemoteDaemon/Transport.hs b/RemoteDaemon/Transport.hs --- a/RemoteDaemon/Transport.hs +++ b/RemoteDaemon/Transport.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module RemoteDaemon.Transport where diff --git a/RemoteDaemon/Transport/GCrypt.hs b/RemoteDaemon/Transport/GCrypt.hs --- a/RemoteDaemon/Transport/GCrypt.hs +++ b/RemoteDaemon/Transport/GCrypt.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module RemoteDaemon.Transport.GCrypt (transport) where diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs --- a/RemoteDaemon/Transport/Ssh.hs +++ b/RemoteDaemon/Transport/Ssh.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module RemoteDaemon.Transport.Ssh (transport, transportUsingCmd) where diff --git a/RemoteDaemon/Transport/Ssh/Types.hs b/RemoteDaemon/Transport/Ssh/Types.hs --- a/RemoteDaemon/Transport/Ssh/Types.hs +++ b/RemoteDaemon/Transport/Ssh/Types.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs --- a/RemoteDaemon/Types.hs +++ b/RemoteDaemon/Types.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,8 +1,8 @@ {- git-annex test suite - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -36,6 +36,7 @@ import qualified Git.Ref import qualified Git.LsTree import qualified Git.FilePath +import qualified Git.Merge import qualified Annex.Locations #ifndef mingw32_HOST_OS import qualified Types.GitConfig @@ -48,6 +49,7 @@ import qualified Logs.Unused import qualified Logs.Transfer import qualified Logs.Presence +import qualified Logs.ContentIdentifier import qualified Logs.PreferredContent import qualified Types.MetaData import qualified Remote @@ -175,7 +177,8 @@ , testProperty "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest , testProperty "prop_read_write_transferinfo" Logs.Transfer.prop_read_write_transferinfo , testProperty "prop_read_show_inodecache" Utility.InodeCache.prop_read_show_inodecache - , testProperty "prop_parse_build_log" Logs.Presence.prop_parse_build_log + , testProperty "prop_parse_build_presence_log" Logs.Presence.prop_parse_build_presence_log + , testProperty "prop_parse_build_contentidentifier_log" Logs.ContentIdentifier.prop_parse_build_contentidentifier_log , testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel , testProperty "prop_parse_build_TrustLevelLog" Logs.Trust.prop_parse_build_TrustLevelLog , testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable @@ -205,6 +208,7 @@ unitTests note = testGroup ("Unit Tests " ++ note) [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras + , testCase "export_import" test_export_import , testCase "shared clone" test_shared_clone , testCase "log" test_log , testCase "import" test_import @@ -1723,3 +1727,53 @@ let dest = "addurlurldest" filecmd "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ " with --file") doesFileExist dest @? (dest ++ " missing after addurl --file") + +test_export_import :: Assertion +test_export_import = intmpclonerepoInDirect $ do + createDirectory "dir" + git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") @? "initremote failed" + git_annex "get" [] @? "get of files failed" + annexed_present annexedfile + + git_annex "export" ["master", "--to", "foo"] @? "export to dir failed" + dircontains annexedfile (content annexedfile) + + writedir "import" (content "import") + git_annex "import" ["master", "--from", "foo"] @? "import from dir failed" + up <- Git.Merge.mergeUnrelatedHistoriesParam + let mergeps = [Param "merge", Param "foo/master", Param "-mmerge"] ++ maybeToList up + boolSystem "git" mergeps @? "git merge foo/master failed" + -- FIXME fails when in an adjusted unlocked branch because + -- it's imported locked + --annexed_present "import" + + nukeFile "import" + writecontent "import" (content "newimport1") + git_annex "add" ["import"] @? "add of import failed" + boolSystem "git" [Param "commit", Param "-q", Param "-mchanged"] @? "git commit failed" + git_annex "export" ["master", "--to", "foo"] @? "export modified file to dir failed" + dircontains "import" (content "newimport1") + + -- verify that export refuses to overwrite modified file + writedir "import" (content "newimport2") + nukeFile "import" + writecontent "import" (content "newimport3") + git_annex "add" ["import"] @? "add of import failed" + boolSystem "git" [Param "commit", Param "-q", Param "-mchanged"] @? "git commit failed" + git_annex_shouldfail "export" ["master", "--to", "foo"] @? "export failed to fail in conflict" + dircontains "import" (content "newimport2") + + -- resolving import conflict + git_annex "import" ["master", "--from", "foo"] @? "import from dir failed" + not <$> boolSystem "git" [Param "merge", Param "foo/master", Param "-mmerge"] @? "git merge of conflict failed to exit nonzero" + nukeFile "import" + writecontent "import" (content "newimport3") + git_annex "add" ["import"] @? "add of import failed" + boolSystem "git" [Param "commit", Param "-q", Param "-mchanged"] @? "git commit failed" + git_annex "export" ["master", "--to", "foo"] @? "export failed after import conflict" + dircontains "import" (content "newimport3") + where + dircontains f v = + ((v==) <$> readFile ("dir" f)) + @? ("did not find expected content of " ++ "dir" f) + writedir f = writecontent ("dir" f) diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Test.Framework where diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types ( diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} diff --git a/Types/Availability.hs b/Types/Availability.hs --- a/Types/Availability.hs +++ b/Types/Availability.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Availability where diff --git a/Types/Backend.hs b/Types/Backend.hs --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -4,7 +4,7 @@ - - Copyright 2010-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Backend where diff --git a/Types/Benchmark.hs b/Types/Benchmark.hs --- a/Types/Benchmark.hs +++ b/Types/Benchmark.hs @@ -2,7 +2,7 @@ - - Copyright 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Benchmark where diff --git a/Types/BranchState.hs b/Types/BranchState.hs --- a/Types/BranchState.hs +++ b/Types/BranchState.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.BranchState where diff --git a/Types/CleanupActions.hs b/Types/CleanupActions.hs --- a/Types/CleanupActions.hs +++ b/Types/CleanupActions.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.CleanupActions where diff --git a/Types/Command.hs b/Types/Command.hs --- a/Types/Command.hs +++ b/Types/Command.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Command where diff --git a/Types/Concurrency.hs b/Types/Concurrency.hs --- a/Types/Concurrency.hs +++ b/Types/Concurrency.hs @@ -1,6 +1,6 @@ {- Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Concurrency where diff --git a/Types/Creds.hs b/Types/Creds.hs --- a/Types/Creds.hs +++ b/Types/Creds.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Creds where diff --git a/Types/Crypto.hs b/Types/Crypto.hs --- a/Types/Crypto.hs +++ b/Types/Crypto.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Crypto ( diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE FlexibleInstances #-} diff --git a/Types/DesktopNotify.hs b/Types/DesktopNotify.hs --- a/Types/DesktopNotify.hs +++ b/Types/DesktopNotify.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Types/Difference.hs b/Types/Difference.hs --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Types/Distribution.hs b/Types/Distribution.hs --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -2,7 +2,7 @@ - - Copyright 2013, 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Distribution where diff --git a/Types/Export.hs b/Types/Export.hs --- a/Types/Export.hs +++ b/Types/Export.hs @@ -2,7 +2,7 @@ - - Copyright 2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Export ( @@ -21,7 +21,7 @@ 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, +-- The FilePath will be relative to the top of the remote, -- and uses unix-style path separators. newtype ExportLocation = ExportLocation FilePath deriving (Show, Eq) diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.FileMatcher where diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.GitConfig ( @@ -231,7 +231,7 @@ , remoteAnnexReadOnly :: Bool , remoteAnnexVerify :: Bool , remoteAnnexCheckUUID :: Bool - , remoteAnnexExportTracking :: Maybe Git.Ref + , remoteAnnexTrackingBranch :: Maybe Git.Ref , remoteAnnexTrustLevel :: Maybe String , remoteAnnexStartCommand :: Maybe String , remoteAnnexStopCommand :: Maybe String @@ -287,8 +287,10 @@ , remoteAnnexReadOnly = getbool "readonly" False , remoteAnnexCheckUUID = getbool "checkuuid" True , remoteAnnexVerify = getbool "verify" True - , remoteAnnexExportTracking = Git.Ref - <$> notempty (getmaybe "export-tracking") + , remoteAnnexTrackingBranch = Git.Ref <$> + ( notempty (getmaybe "tracking-branch") + <|> notempty (getmaybe "export-tracking") -- old name + ) , remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel" , remoteAnnexStartCommand = notempty $ getmaybe "start-command" , remoteAnnexStopCommand = notempty $ getmaybe "stop-command" diff --git a/Types/Group.hs b/Types/Group.hs --- a/Types/Group.hs +++ b/Types/Group.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Group ( diff --git a/Types/Import.hs b/Types/Import.hs new file mode 100644 --- /dev/null +++ b/Types/Import.hs @@ -0,0 +1,50 @@ +{- git-annex import types + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.Import where + +import qualified Data.ByteString as S +import Data.Char + +import Types.Export +import Utility.QuickCheck +import Utility.FileSystemEncoding + +{- Location of content on a remote that can be imported. + - This is just an alias to ExportLocation, because both are referring to a + - location on the remote. -} +type ImportLocation = ExportLocation + +mkImportLocation :: FilePath -> ImportLocation +mkImportLocation = mkExportLocation + +fromImportLocation :: ImportLocation -> FilePath +fromImportLocation = fromExportLocation + +{- An identifier for content stored on a remote that has been imported into + - the repository. It should be reasonably short since it is stored in the + - git-annex branch. -} +newtype ContentIdentifier = ContentIdentifier S.ByteString + deriving (Eq, Ord, Show) + +instance Arbitrary ContentIdentifier where + -- Avoid non-ascii ContentIdentifiers because fully arbitrary + -- strings may not be encoded using the filesystem + -- encoding, which is normally applied to all input. + arbitrary = ContentIdentifier . encodeBS + <$> arbitrary `suchThat` all isAscii + +{- List of files that can be imported from a remote, each with some added + - information. -} +data ImportableContents info = ImportableContents + { importableContents :: [(ImportLocation, info)] + , importableHistory :: [ImportableContents info] + -- ^ Used by remotes that support importing historical versions of + -- files that are stored in them. This is equivilant to a git + -- commit history. + } + deriving (Show) diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Types/KeySource.hs b/Types/KeySource.hs --- a/Types/KeySource.hs +++ b/Types/KeySource.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.KeySource where diff --git a/Types/LockCache.hs b/Types/LockCache.hs --- a/Types/LockCache.hs +++ b/Types/LockCache.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.LockCache ( diff --git a/Types/Messages.hs b/Types/Messages.hs --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.Messages where diff --git a/Types/MetaData.hs b/Types/MetaData.hs --- a/Types/MetaData.hs +++ b/Types/MetaData.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -136,7 +136,7 @@ instance MetaSerializable MetaValue where serialize (MetaValue isset v) = serialize isset <> - if B8.any (== ' ') v || "!" `B8.isPrefixOf` v + if B8.any (`elem` [' ', '\r', '\n']) v || "!" `B8.isPrefixOf` v then "!" <> toB64' v else v deserialize b = do diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -2,7 +2,7 @@ - - Copyright 2014-2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.NumCopies ( diff --git a/Types/RefSpec.hs b/Types/RefSpec.hs --- a/Types/RefSpec.hs +++ b/Types/RefSpec.hs @@ -2,7 +2,7 @@ - - Copyright 2015 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.RefSpec where diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -2,9 +2,9 @@ - - Most things should not need this, using Types instead - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE RankNTypes #-} @@ -20,7 +20,10 @@ , unVerified , RetrievalSecurityPolicy(..) , isExportSupported + , isImportSupported , ExportActions(..) + , ImportActions(..) + , ByteSize ) where @@ -36,11 +39,13 @@ import Types.UrlContents import Types.NumCopies import Types.Export +import Types.Import import Config.Cost import Utility.Metered import Git.Types (RemoteName) import Utility.SafeCommand import Utility.Url +import Utility.DataUnits type RemoteConfigKey = String @@ -61,6 +66,8 @@ , 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 + -- check if a remote of this type is able to support import + , importSupported :: RemoteConfig -> RemoteGitConfig -> a Bool } instance Eq (RemoteTypeA a) where @@ -102,8 +109,10 @@ -- Some remotes can checkPresent without an expensive network -- operation. , checkPresentCheap :: Bool - -- Some remotes support exports of trees. + -- Some remotes support export of trees. , exportActions :: ExportActions a + -- Some remotes support import of trees. + , importActions :: ImportActions a -- Some remotes can provide additional details for whereis. , whereisKey :: Maybe (Key -> a [String]) -- Some remotes can run a fsck operation on the remote, @@ -207,6 +216,9 @@ isExportSupported :: RemoteA a -> a Bool isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r) +isImportSupported :: RemoteA a -> a Bool +isImportSupported r = importSupported (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 @@ -230,7 +242,82 @@ -- 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 + -- This may fail with False, if the file doesn't exist. + -- If the remote does not support renames, it can return Nothing. + , renameExport :: Key -> ExportLocation -> ExportLocation -> a (Maybe Bool) + } + +data ImportActions a = ImportActions + -- Finds the current set of files that are stored in the remote, + -- along with their content identifiers and size. + -- + -- May also find old versions of files that are still stored in the + -- remote. + { listImportableContents :: a (Maybe (ImportableContents (ContentIdentifier, ByteSize))) + -- Retrieves a file from the remote. Ensures that the file + -- it retrieves has the requested ContentIdentifier. + -- + -- This has to be used rather than retrieveExport + -- when a special remote supports imports, since files on such a + -- special remote can be changed at any time. + , retrieveExportWithContentIdentifier + :: ExportLocation + -> ContentIdentifier + -> FilePath + -- ^ file to write content to + -> a (Maybe Key) + -- ^ callback that generates a key from the downloaded content + -> MeterUpdate + -> a (Maybe Key) + -- Exports content to an ExportLocation, and returns the + -- ContentIdentifier corresponding to the content it stored. + -- + -- This is used rather than storeExport when a special remote + -- supports imports, since files on such a special remote can be + -- changed at any time. + -- + -- Since other things can modify the same file on the special + -- remote, this must take care to not overwrite such modifications, + -- and only overwrite a file that has one of the ContentIdentifiers + -- passed to it, unless listContents can recover an overwritten file. + -- + -- Also, since there can be concurrent writers, the implementation + -- needs to make sure that the ContentIdentifier it returns + -- corresponds to what it wrote, not to what some other writer + -- wrote. + , storeExportWithContentIdentifier + :: FilePath + -> Key + -> ExportLocation + -> [ContentIdentifier] + -- ^ old content that it's safe to overwrite + -> MeterUpdate + -> a (Maybe ContentIdentifier) + -- This is used rather than removeExport when a special remote + -- supports imports. + -- + -- It should only remove a file from the remote when it has one + -- of the ContentIdentifiers passed to it, unless listContents + -- can recover an overwritten file. + -- + -- It needs to handle races similar to storeExportWithContentIdentifier. + , removeExportWithContentIdentifier + :: Key + -> ExportLocation + -> [ContentIdentifier] + -> a Bool + -- Removes a directory from the export, but only when it's empty. + -- Used instead of removeExportDirectory when a special remote + -- supports imports. + -- + -- If the directory is not empty, it should succeed. + , removeExportDirectoryWhenEmpty :: Maybe (ExportDirectory -> a Bool) + -- Checks if the specified ContentIdentifier is exported to the + -- remote at the specified ExportLocation. + -- Throws an exception if the remote cannot be accessed. + , checkPresentExportWithContentIdentifier + :: Key + -> ExportLocation + -> [ContentIdentifier] + -> a Bool } diff --git a/Types/ScheduledActivity.hs b/Types/ScheduledActivity.hs --- a/Types/ScheduledActivity.hs +++ b/Types/ScheduledActivity.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.ScheduledActivity where diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.StoreRetrieve where diff --git a/Types/Test.hs b/Types/Test.hs --- a/Types/Test.hs +++ b/Types/Test.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2017 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Types/Transfer.hs b/Types/Transfer.hs --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE FlexibleInstances #-} diff --git a/Types/TrustLevel.hs b/Types/TrustLevel.hs --- a/Types/TrustLevel.hs +++ b/Types/TrustLevel.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE FlexibleInstances #-} diff --git a/Types/UUID.hs b/Types/UUID.hs --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} @@ -18,6 +18,7 @@ import qualified Data.Semigroup as Sem import Utility.FileSystemEncoding +import Utility.QuickCheck import qualified Utility.SimpleProtocol as Proto -- A UUID is either an arbitrary opaque string, or UUID info may be missing. @@ -81,3 +82,9 @@ instance Proto.Serializable UUID where serialize = fromUUID deserialize = Just . toUUID + +instance Arbitrary UUID where + arbitrary = frequency [(1, return NoUUID), (3, UUID <$> arb)] + where + arb = encodeBS <$> listOf1 (elements uuidchars) + uuidchars = '-' : ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] diff --git a/Types/UrlContents.hs b/Types/UrlContents.hs --- a/Types/UrlContents.hs +++ b/Types/UrlContents.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.UrlContents ( diff --git a/Types/View.hs b/Types/View.hs --- a/Types/View.hs +++ b/Types/View.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Types.View where diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -2,7 +2,7 @@ - - Copyright 2010 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Upgrade.V0 where diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Upgrade.V1 where diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Upgrade.V2 where diff --git a/Upgrade/V3.hs b/Upgrade/V3.hs --- a/Upgrade/V3.hs +++ b/Upgrade/V3.hs @@ -4,7 +4,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Upgrade.V3 (upgrade) where diff --git a/Upgrade/V4.hs b/Upgrade/V4.hs --- a/Upgrade/V4.hs +++ b/Upgrade/V4.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Upgrade.V4 where diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -2,7 +2,7 @@ - - Copyright 2015-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Upgrade.V5 where diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -5,6 +5,7 @@ - License: BSD-2-clause -} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -17,6 +18,7 @@ import Data.Time.Clock.POSIX import Data.Ratio import System.Posix.Types +import Data.List.NonEmpty (NonEmpty(..)) import Prelude {- Times before the epoch are excluded. Half with decimal and half without. -} @@ -40,6 +42,12 @@ {- File sizes are never negative. -} instance Arbitrary FileOffset where arbitrary = nonNegative arbitrarySizedIntegral + +{- Latest Quickcheck lacks this instance. -} +#if MIN_VERSION_QuickCheck(2,10,0) +instance Arbitrary l => Arbitrary (NonEmpty l) where + arbitrary = (:|) <$> arbitrary <*> arbitrary +#endif nonNegative :: (Num a, Ord a) => Gen a -> Gen a nonNegative g = g `suchThat` (>= 0) diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -28,7 +28,7 @@ viaTmp a file content = bracketIO setup cleanup use where (dir, base) = splitFileName file - template = base ++ ".tmp" + template = relatedTemplate (base ++ ".tmp") setup = do createDirectoryIfMissing True dir openTempFile dir template diff --git a/Utility/Tor.hs b/Utility/Tor.hs --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -2,7 +2,7 @@ - - Copyright 2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Utility.Tor where diff --git a/Utility/Yesod.hs b/Utility/Yesod.hs --- a/Utility/Yesod.hs +++ b/Utility/Yesod.hs @@ -4,7 +4,7 @@ - - Copyright 2012-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} 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 @@ -6,8 +6,6 @@ git annex export `treeish --to remote` -git annex export `--tracking treeish --to remote` - # DESCRIPTION Use this command to export a tree of files from a git-annex repository. @@ -45,6 +43,27 @@ not supported. See individual special remotes' documentation for details of how to enable such versioning. +The `git annex sync --content` command (and the git-annex assistant) +can also be used to export a branch to a special remote, +updating the special remote whenever the branch is changed. +To do this, you need to configure "remote..annex-tracking-branch" +to tell it what branch to track. +For example: + + git config remote.myremote.annex-tracking-branch master + git annex sync --content + +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`. + +(Some types of special remotes such as S3 with versioning may instead +let an export overwrite the modified file; then `git annex import` +will create a sequence of commits that includes the modified file, +so the overwritten modification is not lost.) + # OPTIONS * `--to=remote` @@ -53,13 +72,9 @@ * `--tracking` - This makes the export track changes that are committed to - the branch. `git annex sync --content` and the git-annex assistant - will update exports with commits made to the branch. - - This is a local configuration setting, similar to a git remote's tracking - branch. You'll need to run `git annex export --tracking` in each - repository you want the export to track. + This is a deprecated way to set "remote..annex-tracking-branch". + Instead of using this option, you should just set the git configuration + yourself. * `--fast` @@ -69,28 +84,24 @@ # EXAMPLE - git annex initremote myexport type=directory directory=/mnt/myexport \ + git annex initremote myremote type=directory directory=/mnt/myremote \ exporttree=yes encryption=none - git annex export master --to myexport + git annex export master --to myremote -After that, /mnt/myexport will contain the same tree of files as the master +After that, /mnt/myremote will contain the same tree of files as the master branch does. git mv myfile subdir/myfile git commit -m renamed - git annex export master --to myexport + git annex export master --to myremote -That updates /mnt/myexport to reflect the renamed file. +That updates /mnt/myremote to reflect the renamed file. - git annex export master:subdir --to myexport + git annex export master:subdir --to myremote -That updates /mnt/myexport, to contain only the files in the "subdir" +That updates /mnt/myremote, to contain only the files in the "subdir" directory of the master branch. - git annex export --tracking master --to myexport - -That makes myexport track changes that are committed to the master branch. - # EXPORT CONFLICTS If two different git-annex repositories are both exporting different trees @@ -115,6 +126,8 @@ [[git-annex]](1) [[git-annex-initremote]](1) + +[[git-annex-import]](1) [[git-annex-sync]](1) 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 @@ -1,16 +1,77 @@ # NAME -git-annex import - move and add files from outside git working copy +git-annex import - add files from a non-versioned directory or a special remote # SYNOPSIS -git annex import `[path ...]` +git annex import `[path ...]` | git annex import --from remote branch[:subdir] # DESCRIPTION -Moves files from somewhere outside the git working copy, and adds them to -the annex. Individual files to import can be specified. -If a directory is specified, the entire directory is imported. +This command is a way to import files from elsewhere into your git-annex +repository. It can import files from a directory into your repository, +or it can import files from a git-annex special remote. + +## IMPORTING FROM A SPECIAL REMOTE + +Importing from a special remote first downloads all new content from it, +and then constructs a git commit that reflects files that have changed on +the special remote since the last time git-annex looked at it. Merging that +commit into your repository will update it to reflect changes made on the +special remote. + +This way, something can be using the special remote for file storage, +adding files, modifying files, and deleting files, and you can track those +changes using git-annex. + +You can combine using `git annex import` to fetch changes from a special +remote with `git annex export` to send your local changes to the special +remote. + +You can only import from special remotes that were configured with +`importtree=yes` when set up with [[git-annex-initremote]](1). Only some +kinds of special remotes will let you configure them this way. + +To import from a special remote, you must specify the name of a branch. +A corresponding remote tracking branch will be updated by `git annex +import`. After that point, it's the same as if you had run a `git fetch` +from a regular git remote; you can `git merge` the changes into your +currently checked out branch. + +For example: + + git annex import master --from myremote + git merge myremote/master + +Note that you may need to pass `--allow-unrelated-histories` the first time +you `git merge` from an import. Think of this as the remote being a +separate git repository with its own files. If you first +`git annex export` files to a remote, and then `git annex import` from it, +you won't need that option. + +You can also limit the import to a subdirectory, using the +"branch:subdir" syntax. For example, if "camera" is a special remote +that accesses a camera, and you want to import those into the photos +directory, rather than to the root of your repository: + + git annex import master:photos --from camera + git merge camera/master + +The `git annex sync --content` command (and the git-annex assistant) +can also be used to import from a special remote. +To do this, you need to configure "remote..annex-tracking-branch" +to tell it what branch to track. For example: + + git config remote.myremote.annex-tracking-branch master + git annex sync --content + +## IMPORTING FROM A DIRECTORY + +When run with a path, `git annex import` moves files from somewhere outside +the git working copy, and adds them to the annex. + +Individual files to import can be specified. If a directory is specified, +the entire directory is imported. git annex import /media/camera/DCIM/* @@ -25,9 +86,11 @@ is present in the repository twice. (With all checksumming backends, including the default SHA256E, only one copy of the data will be stored.) -Several options can be used to adjust handling of duplicate files. +Several options can be used to adjust handling of duplicate files, see +`--duplicate`, `--deduplicate`, `--skip-duplicates`, `--clean-duplicates`, +and `--reinject-duplicates` documentation below. -# OPTIONS +# OPTIONS FOR IMPORTING FROM A DIRECTORY * `--duplicate` @@ -70,6 +133,8 @@ can be used to specify files to import. git annex import /dir --include='*.png' + +## COMMON OPTIONS * `--jobs=N` `-JN` 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 @@ -51,7 +51,8 @@ * `--pull`, `--no-pull` - By default, git pulls from remotes. Use --no-pull to disable all pulling. + By default, git pulls from remotes and imports from some special remotes. + Use --no-pull to disable all pulling. When `remote..annex-pull` or `remote..annex-sync` are set to false, pulling is disabled for those remotes, and using @@ -59,8 +60,8 @@ * `--push`, `--no-push` - By default, git pushes changes to remotes. - Use --no-push to disable all pushing. + By default, git pushes changes to remotes and exports to some + special remotes. Use --no-push to disable all pushing. When `remote..annex-push` or `remote..annex-sync` are set to false, or `remote..annex-readonly` is set to true, @@ -82,9 +83,12 @@ 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). + When `remote..annex-tracking-branch` is configured for a special remote + and that branch is checked out, syncing will import changes from + the remote, merge them into the branch, and export any changes that have + been committed to the branch back to the remote. See + See [[git-annex-import]](1) and [[git-annex-export]](1) for details about + how importing and exporting work. * `--content-of=path` `-C path` diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -148,7 +148,8 @@ * `import [path ...]` - Move and add files from outside git working copy into the annex. + Add files from a non-version-controlled directory or a + special remote into the annex. See [[git-annex-import]](1) for details. @@ -1266,13 +1267,24 @@ in some edge cases, where it's likely the case than an object was downloaded incorrectly, or when needed for security. +* `remote..annex-tracking-branch` + + This is for use with special remotes that support exports and imports. + + When set to eg, "master", this tells git-annex that you want the + special remote to track that branch. + + When set to eg, "master:subdir", the special remote tracks only + the subdirectory of that branch. + + `git-annex sync --content` will import changes from the remote and + merge them into the annex-tracking-branch. They also export changes + made to the branch to the remote. + * `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. + Deprecated name for `remote..annex-tracking-branch`. Will still be used + if it's configured and `remote..annex-tracking-branch` is not. * `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: 7.20190219 +Version: 7.20190322 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess @@ -630,6 +630,7 @@ Annex.GitOverlay Annex.HashObject Annex.Hook + Annex.Import Annex.Ingest Annex.Init Annex.InodeSentinal @@ -649,6 +650,7 @@ Annex.Perms Annex.Queue Annex.ReplaceFile + Annex.RemoteTrackingBranch Annex.SpecialRemote Annex.Ssh Annex.TaggedPush @@ -808,6 +810,7 @@ Config.Smudge Creds Crypto + Database.ContentIdentifier Database.Export Database.Fsck Database.Handle @@ -869,6 +872,8 @@ Logs.Chunk Logs.Chunk.Pure Logs.Config + Logs.ContentIdentifier + Logs.ContentIdentifier.Pure Logs.Difference Logs.Difference.Pure Logs.Export @@ -928,7 +933,7 @@ Remote.Helper.Chunked Remote.Helper.Chunked.Legacy Remote.Helper.Encryptable - Remote.Helper.Export + Remote.Helper.ExportImport Remote.Helper.Git Remote.Helper.Hooks Remote.Helper.Messages @@ -973,6 +978,7 @@ Types.FileMatcher Types.GitConfig Types.Group + Types.Import Types.Key Types.KeySource Types.LockCache diff --git a/git-annex.hs b/git-annex.hs --- a/git-annex.hs +++ b/git-annex.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2016 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -16,7 +16,7 @@ - '.' extra-deps: - IfElse-0.85 -- aws-0.20 +- aws-0.21.1 - bloomfilter-2.0.1.0 - tasty-1.1.0.4 - tasty-rerun-1.1.13