diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -138,6 +138,7 @@ , existinghooks :: M.Map Git.Hook.Hook Bool , desktopnotify :: DesktopNotify , workers :: [Either AnnexState (Async AnnexState)] + , activekeys :: TVar (M.Map Key ThreadId) , activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) , keysdbhandle :: Maybe Keys.DbHandle , cachedcurrentbranch :: Maybe Git.Branch @@ -147,6 +148,7 @@ newState :: GitConfig -> Git.Repo -> IO AnnexState newState c r = do emptyactiveremotes <- newMVar M.empty + emptyactivekeys <- newTVarIO M.empty o <- newMessageState sc <- newTMVarIO False return $ AnnexState @@ -192,6 +194,7 @@ , existinghooks = M.empty , desktopnotify = mempty , workers = [] + , activekeys = emptyactivekeys , activeremotes = emptyactiveremotes , keysdbhandle = Nothing , cachedcurrentbranch = Nothing diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -128,9 +128,7 @@ Just k -> do let f = keyFilename source if lockingFile cfg - then do - liftIO $ nukeFile f - addLink f k mic + then addLink f k mic else ifM isDirect ( do l <- calcRepo $ gitAnnexLink f k diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -107,7 +107,8 @@ -- KDE home <- myHomeDir - let kdeServiceMenusdir = home ".kde" "share" "kde4" "services" "ServiceMenus" + userdata <- userDataDir + let kdeServiceMenusdir = userdata "kservices5" "ServiceMenus" createDirectoryIfMissing True kdeServiceMenusdir writeFile (kdeServiceMenusdir "git-annex.desktop") (kdeDesktopFile actions) diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,24 @@ +git-annex (6.20171018) unstable; urgency=medium + + * add: Replace work tree file atomically on systems supporting hard + links. Avoids a window where interrupting an add could result in + the file being moved into the annex, with no symlink yet created. + * webdav: Avoid unncessisarily creating the collection at the top + of the repository when storing files there, since that collection + is created by initremote. + (This seems to work around some brokenness of the box.com webdav + server, which caused uploads to be very slow or sometimes fail.) + * webdav: Make --debug show all webdav operations. + * get -J/move -J/copy -J/mirror -J/sync -J: Avoid "transfer already in + progress" errors when two files use the same key. + * Konqueror desktop file location changed to one used by plasma 5. + Thanks, Félix Sipma. + * Avoid repeated checking that files passed on the command line exist. + * Fix build with aws-0.17. + * stack.yaml: Update to lts-9.9. + + -- Joey Hess Wed, 18 Oct 2017 15:40:06 -0400 + git-annex (6.20171003) unstable; urgency=medium * webdav: Improve error message for failed request to include the request diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -1,6 +1,6 @@ {- git-annex command-line actions - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -18,9 +18,12 @@ import Types.Messages import Remote.List +import Control.Concurrent import Control.Concurrent.Async +import Control.Concurrent.STM import Control.Exception (throwIO) import Data.Either +import qualified Data.Map.Strict as M #ifdef WITH_CONCURRENTOUTPUT import qualified System.Console.Regions as Regions @@ -177,3 +180,36 @@ #else allowConcurrentOutput = id #endif + +{- Ensures that only one thread processes a key at a time. + - Other threads will block until it's done. -} +onlyActionOn :: Key -> CommandStart -> CommandStart +onlyActionOn k a = onlyActionOn' k run + where + run = do + -- Run whole action, not just start stage, so other threads + -- block until it's done. + r <- callCommandAction' a + case r of + Nothing -> return Nothing + Just r' -> return $ Just $ return $ Just $ return r' + +onlyActionOn' :: Key -> Annex a -> Annex a +onlyActionOn' k a = go =<< Annex.getState Annex.concurrency + where + go NonConcurrent = a + go (Concurrent _) = do + tv <- Annex.getState Annex.activekeys + bracket (setup tv) id (const a) + setup tv = liftIO $ do + mytid <- myThreadId + atomically $ do + m <- readTVar tv + case M.lookup k m of + Just tid + | tid /= mytid -> retry + | otherwise -> return (return ()) + Nothing -> do + writeTVar tv $! M.insert k mytid m + return $ liftIO $ atomically $ + modifyTVar tv $ M.delete k diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -32,22 +32,20 @@ import Annex.CatFile import Annex.Content -withFilesInGit :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek -withFilesInGit a params = seekActions $ prepFiltered a $ - seekHelper LsFiles.inRepo params +withFilesInGit :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek +withFilesInGit a l = seekActions $ prepFiltered a $ + seekHelper LsFiles.inRepo l -withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek -withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force) - ( withFilesInGit a params - , if null params +withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek +withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force) + ( withFilesInGit a l + , if null l then giveup needforce - else do - checkFileOrDirectoryExists params - seekActions $ prepFiltered a (getfiles [] params) + else seekActions $ prepFiltered a (getfiles [] l) ) where getfiles c [] = return (reverse c) - getfiles c (p:ps) = do + getfiles c ((WorkTreeItem p):ps) = do (fs, cleanup) <- inRepo $ LsFiles.inRepo [p] case fs of [f] -> do @@ -58,24 +56,25 @@ getfiles c ps _ -> giveup needforce -withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek -withFilesNotInGit skipdotfiles a params +withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek +withFilesNotInGit skipdotfiles a l | skipdotfiles = do {- dotfiles are not acted on unless explicitly listed -} files <- filter (not . dotfile) <$> - seekunless (null ps && not (null params)) ps + seekunless (null ps && not (null l)) ps dotfiles <- seekunless (null dotps) dotps go (files++dotfiles) - | otherwise = go =<< seekunless False params + | otherwise = go =<< seekunless False l where - (dotps, ps) = partition dotfile params + (dotps, ps) = partition (\(WorkTreeItem f) -> dotfile f) l seekunless True _ = return [] - seekunless _ l = do + seekunless _ l' = do force <- Annex.getState Annex.force g <- gitRepo - liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g - go l = seekActions $ prepFiltered a $ - return $ concat $ segmentPaths params l + liftIO $ Git.Command.leaveZombie + <$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> f) l') g + go fs = seekActions $ prepFiltered a $ + return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs withFilesInRefs :: (FilePath -> Key -> CommandStart) -> [Git.Ref] -> CommandSeek withFilesInRefs a = mapM_ go @@ -121,14 +120,14 @@ pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek -withFilesToBeCommitted a params = seekActions $ prepFiltered a $ - seekHelper LsFiles.stagedNotDeleted params +withFilesToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek +withFilesToBeCommitted a l = seekActions $ prepFiltered a $ + seekHelper LsFiles.stagedNotDeleted l -withFilesOldUnlocked :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek +withFilesOldUnlocked :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesOldUnlocked = withFilesOldUnlocked' LsFiles.typeChanged -withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek +withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesOldUnlockedToBeCommitted = withFilesOldUnlocked' LsFiles.typeChangedStaged {- Unlocked files before v6 have changed type from a symlink to a regular file. @@ -136,23 +135,23 @@ - Furthermore, unlocked files used to be a git-annex symlink, - not some other sort of symlink. -} -withFilesOldUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek -withFilesOldUnlocked' typechanged a params = seekActions $ +withFilesOldUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek +withFilesOldUnlocked' typechanged a l = seekActions $ prepFiltered a unlockedfiles where - unlockedfiles = filterM isOldUnlocked =<< seekHelper typechanged params + unlockedfiles = filterM isOldUnlocked =<< seekHelper typechanged l isOldUnlocked :: FilePath -> Annex Bool isOldUnlocked f = liftIO (notSymlink f) <&&> (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) {- Finds files that may be modified. -} -withFilesMaybeModified :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek +withFilesMaybeModified :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesMaybeModified a params = seekActions $ prepFiltered a $ seekHelper LsFiles.modified params withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek -withKeys a params = seekActions $ return $ map (a . parse) params +withKeys a l = seekActions $ return $ map (a . parse) l where parse p = fromMaybe (giveup "bad key") $ file2key p @@ -172,8 +171,8 @@ :: Maybe KeyOptions -> Bool -> (Key -> ActionItem -> CommandStart) - -> (CmdParams -> CommandSeek) - -> CmdParams + -> ([WorkTreeItem] -> CommandSeek) + -> [WorkTreeItem] -> CommandSeek withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction where @@ -187,8 +186,8 @@ :: Maybe KeyOptions -> Bool -> Annex (Key -> ActionItem -> Annex ()) - -> (CmdParams -> CommandSeek) - -> CmdParams + -> ([WorkTreeItem] -> CommandSeek) + -> [WorkTreeItem] -> CommandSeek withKeyOptions' ko auto mkkeyaction fallbackaction params = do bare <- fromRepo Git.repoIsLocalBare @@ -243,17 +242,27 @@ seekActions :: Annex [CommandStart] -> Annex () seekActions gen = mapM_ commandAction =<< gen -seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] -seekHelper a params = do - checkFileOrDirectoryExists params - inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered params) +seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [WorkTreeItem] -> Annex [FilePath] +seekHelper a l = inRepo $ \g -> + concat . concat <$> forM (segmentXargsOrdered l') (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g)) + where + l' = map (\(WorkTreeItem f) -> f) l -checkFileOrDirectoryExists :: [FilePath] -> Annex () -checkFileOrDirectoryExists ps = forM_ ps $ \p -> - unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ do - toplevelWarning False (p ++ " not found") - Annex.incError +-- An item in the work tree, which may be a file or a directory. +newtype WorkTreeItem = WorkTreeItem FilePath + +-- Many git commands seek work tree items matching some criteria, +-- and silently skip over anything that does not exist. But users expect +-- an error message when one of the files they provided as a command-line +-- parameter doesn't exist, so this checks that each exists. +workTreeItems :: CmdParams -> Annex [WorkTreeItem] +workTreeItems ps = do + forM_ ps $ \p -> + unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ do + toplevelWarning False (p ++ " not found") + Annex.incError + return (map WorkTreeItem ps) notSymlink :: FilePath -> IO Bool notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -63,7 +63,8 @@ giveup "--update --batch is not supported" | otherwise -> batchFiles gofile NoBatch -> do - let go a = a gofile (addThese o) + l <- workTreeItems (addThese o) + let go a = a gofile l unless (updateOnly o) $ go (withFilesNotInGit (not $ includeDotFiles o)) go withFilesMaybeModified diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -43,7 +43,7 @@ (Command.Move.keyOptions $ moveOptions o) (autoMode o) (Command.Move.startKey (moveOptions o) False) (withFilesInGit go) - (Command.Move.moveFiles $ moveOptions o) + =<< workTreeItems (Command.Move.moveFiles $ moveOptions o) {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -58,7 +58,7 @@ NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (startKeys o) (withFilesInGit go) - (dropFiles o) + =<< workTreeItems (dropFiles o) where go = whenAnnexed $ start o diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -50,7 +50,7 @@ seek :: FindOptions -> CommandSeek seek o = case batchOption o of - NoBatch -> withFilesInGit go (findThese o) + NoBatch -> withFilesInGit go =<< workTreeItems (findThese o) Batch -> batchFiles go where go = whenAnnexed $ start o diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -34,7 +34,8 @@ ( return FixAll , return FixSymlinks ) - flip withFilesInGit ps $ whenAnnexed $ start fixwhat + l <- workTreeItems ps + flip withFilesInGit l $ whenAnnexed $ start fixwhat data FixWhat = FixSymlinks | FixAll diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -93,7 +93,7 @@ withKeyOptions (keyOptions o) False (\k ai -> startKey from i k ai =<< getNumCopies) (withFilesInGit $ whenAnnexed $ start from i) - (fsckFiles o) + =<< workTreeItems (fsckFiles o) cleanupIncremental i void $ tryIO $ recordActivity Fsck u diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -46,7 +46,7 @@ NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (startKeys from) (withFilesInGit go) - (getFiles o) + =<< workTreeItems (getFiles o) start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart start o from file key = start' expensivecheck from key afile (mkActionItem afile) @@ -62,8 +62,8 @@ start' (return True) from key (AssociatedFile Nothing) ai start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart -start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $ - stopUnless expensivecheck $ +start' expensivecheck from key afile ai = onlyActionOn key $ + stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $ case from of Nothing -> go $ perform key afile Just src -> diff --git a/Command/List.hs b/Command/List.hs --- a/Command/List.hs +++ b/Command/List.hs @@ -44,7 +44,8 @@ seek o = do list <- getList o printHeader list - withFilesInGit (whenAnnexed $ start list) (listThese o) + withFilesInGit (whenAnnexed $ start list) + =<< workTreeItems (listThese o) getList :: ListOptions -> Annex [(UUID, RemoteName, TrustLevel)] getList o diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -29,12 +29,14 @@ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = ifM versionSupportsUnlockedPointers - ( withFilesInGit (whenAnnexed startNew) ps - , do - withFilesOldUnlocked startOld ps - withFilesOldUnlockedToBeCommitted startOld ps - ) +seek ps = do + l <- workTreeItems ps + ifM versionSupportsUnlockedPointers + ( withFilesInGit (whenAnnexed startNew) l + , do + withFilesOldUnlocked startOld l + withFilesOldUnlockedToBeCommitted startOld l + ) startNew :: FilePath -> Key -> CommandStart startNew file key = ifM (isJust <$> isAnnexLink file) diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -91,7 +91,8 @@ zone <- liftIO getCurrentTimeZone let outputter = mkOutputter m zone o case (logFiles o, allOption o) of - (fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) fs + (fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) + =<< workTreeItems fs ([], True) -> commandAction (startAll o outputter) (_, True) -> giveup "Cannot specify both files and --all" diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -81,7 +81,7 @@ withKeyOptions (keyOptions o) False (startKeys c o) (seeker $ whenAnnexed $ start c o) - (forFiles o) + =<< workTreeItems (forFiles o) Batch -> withMessageState $ \s -> case outputType s of JSONOutput _ -> batchInput parseJSONInput $ commandAction . startBatch diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -26,7 +26,7 @@ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek = withFilesInGit $ whenAnnexed start +seek ps = withFilesInGit (whenAnnexed start) =<< workTreeItems ps start :: FilePath -> Key -> CommandStart start file key = do @@ -74,7 +74,7 @@ checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked afile finish newkey = ifM (Command.ReKey.linkKey file oldkey newkey) ( do - copyMetaData oldkey newkey + _ <- copyMetaData oldkey newkey -- If the old key had some associated urls, record them for -- the new key as well. urls <- getUrls oldkey diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -45,7 +45,7 @@ withKeyOptions (keyOptions o) False (startKey o (AssociatedFile Nothing)) (withFilesInGit $ whenAnnexed $ start o) - (mirrorFiles o) + =<< workTreeItems (mirrorFiles o) start :: MirrorOptions -> FilePath -> Key -> CommandStart start o file k = startKey o afile k (mkActionItem afile) @@ -53,7 +53,7 @@ afile = AssociatedFile (Just file) startKey :: MirrorOptions -> AssociatedFile -> Key -> ActionItem -> CommandStart -startKey o afile key ai = case fromToOptions o of +startKey o afile key ai = onlyActionOn key $ case fromToOptions o of ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key) ( Command.Move.toStart False afile key ai =<< getParsed r , do diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -63,7 +63,7 @@ NoBatch -> withKeyOptions (keyOptions o) False (startKey o True) (withFilesInGit go) - (moveFiles o) + =<< workTreeItems (moveFiles o) start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart start o move f k = start' o move afile k (mkActionItem afile) @@ -74,7 +74,7 @@ startKey o move = start' o move (AssociatedFile Nothing) start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart -start' o move afile key ai = +start' o move afile key ai = onlyActionOn key $ case fromToOptions o of Right (FromRemote src) -> checkFailedTransferDirection ai Download $ diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -131,7 +131,7 @@ giveup "Sorry, multicast send cannot be done from a direct mode repository." showStart "generating file list" "" - fs' <- seekHelper LsFiles.inRepo fs + fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs matcher <- Limit.getMatcher let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $ liftIO $ hPutStrLn h o diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -49,15 +49,16 @@ giveup "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit." void $ liftIO cleanup , do + l <- workTreeItems ps -- fix symlinks to files being committed - flip withFilesToBeCommitted ps $ \f -> + flip withFilesToBeCommitted l $ \f -> maybe stop (Command.Fix.start Command.Fix.FixSymlinks f) =<< isAnnexLink f -- inject unlocked files into the annex -- (not needed when repo version uses -- unlocked pointer files) unlessM versionSupportsUnlockedPointers $ - withFilesOldUnlockedToBeCommitted startInjectUnlocked ps + withFilesOldUnlockedToBeCommitted startInjectUnlocked l ) runAnnexHook preCommitAnnexHook -- committing changes to a view updates metadata diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -576,7 +576,10 @@ mvar <- liftIO newEmptyMVar bloom <- case keyOptions o of Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar []) - _ -> seekworktree mvar (contentOfOption o) (const noop) >> pure Nothing + _ -> do + l <- workTreeItems (contentOfOption o) + seekworktree mvar l (const noop) + pure Nothing withKeyOptions' (keyOptions o) False (return (seekkeys mvar bloom)) (const noop) @@ -606,7 +609,7 @@ - Returns True if any file transfers were made. -} syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool -syncFile ebloom rs af k = do +syncFile ebloom rs af k = onlyActionOn' k $ do locs <- Remote.keyLocations k let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -30,7 +30,8 @@ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek = wrapUnannex . (withFilesInGit $ whenAnnexed start) +seek ps = wrapUnannex $ + (withFilesInGit $ whenAnnexed start) =<< workTreeItems ps wrapUnannex :: Annex a -> Annex a wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect) diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -40,9 +40,10 @@ seek :: CmdParams -> CommandSeek seek ps = do - withFilesNotInGit False (whenAnnexed startCheckIncomplete) ps + l <- workTreeItems ps + withFilesNotInGit False (whenAnnexed startCheckIncomplete) l Annex.changeState $ \s -> s { Annex.fast = True } - withFilesInGit (whenAnnexed Command.Unannex.start) ps + withFilesInGit (whenAnnexed Command.Unannex.start) l finish {- git annex symlinks that are not checked into git could be left by an diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -30,7 +30,7 @@ command n SectionCommon d paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek = withFilesInGit $ whenAnnexed start +seek ps = withFilesInGit (whenAnnexed start) =<< workTreeItems ps {- Before v6, the unlock subcommand replaces the symlink with a copy of - the file's content. In v6 and above, it converts the file from a symlink diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -44,7 +44,7 @@ withKeyOptions (keyOptions o) False (startKeys m) (withFilesInGit go) - (whereisFiles o) + =<< workTreeItems (whereisFiles o) start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart start remotemap file key = startKeys remotemap key (mkActionItem afile) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -108,7 +108,6 @@ -- due to permissions problems, races, etc. void $ tryIO $ do mode <- annexFileMode - let lck = transferLockFile tfile r <- tryLockExclusive (Just mode) lck case r of Just lockhandle -> liftIO $ do diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -497,6 +497,9 @@ Just creds -> do awscreds <- liftIO $ genCredentials creds let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper +#if MIN_VERSION_aws(0,17,0) + Nothing +#endif bracketIO (newManager managerSettings) closeManager $ \mgr -> a $ Just $ S3Handle mgr awscfg s3cfg Nothing -> a Nothing diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -20,6 +20,8 @@ import Network.HTTP.Types import System.IO.Error import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO) +import System.Log.Logger (debugM) import Annex.Common import Types.Remote @@ -130,12 +132,14 @@ storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO () storeHelper dav tmp dest reqbody = do maybe noop (void . mkColRecursive) (locationParent tmp) + debugDav $ "putContent " ++ tmp inLocation tmp $ putContentM' (contentType, reqbody) finalizeStore dav tmp dest finalizeStore :: DavHandle -> DavLocation -> DavLocation -> DAVT IO () finalizeStore dav tmp dest = do + debugDav $ "delContent " ++ dest inLocation dest $ void $ safely $ delContentM maybe noop (void . mkColRecursive) (locationParent dest) moveDAV (baseURL dav) tmp dest @@ -150,8 +154,10 @@ goDAV dav $ retrieveHelper (keyLocation k) d p retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO () -retrieveHelper loc d p = inLocation loc $ - withContentM $ httpBodyRetriever d p +retrieveHelper loc d p = do + debugDav $ "retrieve " ++ loc + inLocation loc $ + withContentM $ httpBodyRetriever d p remove :: Maybe DavHandle -> Remover remove Nothing _ = return False @@ -162,6 +168,7 @@ removeHelper :: DavLocation -> DAVT IO Bool removeHelper d = do + debugDav $ "delContent " ++ d v <- safely $ inLocation d delContentM case v of Just _ -> return True @@ -205,8 +212,10 @@ removeHelper (exportLocation loc) removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool -removeExportDirectoryDav mh dir = runExport mh $ \_dav -> - safely (inLocation (fromExportDirectory dir) delContentM) +removeExportDirectoryDav mh dir = runExport mh $ \_dav -> do + let d = fromExportDirectory dir + debugDav $ "delContent " ++ d + safely (inLocation d delContentM) >>= maybe (return False) (const $ return True) renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool @@ -295,14 +304,16 @@ mkColRecursive d = go =<< existsDAV d where go (Right True) = return True - go _ = ifM (inLocation d mkCol) - ( return True - , do - case locationParent d of - Nothing -> makeParentDirs - Just parent -> void (mkColRecursive parent) - inLocation d mkCol - ) + go _ = do + debugDav $ "mkCol " ++ d + ifM (inLocation d mkCol) + ( return True + , do + case locationParent d of + Nothing -> makeParentDirs + Just parent -> void (mkColRecursive parent) + inLocation d mkCol + ) getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair) getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u) @@ -322,12 +333,16 @@ throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing moveDAV :: URLString -> DavLocation -> DavLocation -> DAVT IO () -moveDAV baseurl src dest = inLocation src $ moveContentM newurl +moveDAV baseurl src dest = do + debugDav $ "moveContent " ++ src ++ " " ++ newurl + inLocation src $ moveContentM (B8.fromString newurl) where - newurl = B8.fromString (locationUrl baseurl dest) + newurl = locationUrl baseurl dest existsDAV :: DavLocation -> DAVT IO (Either String Bool) -existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) +existsDAV l = do + debugDav $ "getProps " ++ l + inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) where check = do -- Some DAV services only support depth of 1, and @@ -415,6 +430,7 @@ where storehttp l b' = void $ goDAV dav $ do maybe noop (void . mkColRecursive) (locationParent l) + debugDav $ "putContent " ++ l inLocation l $ putContentM (contentType, b') storer locs = Legacy.storeChunked chunksize locs storehttp b recorder l s = storehttp l (L8.fromString s) @@ -428,7 +444,8 @@ retrieveLegacyChunked dav = fileRetriever $ \d k p -> liftIO $ withStoredFilesLegacyChunked k dav onerr $ \locs -> Legacy.meteredWriteFileChunks p d locs $ \l -> - goDAV dav $ + goDAV dav $ do + debugDav $ "getContent " ++ l inLocation l $ snd <$> getContentM where @@ -462,7 +479,8 @@ -> IO a withStoredFilesLegacyChunked k dav onerr a = do let chunkcount = keyloc ++ Legacy.chunkCount - v <- goDAV dav $ safely $ + v <- goDAV dav $ safely $ do + debugDav $ "getContent " ++ chunkcount inLocation chunkcount $ snd <$> getContentM case v of @@ -475,3 +493,6 @@ else a chunks where keyloc = keyLocation k + +debugDav :: MonadIO m => String -> DAVT m () +debugDav msg = liftIO $ debugM "WebDAV" msg diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -58,10 +58,11 @@ locationParent :: String -> Maybe String locationParent loc - | loc `elem` tops = Nothing - | otherwise = Just (takeDirectory loc) + | loc `elem` tops || parent `elem` tops = Nothing + | otherwise = Just parent where tops = ["/", "", "."] + parent = takeDirectory loc locationUrl :: URLString -> DavLocation -> URLString locationUrl baseurl loc = baseurl loc diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20171003 +Version: 6.20171018 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -17,10 +17,10 @@ packages: - '.' extra-deps: -- aws-0.16 +- aws-0.17.1 - bloomfilter-2.0.1.0 - torrent-10000.1.1 - yesod-default-1.2.0 explicit-setup-deps: git-annex: true -resolver: lts-8.13 +resolver: lts-9.9