diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -139,6 +139,7 @@ , activeremotes :: MVar (S.Set (Types.Remote.RemoteA Annex)) , keysdbhandle :: Maybe Keys.DbHandle , cachedcurrentbranch :: Maybe Git.Branch + , cachedgitenv :: Maybe [(String, String)] } newState :: GitConfig -> Git.Repo -> IO AnnexState @@ -189,6 +190,7 @@ , activeremotes = emptyactiveremotes , keysdbhandle = Nothing , cachedcurrentbranch = Nothing + , cachedgitenv = Nothing } {- Makes an Annex state object for the specified git repo. @@ -241,10 +243,10 @@ mvar <- ask liftIO $ modifyMVar_ mvar $ return . modifier -withState :: (AnnexState -> (AnnexState, b)) -> Annex b +withState :: (AnnexState -> IO (AnnexState, b)) -> Annex b withState modifier = do mvar <- ask - liftIO $ modifyMVar mvar $ return . modifier + liftIO $ modifyMVar mvar modifier {- Sets a flag to True -} setFlag :: String -> Annex () diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -49,6 +49,11 @@ h <- catFileHandle liftIO $ Git.CatFile.catObject h ref +catObjectMetaData :: Git.Ref -> Annex (Maybe (Integer, ObjectType)) +catObjectMetaData ref = do + h <- catFileHandle + liftIO $ Git.CatFile.catObjectMetaData h ref + catTree :: Git.Ref -> Annex [(FilePath, FileMode)] catTree ref = do h <- catFileHandle @@ -83,13 +88,20 @@ - nothing is using the handles, eg at shutdown. -} catFileStop :: Annex () catFileStop = do - m <- Annex.withState $ \s -> + m <- Annex.withState $ pure . \s -> (s { Annex.catfilehandles = M.empty }, Annex.catfilehandles s) liftIO $ mapM_ Git.CatFile.catFileStop (M.elems m) {- From ref to a symlink or a pointer file, get the key. -} catKey :: Ref -> Annex (Maybe Key) -catKey ref = parseLinkOrPointer <$> catObject ref +catKey ref = go =<< catObjectMetaData ref + where + go (Just (sz, _)) + -- Avoid catting large files, that cannot be symlinks or + -- pointer files, which would require buffering their + -- content in memory, as well as a lot of IO. + | sz <= maxPointerSz = parseLinkOrPointer <$> catObject ref + go _ = return Nothing {- Gets a symlink target. -} catSymLinkTarget :: Sha -> Annex String diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -14,6 +14,7 @@ dirHashes, hashDirMixed, hashDirLower, + display_32bits_as_dir ) where import Data.Bits @@ -74,7 +75,7 @@ -} display_32bits_as_dir :: Word32 -> String display_32bits_as_dir w = trim $ swap_pairs cs - where + where -- Need 32 characters to use. To avoid inaverdently making -- a real word, use letters that appear less frequently. chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF" diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -22,9 +22,28 @@ withIndexFile f a = do f' <- liftIO $ indexEnvVal f withAltRepo - (\g -> addGitEnv g indexEnv f') + (usecachedgitenv $ \g -> liftIO $ addGitEnv g indexEnv f') (\g g' -> g' { gitEnv = gitEnv g }) a + where + -- This is an optimisation. Since withIndexFile is run repeatedly, + -- and addGitEnv uses the slow copyGitEnv when gitEnv is Nothing, + -- we cache the copied environment the first time, and reuse it in + -- subsequent calls. + -- + -- (This could be done at another level; eg when creating the + -- Git object in the first place, but it's more efficient to let + -- the enviroment be inherited in all calls to git where it + -- does not need to be modified.) + usecachedgitenv m g = case gitEnv g of + Just _ -> m g + Nothing -> do + e <- Annex.withState $ \s -> case Annex.cachedgitenv s of + Nothing -> do + e <- copyGitEnv + return (s { Annex.cachedgitenv = Just e }, e) + Just e -> return (s, e) + m (g { gitEnv = Just e }) {- Runs an action using a different git work tree. - @@ -52,7 +71,7 @@ withWorkTreeRelated :: FilePath -> Annex a -> Annex a withWorkTreeRelated d = withAltRepo modrepo unmodrepo where - modrepo g = do + modrepo g = liftIO $ do g' <- addGitEnv g "GIT_COMMON_DIR" =<< absPath (localGitDir g) g'' <- addGitEnv g' "GIT_DIR" d return (g'' { gitEnvOverridesGitDir = True }) @@ -62,7 +81,7 @@ } withAltRepo - :: (Repo -> IO Repo) + :: (Repo -> Annex Repo) -- ^ modify Repo -> (Repo -> Repo -> Repo) -- ^ undo modifications; first Repo is the original and second @@ -71,7 +90,7 @@ -> Annex a withAltRepo modrepo unmodrepo a = do g <- gitRepo - g' <- liftIO $ modrepo g + g' <- modrepo g q <- Annex.Queue.get v <- tryNonAsync $ do Annex.changeState $ \s -> s diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -93,7 +93,8 @@ Database.Keys.scanAssociatedFiles v <- checkAdjustedClone case v of - NeedUpgradeForAdjustedClone -> void $ upgrade True + NeedUpgradeForAdjustedClone -> + void $ upgrade True versionForAdjustedClone InAdjustedClone -> return () NotInAdjustedClone -> ifM (crippledFileSystem <&&> (not <$> isBareRepo)) diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -26,7 +26,6 @@ import Utility.FileMode import qualified Data.ByteString.Lazy as L -import Data.Int type LinkTarget = String @@ -137,7 +136,8 @@ - Only looks at the first line, as pointer files can have subsequent - lines. -} parseLinkOrPointer :: L.ByteString -> Maybe Key -parseLinkOrPointer = parseLinkOrPointer' . decodeBS . L.take maxPointerSz +parseLinkOrPointer = parseLinkOrPointer' + . decodeBS . L.take (fromIntegral maxPointerSz) where {- Want to avoid buffering really big files in git into @@ -146,7 +146,7 @@ - 8192 bytes is plenty for a pointer to a key. - Pad some more to allow for any pointer files that might have - lines after the key explaining what the file is used for. -} -maxPointerSz :: Int64 +maxPointerSz :: Integer maxPointerSz = 81920 parseLinkOrPointer' :: String -> Maybe Key diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -452,15 +452,25 @@ - can cause existing objects to get lost. -} keyFile :: Key -> FilePath -keyFile key = replace "/" "%" $ replace ":" "&c" $ - replace "%" "&s" $ replace "&" "&a" $ key2file key +keyFile = concatMap esc . key2file + where + esc '&' = "&a" + esc '%' = "&s" + esc ':' = "&c" + esc '/' = "%" + esc c = [c] {- Reverses keyFile, converting a filename fragment (ie, the basename of - the symlink target) into a key. -} fileKey :: FilePath -> Maybe Key -fileKey file = file2key $ - replace "&a" "&" $ replace "&s" "%" $ - replace "&c" ":" $ replace "%" "/" file +fileKey = file2key . unesc [] + where + unesc r [] = reverse r + unesc r ('%':cs) = unesc ('/':r) cs + unesc r ('&':'c':cs) = unesc (':':r) cs + unesc r ('&':'s':cs) = unesc ('%':r) cs + unesc r ('&':'a':cs) = unesc ('&':r) cs + unesc r (c:cs) = unesc (c:r) cs {- for quickcheck -} prop_isomorphic_fileKey :: String -> Bool diff --git a/Annex/Version.hs b/Annex/Version.hs --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -22,7 +22,10 @@ latestVersion = "6" supportedVersions :: [Version] -supportedVersions = ["5", "6"] +supportedVersions = ["3", "5", "6"] + +versionForAdjustedClone :: Version +versionForAdjustedClone = "6" upgradableVersions :: [Version] #ifndef mingw32_HOST_OS diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -30,7 +30,7 @@ import qualified Data.Text as T getDaemonStatus :: Assistant DaemonStatus -getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle +getDaemonStatus = (atomically . readTVar) <<~ daemonStatusHandle modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant () modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ()) @@ -40,8 +40,8 @@ dstatus <- getAssistant daemonStatusHandle liftIO $ do (s, b) <- atomically $ do - r@(!s, _) <- a <$> takeTMVar dstatus - putTMVar dstatus s + r@(!s, _) <- a <$> readTVar dstatus + writeTVar dstatus s return r sendNotification $ changeNotifier s return b @@ -102,7 +102,7 @@ flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus transfers <- M.fromList <$> getTransfers addsync <- calcSyncRemotes - liftIO $ atomically $ newTMVar $ addsync $ status + liftIO $ atomically $ newTVar $ addsync $ status { scanComplete = False , sanityCheckRunning = False , currentTransfers = transfers @@ -162,14 +162,14 @@ - to the caller. -} adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM () adjustTransfersSTM dstatus a = do - s <- takeTMVar dstatus + s <- readTVar dstatus let !v = a (currentTransfers s) - putTMVar dstatus $ s { currentTransfers = v } + writeTVar dstatus $ s { currentTransfers = v } {- Checks if a transfer is currently running. -} checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool checkRunningTransferSTM dstatus t = M.member t . currentTransfers - <$> readTMVar dstatus + <$> readTVar dstatus {- Alters a transfer's info, if the transfer is in the map. -} alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant () @@ -207,14 +207,14 @@ notifyTransfer = do dstatus <- getAssistant daemonStatusHandle liftIO $ sendNotification - =<< transferNotifier <$> atomically (readTMVar dstatus) + =<< transferNotifier <$> atomically (readTVar dstatus) {- Send a notification when alerts are changed. -} notifyAlert :: Assistant () notifyAlert = do dstatus <- getAssistant daemonStatusHandle liftIO $ sendNotification - =<< alertNotifier <$> atomically (readTMVar dstatus) + =<< alertNotifier <$> atomically (readTVar dstatus) {- Returns the alert's identifier, which can be used to remove it. -} addAlert :: Alert -> Assistant AlertId diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -86,8 +86,7 @@ type TransferMap = M.Map Transfer TransferInfo -{- This TMVar is never left empty, so accessing it will never block. -} -type DaemonStatusHandle = TMVar DaemonStatus +type DaemonStatusHandle = TVar DaemonStatus newDaemonStatus :: IO DaemonStatus newDaemonStatus = DaemonStatus diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs --- a/Assistant/Types/TransferrerPool.hs +++ b/Assistant/Types/TransferrerPool.hs @@ -13,8 +13,7 @@ import Control.Concurrent.STM hiding (check) -{- This TMVar is never left empty. -} -type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem]) +type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem]) type CheckTransferrer = IO Bool type MkCheckTransferrer = IO (IO Bool) @@ -31,24 +30,22 @@ } newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool -newTransferrerPool c = newTMVarIO (c, []) +newTransferrerPool c = newTVarIO (c, []) popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int) popTransferrerPool p = do - (c, l) <- takeTMVar p + (c, l) <- readTVar p case l of - [] -> do - putTMVar p (c, []) - return (Nothing, 0) + [] -> return (Nothing, 0) (i:is) -> do - putTMVar p (c, is) + writeTVar p (c, is) return $ (Just i, length is) pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM () pushTransferrerPool p i = do - (c, l) <- takeTMVar p + (c, l) <- readTVar p let l' = i:l - putTMVar p (c, l') + writeTVar p (c, l') {- Note that making a CheckTransferrer may allocate resources, - such as a NotificationHandle, so it's important that the returned @@ -56,12 +53,12 @@ - garbage collected. -} mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem mkTransferrerPoolItem p t = do - mkcheck <- atomically $ fst <$> readTMVar p + mkcheck <- atomically $ fst <$> readTVar p check <- mkcheck return $ TransferrerPoolItem (Just t) check checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer checkNetworkConnections dstatushandle = do - dstatus <- atomically $ readTMVar dstatushandle + dstatus <- atomically $ readTVar dstatushandle h <- newNotificationHandle False (networkConnectedNotifier dstatus) return $ not <$> checkNotification h diff --git a/Build/BundledPrograms.hs b/Build/BundledPrograms.hs --- a/Build/BundledPrograms.hs +++ b/Build/BundledPrograms.hs @@ -91,6 +91,8 @@ -- used to unpack the tarball when upgrading , Just "gunzip" , Just "tar" + -- used by runshell to generate locales + , Just "localedef" #endif -- nice, ionice, and nocache are not included in the bundle; -- we rely on the system's own version, which may better match diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs --- a/Build/LinuxMkLibs.hs +++ b/Build/LinuxMkLibs.hs @@ -5,8 +5,6 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Main where import System.Environment @@ -73,18 +71,6 @@ [ "#!/bin/sh" , "GIT_ANNEX_PROGRAMPATH=\"$0\"" , "export GIT_ANNEX_PROGRAMPATH" -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if ! MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) -#define NEED_LOCPATH_WORKAROUND -#endif -#else -#define NEED_LOCPATH_WORKAROUND -#endif -#ifdef NEED_LOCPATH_WORKAROUND - -- workaround for https://ghc.haskell.org/trac/ghc/ticket/7695 - , "LOCPATH=/dev/null" - , "export LOCPATH" -#endif , "exec \"$GIT_ANNEX_DIR/" ++ exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ base ++ "/" ++ base ++ "\" \"$@\"" ] modifyFileMode exe $ addModes executeModes diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,36 @@ +git-annex (6.20161012) unstable; urgency=medium + + * Optimisations to time it takes git-annex to walk working tree and find + files to work on. Sped up by around 18%. + * Optimisations to git-annex branch query and setting, avoiding repeated + copies of the environment. Speeds up commands like + "git-annex find --in remote" by over 50%. + * Optimised git-annex branch log file timestamp parsing. + * Add "total-size" field to --json-progress output. + * Make --json-progress output be shown even when the size of a object + is not known. + * Multiple external special remote processes for the same remote will be + started as needed when using -J. This should not beak any existing + external special remotes, because running multiple git-annex commands + at the same time could already start multiple processes for the same + external special remotes. + * Linux standalone: Include locale files in the bundle, and generate + locale definition files for the locales in use when starting runshell. + (Currently only done for utf-8 locales.) + * Avoid using a lot of memory when large objects are present in the git + repository and have to be checked to see if they are a pointed to an + annexed file. Cases where such memory use could occur included, but + were not limited to: + - git commit -a of a large unlocked file (in v5 mode) + - git-annex adjust when a large file was checked into git directly + * When auto-upgrading a v3 remote, avoid upgrading to version 6, + instead keep it at version 5. + * Support using v3 repositories without upgrading them to v5. + * sync: Fix bug in adjusted branch merging that could cause recently + added files to be lost when updating the adjusted branch. + + -- Joey Hess Wed, 12 Oct 2016 09:37:41 -0400 + git-annex (6.20160923) unstable; urgency=medium * Rate limit console progress display updates to 10 per second. diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -26,5 +26,5 @@ showStart "upgrade" "." whenM (isNothing <$> getVersion) $ do initialize Nothing Nothing - r <- upgrade False + r <- upgrade False latestVersion next $ next $ return r diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -154,7 +154,7 @@ - threadstate. -} let st = error "annex state not available" {- Get a DaemonStatus without running in the Annex monad. -} - dstatus <- atomically . newTMVar =<< newDaemonStatus + dstatus <- atomically . newTVar =<< newDaemonStatus d <- newAssistantData st dstatus urlrenderer <- newUrlRenderer v <- newEmptyMVar diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -16,6 +16,7 @@ catCommit, catObject, catObjectDetails, + catObjectMetaData, ) where import System.IO @@ -37,21 +38,28 @@ import Git.FilePath import qualified Utility.CoProcess as CoProcess -data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo +data CatFileHandle = CatFileHandle + { catFileProcess :: CoProcess.CoProcessHandle + , checkFileProcess :: CoProcess.CoProcessHandle + } catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle -catFileStart' restartable repo = do - coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable +catFileStart' restartable repo = CatFileHandle + <$> startp "--batch" + <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + where + startp p = CoProcess.rawMode =<< gitCoProcessStart restartable [ Param "cat-file" - , Param "--batch" + , Param p ] repo - return $ CatFileHandle coprocess repo catFileStop :: CatFileHandle -> IO () -catFileStop (CatFileHandle p _) = CoProcess.stop p +catFileStop h = do + CoProcess.stop (catFileProcess h) + CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString @@ -68,31 +76,50 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive +catObjectDetails h object = query (catFileProcess h) object $ \from -> do + header <- hGetLine from + case parseResp object header of + Just (ParsedResp sha size objtype) -> do + content <- S.hGet from (fromIntegral size) + eatchar '\n' from + return $ Just (L.fromChunks [content], sha, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where - query = fromRef object - send to = hPutStrLn to query - receive from = do - header <- hGetLine from - case words header of - [sha, objtype, size] - | length sha == shaSize -> - case (readObjectType objtype, reads size) of - (Just t, [(bytes, "")]) -> readcontent t bytes from sha - _ -> dne - | otherwise -> dne - _ - | header == fromRef object ++ " missing" -> dne - | otherwise -> error $ "unknown response from git cat-file " ++ show (header, query) - readcontent objtype bytes from sha = do - content <- S.hGet from bytes - eatchar '\n' from - return $ Just (L.fromChunks [content], Ref sha, objtype) - dne = return Nothing eatchar expected from = do c <- hGetChar from when (c /= expected) $ error $ "missing " ++ (show expected) ++ " from git cat-file" + +{- Gets the size and type of an object, without reading its content. -} +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do + resp <- hGetLine from + case parseResp object resp of + Just (ParsedResp _ size objtype) -> + return $ Just (size, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) + +data ParsedResp = ParsedResp Sha Integer ObjectType | DNE + +query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a +query hdl object receive = CoProcess.query hdl send receive + where + send to = hPutStrLn to (fromRef object) + +parseResp :: Ref -> String -> Maybe ParsedResp +parseResp object l = case words l of + [sha, objtype, size] + | length sha == shaSize -> + case (readObjectType objtype, reads size) of + (Just t, [(bytes, "")]) -> + Just $ ParsedResp (Ref sha) bytes t + _ -> Nothing + | otherwise -> Nothing + _ + | l == fromRef object ++ " missing" -> Just DNE + | otherwise -> Nothing {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] diff --git a/Git/Env.hs b/Git/Env.hs --- a/Git/Env.hs +++ b/Git/Env.hs @@ -18,22 +18,26 @@ - does not have any gitEnv yet. -} adjustGitEnv :: Repo -> ([(String, String)] -> [(String, String)]) -> IO Repo adjustGitEnv g adj = do - e <- maybe copyenv return (gitEnv g) + e <- maybe copyGitEnv return (gitEnv g) let e' = adj e return $ g { gitEnv = Just e' } where - copyenv = do + +{- Copies the current environment, so it can be adjusted when running a git + - command. -} +copyGitEnv :: IO [(String, String)] +copyGitEnv = do #ifdef __ANDROID__ - {- This should not be necessary on Android, but there is some - - weird getEnvironment breakage. See - - https://github.com/neurocyte/ghc-android/issues/7 - - Use getEnv to get some key environment variables that - - git expects to have. -} - let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME" - let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k - catMaybes <$> forM keyenv getEnvPair + {- This should not be necessary on Android, but there is some + - weird getEnvironment breakage. See + - https://github.com/neurocyte/ghc-android/issues/7 + - Use getEnv to get some key environment variables that + - git expects to have. -} + let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME" + let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k + catMaybes <$> forM keyenv getEnvPair #else - getEnvironment + getEnvironment #endif addGitEnv :: Repo -> String -> String -> IO Repo diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -143,6 +143,16 @@ where parent = takeDirectory d +{- Flattens the top N levels of a Tree. -} +flattenTree :: Int -> Tree -> Tree +flattenTree 0 t = t +flattenTree n (Tree l) = Tree (concatMap (go n) l) + where + go 0 c = [c] + go _ b@(TreeBlob _ _ _) = [b] + go n' (RecordedSubTree _ _ l') = concatMap (go (n'-1)) l' + go n' (NewSubTree _ l') = concatMap (go (n'-1)) l' + {- Applies an adjustment to items in a tree. - - While less flexible than using getTree and recordTree, @@ -163,41 +173,42 @@ adjustTree adjusttreeitem addtreeitems removefiles r repo = withMkTreeHandle repo $ \h -> do (l, cleanup) <- liftIO $ lsTreeWithObjects r repo - (l', _, _) <- go h False [] inTopTree l - l'' <- adjustlist h inTopTree (const True) l' + (l', _, _) <- go h False [] 1 inTopTree l + l'' <- adjustlist h 0 inTopTree (const True) l' sha <- liftIO $ mkTree h l'' void $ liftIO cleanup return sha where - go _ wasmodified c _ [] = return (c, wasmodified, []) - go h wasmodified c intree (i:is) + go _ wasmodified c _ _ [] = return (c, wasmodified, []) + go h wasmodified c depth intree (i:is) | intree i = case readObjectType (LsTree.typeobj i) of Just BlobObject -> do let ti = TreeItem (LsTree.file i) (LsTree.mode i) (LsTree.sha i) v <- adjusttreeitem ti case v of - Nothing -> go h True c intree is + Nothing -> go h True c depth intree is Just ti'@(TreeItem f m s) -> let !modified = wasmodified || ti' /= ti blob = TreeBlob f m s - in go h modified (blob:c) intree is + in go h modified (blob:c) depth intree is Just TreeObject -> do - (sl, modified, is') <- go h False [] (beneathSubTree i) is - sl' <- adjustlist h (inTree i) (beneathSubTree i) sl - subtree <- if modified || sl' /= sl + (sl, modified, is') <- go h False [] (depth+1) (beneathSubTree i) is + sl' <- adjustlist h depth (inTree i) (beneathSubTree i) sl + let slmodified = sl' /= sl + subtree <- if modified || slmodified then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl' else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) [] - let !modified' = modified || wasmodified - go h modified' (subtree : c) intree is' + let !modified' = modified || slmodified || wasmodified + go h modified' (subtree : c) depth intree is' _ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") | otherwise = return (c, wasmodified, i:is) - adjustlist h ishere underhere l = do + adjustlist h depth ishere underhere l = do let (addhere, rest) = partition ishere addtreeitems let l' = filter (not . removed) $ map treeItemToTreeContent addhere ++ l let inl i = any (\t -> beneathSubTree t i) l' - let (Tree addunderhere) = treeItemsToTree $ + let (Tree addunderhere) = flattenTree depth $ treeItemsToTree $ filter (\i -> underhere i && not (inl i)) rest addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere return (addunderhere'++l') diff --git a/Logs/TimeStamp.hs b/Logs/TimeStamp.hs --- a/Logs/TimeStamp.hs +++ b/Logs/TimeStamp.hs @@ -1,6 +1,6 @@ {- log timestamp parsing - - - Copyright 2015 Joey Hess + - Copyright 2015-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -9,22 +9,31 @@ module Logs.TimeStamp where +import Utility.PartialPrelude +import Utility.Misc + import Data.Time.Clock.POSIX import Data.Time +import Data.Ratio #if ! MIN_VERSION_time(1,5,0) import System.Locale #endif -import Control.Applicative -import Prelude {- Parses how POSIXTime shows itself: "1431286201.113452s" - Also handles the format with no fractional seconds. -} parsePOSIXTime :: String -> Maybe POSIXTime -#if MIN_VERSION_time(1,5,0) -parsePOSIXTime s = utcTimeToPOSIXSeconds <$> parseTimeM True defaultTimeLocale "%s%Qs" s -#else -parsePOSIXTime s = utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" s -#endif +parsePOSIXTime s = do + let (sn, sd) = separate (== '.') s + n <- readi sn + if null sd + then return (fromIntegral n) + else do + d <- readi sd + let r = d % (10 ^ (length sd - 1)) + return (fromIntegral n + fromRational r) + where + readi :: String -> Maybe Integer + readi = readish formatPOSIXTime :: String -> POSIXTime -> String formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t) diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -95,16 +95,20 @@ -- Show JSON formatted progress, including the current state of the JSON -- object for the action being performed. -progress :: Maybe Object -> Integer -> BytesProcessed -> IO () -progress maction size bytesprocessed = emit $ case maction of +progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO () +progress maction msize bytesprocessed = emit $ case maction of Just action -> HM.insert "action" (Object action) o Nothing -> o where n = fromBytesProcessed bytesprocessed :: Integer - Object o = object - [ "byte-progress" .= n - , "percent-progress" .= showPercentage 2 (percentage size n) - ] + Object o = case msize of + Just size -> object + [ "byte-progress" .= n + , "percent-progress" .= showPercentage 2 (percentage size n) + , "total-size" .= size + ] + Nothing -> object + [ "byte-progress" .= n ] -- A value that can be displayed either normally, or as JSON. data DualDisp = DualDisp diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -30,12 +30,11 @@ {- Shows a progress meter while performing a transfer of a key. - The action is passed a callback to use to update the meter. -} metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a -metered othermeter key a = case keySize key of - Nothing -> nometer - Just size -> withMessageState (go $ fromInteger size) +metered othermeter key a = withMessageState $ go (keySize key) where go _ (MessageState { outputType = QuietOutput }) = nometer - go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do + go Nothing (MessageState { outputType = NormalOutput }) = nometer + go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do showOutput (progress, meter) <- mkmeter size m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do @@ -44,7 +43,7 @@ r <- a (combinemeter m) liftIO $ clearMeter stdout meter return r - go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = + go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = #if WITH_CONCURRENTOUTPUT withProgressRegion $ \r -> do (progress, meter) <- mkmeter size @@ -57,10 +56,10 @@ nometer #endif go _ (MessageState { outputType = JSONOutput False }) = nometer - go size (MessageState { outputType = JSONOutput True }) = do + go msize (MessageState { outputType = JSONOutput True }) = do buf <- withMessageState $ return . jsonBuffer - m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ - JSON.progress buf size + m <- liftIO $ rateLimitMeterUpdate 0.1 msize $ + JSON.progress buf msize a (combinemeter m) mkmeter size = do diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -1,6 +1,6 @@ {- External special remote interface. - - - Copyright 2013-2015 Joey Hess + - Copyright 2013-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -126,7 +126,8 @@ INITREMOTE_SUCCESS -> Just noop INITREMOTE_FAILURE errmsg -> Just $ error errmsg _ -> Nothing - liftIO $ atomically $ readTMVar $ externalConfig external + withExternalState external $ + liftIO . atomically . readTVar . externalConfig gitConfigSpecialRemote u c'' "externaltype" externaltype return (c'', u) @@ -201,27 +202,28 @@ - While the external remote is processing the Request, it may send - any number of RemoteRequests, that are handled here. - - - Only one request can be made at a time, so locking is used. + - An external remote process can only handle one request at a time. + - Concurrent requests will start up additional processes. - - May throw exceptions, for example on protocol errors, or - when the repository cannot be used. -} handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequest external req mp responsehandler = - withExternalLock external $ \lck -> - handleRequest' lck external req mp responsehandler + withExternalState external $ \st -> + handleRequest' st external req mp responsehandler -handleRequest' :: ExternalLock -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a -handleRequest' lck external req mp responsehandler +handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a +handleRequest' st external req mp responsehandler | needsPREPARE req = do - checkPrepared lck external + checkPrepared st external go | otherwise = go where go = do - sendMessage lck external req + sendMessage st external req loop - loop = receiveMessage lck external responsehandler + loop = receiveMessage st external responsehandler (\rreq -> Just $ handleRemoteRequest rreq >> loop) (\msg -> Just $ handleAsyncMessage msg >> loop) @@ -232,23 +234,23 @@ handleRemoteRequest (DIRHASH_LOWER k) = send $ VALUE $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) = - liftIO $ atomically $ do - let v = externalConfig external - m <- takeTMVar v - putTMVar v $ M.insert setting value m + liftIO $ atomically $ modifyTVar' (externalConfig st) $ + M.insert setting value handleRemoteRequest (GETCONFIG setting) = do value <- fromMaybe "" . M.lookup setting - <$> liftIO (atomically $ readTMVar $ externalConfig external) + <$> liftIO (atomically $ readTVar $ externalConfig st) send $ VALUE value handleRemoteRequest (SETCREDS setting login password) = do - c <- liftIO $ atomically $ readTMVar $ externalConfig external - gc <- liftIO $ atomically $ readTMVar $ externalGitConfig external - c' <- setRemoteCredPair encryptionAlreadySetup c gc (credstorage setting) $ - Just (login, password) - void $ liftIO $ atomically $ swapTMVar (externalConfig external) c' + let v = externalConfig st + c <- liftIO $ atomically $ readTVar v + let gc = externalGitConfig external + c' <- setRemoteCredPair encryptionAlreadySetup c gc + (credstorage setting) + (Just (login, password)) + void $ liftIO $ atomically $ swapTVar v c' handleRemoteRequest (GETCREDS setting) = do - c <- liftIO $ atomically $ readTMVar $ externalConfig external - gc <- liftIO $ atomically $ readTMVar $ externalGitConfig external + c <- liftIO $ atomically $ readTVar $ externalConfig st + let gc = externalGitConfig external creds <- fromMaybe ("", "") <$> getRemoteCredPair c gc (credstorage setting) send $ CREDS (fst creds) (snd creds) @@ -280,11 +282,11 @@ send (VALUE "") -- end of list handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg handleRemoteRequest (VERSION _) = - sendMessage lck external $ ERROR "too late to send VERSION" + sendMessage st external (ERROR "too late to send VERSION") handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err - send = sendMessage lck external + send = sendMessage st external credstorage setting = CredPairStorage { credPairFile = base @@ -297,34 +299,32 @@ withurl mk uri = handleRemoteRequest $ mk $ setDownloader (show uri) OtherDownloader -sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex () -sendMessage lck external m = - fromExternal lck external externalSend $ \h -> - liftIO $ do - protocolDebug external True line - hPutStrLn h line - hFlush h +sendMessage :: Sendable m => ExternalState -> External -> m -> Annex () +sendMessage st external m = liftIO $ do + protocolDebug external st True line + hPutStrLn h line + hFlush h where line = unwords $ formatMessage m + h = externalSend st {- Waits for a message from the external remote, and passes it to the - apppropriate handler. - - If the handler returns Nothing, this is a protocol error.-} receiveMessage - :: ExternalLock + :: ExternalState -> External -> (Response -> Maybe (Annex a)) -> (RemoteRequest -> Maybe (Annex a)) -> (AsyncMessage -> Maybe (Annex a)) -> Annex a -receiveMessage lck external handleresponse handlerequest handleasync = - go =<< fromExternal lck external externalReceive - (liftIO . catchMaybeIO . hGetLine) +receiveMessage st external handleresponse handlerequest handleasync = + go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive st) where go Nothing = protocolError False "" go (Just s) = do - liftIO $ protocolDebug external False s + liftIO $ protocolDebug external st False s case parseMessage s :: Maybe Response of Just resp -> maybe (protocolError True s) id (handleresponse resp) Nothing -> case parseMessage s :: Maybe RemoteRequest of @@ -335,46 +335,47 @@ protocolError parsed s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ if parsed then "(command not allowed at this time)" else "(unable to parse command)" -protocolDebug :: External -> Bool -> String -> IO () -protocolDebug external sendto line = debugM "external" $ unwords - [ externalRemoteProgram (externalType external) +protocolDebug :: External -> ExternalState -> Bool -> String -> IO () +protocolDebug external st sendto line = debugM "external" $ unwords + [ externalRemoteProgram (externalType external) ++ + "[" ++ show (externalPid st) ++ "]" , if sendto then "<--" else "-->" , line ] -{- Starts up the external remote if it's not yet running, - - and passes a value extracted from its state to an action. - -} -fromExternal :: ExternalLock -> External -> (ExternalState -> v) -> (v -> Annex a) -> Annex a -fromExternal lck external extractor a = - go =<< liftIO (atomically (tryReadTMVar v)) +{- While the action is running, the ExternalState provided to it will not + - be available to any other calls. + - + - Starts up a new process if no ExternalStates are available. -} +withExternalState :: External -> (ExternalState -> Annex a) -> Annex a +withExternalState external = bracket alloc dealloc where - go (Just st) = run st - go Nothing = do - st <- startExternal $ externalType external - void $ liftIO $ atomically $ do - void $ tryReadTMVar v - putTMVar v st - - {- Handle initial protocol startup; check the VERSION - - the remote sends. -} - receiveMessage lck external - (const Nothing) - (checkVersion lck external) - (const Nothing) - - run st - - run st = a $ extractor st v = externalState external -{- Starts an external remote process running, but does not handle checking - - VERSION, etc. -} -startExternal :: ExternalType -> Annex ExternalState -startExternal externaltype = do + alloc = do + ms <- liftIO $ atomically $ do + l <- readTVar v + case l of + [] -> return Nothing + (st:rest) -> do + writeTVar v rest + return (Just st) + maybe (startExternal external) return ms + + dealloc st = liftIO $ atomically $ modifyTVar' v (st:) + +{- Starts an external remote process running, and checks VERSION. -} +startExternal :: External -> Annex ExternalState +startExternal external = do errrelayer <- mkStderrRelayer - g <- Annex.gitRepo - liftIO $ do + st <- start errrelayer =<< Annex.gitRepo + receiveMessage st external + (const Nothing) + (checkVersion st external) + (const Nothing) + return st + where + start errrelayer g = liftIO $ do (cmd, ps) <- findShellCommand basecmd let basep = (proc cmd (toCommand ps)) { std_in = CreatePipe @@ -382,23 +383,31 @@ , std_err = CreatePipe } p <- propgit g basep - (Just hin, Just hout, Just herr, pid) <- + (Just hin, Just hout, Just herr, ph) <- createProcess p `catchIO` runerr fileEncoding hin fileEncoding hout fileEncoding herr stderrelay <- async $ errrelayer herr - checkearlytermination =<< getProcessExitCode pid + checkearlytermination =<< getProcessExitCode ph + cv <- newTVarIO $ externalDefaultConfig external + pv <- newTVarIO Unprepared + pid <- atomically $ do + n <- succ <$> readTVar (externalLastPid external) + writeTVar (externalLastPid external) n + return n return $ ExternalState { externalSend = hin , externalReceive = hout + , externalPid = pid , externalShutdown = do cancel stderrelay - void $ waitForProcess pid - , externalPrepared = Unprepared + void $ waitForProcess ph + , externalPrepared = pv + , externalConfig = cv } - where - basecmd = externalRemoteProgram externaltype + + basecmd = externalRemoteProgram $ externalType external propgit g p = do environ <- propGitEnv g @@ -415,50 +424,47 @@ ) stopExternal :: External -> Annex () -stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v) +stopExternal external = liftIO $ do + l <- atomically $ swapTVar (externalState external) [] + mapM_ stop l where - stop Nothing = noop - stop (Just st) = do - void $ atomically $ tryTakeTMVar v + stop st = do hClose $ externalSend st hClose $ externalReceive st externalShutdown st - v = externalState external externalRemoteProgram :: ExternalType -> String externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype -checkVersion :: ExternalLock -> External -> RemoteRequest -> Maybe (Annex ()) -checkVersion lck external (VERSION v) = Just $ +checkVersion :: ExternalState -> External -> RemoteRequest -> Maybe (Annex ()) +checkVersion st external (VERSION v) = Just $ if v `elem` supportedProtocolVersions then noop - else sendMessage lck external (ERROR "unsupported VERSION") + else sendMessage st external (ERROR "unsupported VERSION") checkVersion _ _ _ = Nothing {- If repo has not been prepared, sends PREPARE. - - If the repo fails to prepare, or failed before, throws an exception with - the error message. -} -checkPrepared :: ExternalLock -> External -> Annex () -checkPrepared lck external = - fromExternal lck external externalPrepared $ \prepared -> - case prepared of - Prepared -> noop - FailedPrepare errmsg -> error errmsg - Unprepared -> - handleRequest' lck external PREPARE Nothing $ \resp -> - case resp of - PREPARE_SUCCESS -> Just $ - setprepared Prepared - PREPARE_FAILURE errmsg -> Just $ do - setprepared $ FailedPrepare errmsg - error errmsg - _ -> Nothing +checkPrepared :: ExternalState -> External -> Annex () +checkPrepared st external = do + v <- liftIO $ atomically $ readTVar $ externalPrepared st + case v of + Prepared -> noop + FailedPrepare errmsg -> error errmsg + Unprepared -> + handleRequest' st external PREPARE Nothing $ \resp -> + case resp of + PREPARE_SUCCESS -> Just $ + setprepared Prepared + PREPARE_FAILURE errmsg -> Just $ do + setprepared $ FailedPrepare errmsg + error errmsg + _ -> Nothing where - setprepared status = liftIO . atomically $ do - let v = externalState external - st <- takeTMVar v - void $ putTMVar v $ st { externalPrepared = status } + setprepared status = liftIO $ atomically $ void $ + swapTVar (externalPrepared st) status {- Caches the cost in the git config to avoid needing to start up an - external special remote every time time just to ask it what its diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -12,8 +12,6 @@ External(..), newExternal, ExternalType, - ExternalLock, - withExternalLock, ExternalState(..), PrepareStatus(..), Proto.parseMessage, @@ -44,28 +42,25 @@ import Control.Concurrent.STM import Network.URI --- If the remote is not yet running, the ExternalState TMVar is empty. data External = External { externalType :: ExternalType , externalUUID :: UUID - -- Empty until the remote is running. - , externalState :: TMVar ExternalState - -- Empty when a remote is in use. - , externalLock :: TMVar ExternalLock - -- Never left empty. - , externalConfig :: TMVar RemoteConfig - -- Never left empty. - , externalGitConfig :: TMVar RemoteGitConfig + , externalState :: TVar [ExternalState] + -- ^ Contains states for external special remote processes + -- that are not currently in use. + , externalLastPid :: TVar PID + , externalDefaultConfig :: RemoteConfig + , externalGitConfig :: RemoteGitConfig } newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex External newExternal externaltype u c gc = liftIO $ External <$> pure externaltype <*> pure u - <*> atomically newEmptyTMVar - <*> atomically (newTMVar ExternalLock) - <*> atomically (newTMVar c) - <*> atomically (newTMVar gc) + <*> atomically (newTVar []) + <*> atomically (newTVar 0) + <*> pure c + <*> pure gc type ExternalType = String @@ -73,20 +68,14 @@ { externalSend :: Handle , externalReceive :: Handle , externalShutdown :: IO () - , externalPrepared :: PrepareStatus + , externalPid :: PID + , externalPrepared :: TVar PrepareStatus + , externalConfig :: TVar RemoteConfig } -data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg - --- Constructor is not exported, and only created by newExternal. -data ExternalLock = ExternalLock +type PID = Int -withExternalLock :: External -> (ExternalLock -> Annex a) -> Annex a -withExternalLock external = bracketIO setup cleanup - where - setup = atomically $ takeTMVar v - cleanup = atomically . putTMVar v - v = externalLock external +data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg -- Messages that can be sent to the external remote to request it do something. data Request diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -234,6 +234,7 @@ , testCase "sync" test_sync , testCase "union merge regression" test_union_merge_regression , testCase "adjusted branch merge regression" test_adjusted_branch_merge_regression + , testCase "adjusted branch subtree regression" test_adjusted_branch_subtree_regression , testCase "conflict resolution" test_conflict_resolution , testCase "conflict resolution (adjusted branch)" test_conflict_resolution_adjusted_branch , testCase "conflict resolution movein regression" test_conflict_resolution_movein_regression @@ -1424,6 +1425,27 @@ l <- getDirectoryContents "." conflictor `elem` l @? ("conflictor not present after merge in " ++ what) + +{- Regression test for a bug in adjusted branch syncing code, where adding + - a subtree to an existing tree lost files. -} +test_adjusted_branch_subtree_regression :: Assertion +test_adjusted_branch_subtree_regression = + whenM Annex.AdjustedBranch.isGitVersionSupported $ + withtmpclonerepo $ \r -> do + indir r $ do + disconnectOrigin + git_annex "upgrade" [] @? "upgrade failed" + git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" + createDirectoryIfMissing True "a/b/c" + writeFile "a/b/c/d" "foo" + git_annex "add" ["a/b/c"] @? "add a/b/c failed" + git_annex "sync" [] @? "sync failed" + createDirectoryIfMissing True "a/b/x" + writeFile "a/b/x/y" "foo" + git_annex "add" ["a/b/x"] @? "add a/b/x failed" + git_annex "sync" [] @? "sync failed" + boolSystem "git" [Param "checkout", Param "master"] @? "git checkout master failed" + doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") {- Set up repos as remotes of each other. -} pair :: FilePath -> FilePath -> Assertion diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -26,7 +26,7 @@ needsUpgrade :: Version -> Annex (Maybe String) needsUpgrade v | v `elem` supportedVersions = ok - | v `elem` autoUpgradeableVersions = ifM (upgrade True) + | v `elem` autoUpgradeableVersions = ifM (upgrade True defaultVersion) ( ok , err "Automatic upgrade failed!" ) @@ -37,13 +37,14 @@ " is not supported. " ++ msg ok = return Nothing -upgrade :: Bool -> Annex Bool -upgrade automatic = do +upgrade :: Bool -> Version -> Annex Bool +upgrade automatic destversion = do upgraded <- go =<< getVersion when upgraded $ - setVersion latestVersion + setVersion destversion return upgraded where + go (Just v) | v >= destversion = return True #ifndef mingw32_HOST_OS go (Just "0") = Upgrade.V0.upgrade go (Just "1") = Upgrade.V1.upgrade diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -19,7 +19,6 @@ import qualified Git import qualified Git.LsFiles as LsFiles import Backend -import Annex.Version import Utility.FileMode import Utility.Tmp import qualified Upgrade.V2 @@ -52,16 +51,13 @@ showAction "v1 to v2" ifM (fromRepo Git.repoIsLocalBare) - ( do - moveContent - setVersion latestVersion + ( moveContent , do moveContent updateSymlinks moveLocationLogs Annex.Queue.flush - setVersion latestVersion ) Upgrade.V2.upgrade 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.20160923 +Version: 6.20161012 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess