diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Add.hs | 22 | ||||
| -rw-r--r-- | Command/ConfigList.hs | 2 | ||||
| -rw-r--r-- | Command/Direct.hs | 6 | ||||
| -rw-r--r-- | Command/Fsck.hs | 116 | ||||
| -rw-r--r-- | Command/Indirect.hs | 2 | ||||
| -rw-r--r-- | Command/Init.hs | 43 | ||||
| -rw-r--r-- | Command/Lock.hs | 106 | ||||
| -rw-r--r-- | Command/Migrate.hs | 2 | ||||
| -rw-r--r-- | Command/PreCommit.hs | 19 | ||||
| -rw-r--r-- | Command/Reinit.hs | 2 | ||||
| -rw-r--r-- | Command/Smudge.hs | 135 | ||||
| -rw-r--r-- | Command/Unannex.hs | 3 | ||||
| -rw-r--r-- | Command/Undo.hs | 4 | ||||
| -rw-r--r-- | Command/Unlock.hs | 50 | ||||
| -rw-r--r-- | Command/Unused.hs | 5 | ||||
| -rw-r--r-- | Command/Upgrade.hs | 1 | ||||
| -rw-r--r-- | Command/Version.hs | 3 |
17 files changed, 423 insertions, 98 deletions
diff --git a/Command/Add.hs b/Command/Add.hs index 27c11eab4..ab4e3a9d1 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -32,6 +32,9 @@ import Annex.FileMatcher import Annex.ReplaceFile import Utility.Tmp import Utility.CopyFile +import Annex.InodeSentinal +import Annex.Version +import qualified Database.Keys import Control.Exception (IOException) @@ -64,9 +67,9 @@ seek o = allowConcurrentOutput $ do , startSmall file ) go $ withFilesNotInGit (not $ includeDotFiles o) - ifM isDirect + ifM (versionSupportsUnlockedPointers <||> isDirect) ( go withFilesMaybeModified - , go withFilesUnlocked + , go withFilesOldUnlocked ) {- Pass file off to git-add. -} @@ -103,13 +106,22 @@ start file = ifAnnexed file addpresent add next $ if isSymbolicLink s then next $ addFile file else perform file - addpresent key = ifM isDirect + addpresent key = ifM versionSupportsUnlockedPointers ( do ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file case ms of Just s | isSymbolicLink s -> fixup key - _ -> ifM (goodContent key file) ( stop , add ) - , fixup key + _ -> ifM (sameInodeCache file =<< Database.Keys.getInodeCaches key) + ( stop, add ) + , ifM isDirect + ( do + ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + case ms of + Just s | isSymbolicLink s -> fixup key + _ -> ifM (goodContent key file) + ( stop , add ) + , fixup key + ) ) fixup key = do -- the annexed symlink is present but not yet added to git diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 46c909107..997016e8e 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -46,7 +46,7 @@ findOrGenUUID = do else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit)) ( do liftIO checkNotReadOnly - initialize Nothing + initialize Nothing Nothing getUUID , return NoUUID ) diff --git a/Command/Direct.hs b/Command/Direct.hs index 162780dd5..9cfd258eb 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -14,6 +14,7 @@ import qualified Git.LsFiles import qualified Git.Branch import Config import Annex.Direct +import Annex.Version cmd :: Command cmd = notBareRepo $ noDaemonRunning $ @@ -24,7 +25,10 @@ seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart -start = ifM isDirect ( stop , next perform ) +start = ifM versionSupportsDirectMode + ( ifM isDirect ( stop , next perform ) + , error "Direct mode is not suppported by this repository version. Use git-annex unlock instead." + ) perform :: CommandPerform perform = do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 1531d2ab7..46de4ac96 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -34,6 +34,7 @@ import Utility.HumanTime import Utility.CopyFile import Git.FilePath import Utility.PID +import qualified Database.Keys #ifdef WITH_DATABASE import qualified Database.Fsck as FsckDb @@ -118,16 +119,18 @@ start from inc file key = do go = runFsck inc file key perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool -perform key file backend numcopies = check - -- order matters - [ fixLink key file - , verifyLocationLog key file - , verifyDirectMapping key file - , verifyDirectMode key file - , checkKeySize key - , checkBackend backend key (Just file) - , checkKeyNumCopies key (Just file) numcopies - ] +perform key file backend numcopies = do + keystatus <- getKeyStatus key + check + -- order matters + [ fixLink key file + , verifyLocationLog key keystatus file + , verifyDirectMapping key file + , verifyDirectMode key file + , checkKeySize key keystatus + , checkBackend backend key keystatus (Just file) + , checkKeyNumCopies key (Just file) numcopies + ] {- To fsck a remote, the content is retrieved to a tmp file, - and checked locally. -} @@ -183,19 +186,19 @@ startKey inc key numcopies = performKey key backend numcopies performKey :: Key -> Backend -> NumCopies -> Annex Bool -performKey key backend numcopies = check - [ verifyLocationLog key (key2file key) - , checkKeySize key - , checkBackend backend key Nothing - , checkKeyNumCopies key Nothing numcopies - ] +performKey key backend numcopies = do + keystatus <- getKeyStatus key + check + [ verifyLocationLog key keystatus (key2file key) + , checkKeySize key keystatus + , checkBackend backend key keystatus Nothing + , checkKeyNumCopies key Nothing numcopies + ] check :: [Annex Bool] -> Annex Bool check cs = and <$> sequence cs -{- Checks that the file's link points correctly to the content. - - - - In direct mode, there is only a link when the content is not present. +{- Checks that symlinks points correctly to the annexed content. -} fixLink :: Key -> FilePath -> Annex Bool fixLink key file = do @@ -214,19 +217,23 @@ fixLink key file = do {- Checks that the location log reflects the current status of the key, - in this repository only. -} -verifyLocationLog :: Key -> String -> Annex Bool -verifyLocationLog key desc = do - present <- inAnnex key +verifyLocationLog :: Key -> KeyStatus -> String -> Annex Bool +verifyLocationLog key keystatus desc = do + obj <- calcRepo $ gitAnnexLocation key + present <- if isKeyUnlocked keystatus + then liftIO (doesFileExist obj) + else inAnnex key direct <- isDirect u <- getUUID - {- Since we're checking that a key's file is present, throw + {- Since we're checking that a key's object file is present, throw - in a permission fixup here too. -} - file <- calcRepo $ gitAnnexLocation key - when (present && not direct) $ - freezeContent file - whenM (liftIO $ doesDirectoryExist $ parentDir file) $ - freezeContentDir file + when (present && not direct) $ void $ tryIO $ + if isKeyUnlocked keystatus + then thawContent obj + else freezeContent obj + whenM (liftIO $ doesDirectoryExist $ parentDir obj) $ + freezeContentDir obj {- In direct mode, modified files will show up as not present, - but that is expected and not something to do anything about. -} @@ -288,18 +295,16 @@ verifyDirectMode key file = do {- The size of the data for a key is checked against the size encoded in - the key's metadata, if available. - - - Not checked in direct mode, because files can be changed directly. + - Not checked when a file is unlocked, or in direct mode. -} -checkKeySize :: Key -> Annex Bool -checkKeySize key = ifM isDirect - ( return True - , do - file <- calcRepo $ gitAnnexLocation key - ifM (liftIO $ doesFileExist file) - ( checkKeySizeOr badContent key file - , return True - ) - ) +checkKeySize :: Key -> KeyStatus -> Annex Bool +checkKeySize _ KeyUnlocked = return True +checkKeySize key _ = do + file <- calcRepo $ gitAnnexLocation key + ifM (liftIO $ doesFileExist file) + ( checkKeySizeOr badContent key file + , return True + ) checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool checkKeySizeRemote _ _ Nothing = return True @@ -326,18 +331,26 @@ checkKeySizeOr bad key file = case Types.Key.keySize key of , msg ] -{- Runs the backend specific check on a key's content. +{- Runs the backend specific check on a key's content object. + - + - When a file is unlocked, it may be a hard link to the object, + - thus when the user modifies the file, the object will be modified and + - not pass the check, and we don't want to find an error in this case. + - So, skip the check if the key is unlocked and modified. - - In direct mode this is not done if the file has clearly been modified, - because modification of direct mode files is allowed. It's still done - if the file does not appear modified, to catch disk corruption, etc. -} -checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool -checkBackend backend key mfile = go =<< isDirect +checkBackend :: Backend -> Key -> KeyStatus -> Maybe FilePath -> Annex Bool +checkBackend backend key keystatus mfile = go =<< isDirect where go False = do content <- calcRepo $ gitAnnexLocation key - checkBackendOr badContent backend key content + ifM (pure (isKeyUnlocked keystatus) <&&> (not <$> isUnmodified key content)) + ( nocheck + , checkBackendOr badContent backend key content + ) go True = maybe nocheck checkdirect mfile checkdirect file = ifM (goodContent key file) ( checkBackendOr' (badContentDirect file) backend key file @@ -582,3 +595,20 @@ withFsckDb (StartIncremental h) a = a h withFsckDb NonIncremental _ = noop withFsckDb (ScheduleIncremental _ _ i) a = withFsckDb i a #endif + +data KeyStatus = KeyLocked | KeyUnlocked | KeyMissing + +isKeyUnlocked :: KeyStatus -> Bool +isKeyUnlocked KeyUnlocked = True +isKeyUnlocked KeyLocked = False +isKeyUnlocked KeyMissing = False + +getKeyStatus :: Key -> Annex KeyStatus +getKeyStatus key = ifM isDirect + ( return KeyUnlocked + , catchDefaultIO KeyMissing $ do + obj <- calcRepo $ gitAnnexLocation key + unlocked <- ((> 1) . linkCount <$> liftIO (getFileStatus obj)) + <&&> (not . null <$> Database.Keys.getAssociatedFiles key) + return $ if unlocked then KeyUnlocked else KeyLocked + ) diff --git a/Command/Indirect.hs b/Command/Indirect.hs index c12c91a48..f5234b4dc 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -76,7 +76,7 @@ perform = do return Nothing | otherwise -> maybe noop (fromdirect f) - =<< catKey sha mode + =<< catKey sha _ -> noop go _ = noop diff --git a/Command/Init.hs b/Command/Init.hs index d969669f8..94d8168a6 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -10,25 +10,44 @@ module Command.Init where import Common.Annex import Command import Annex.Init +import Annex.Version import qualified Annex.SpecialRemote cmd :: Command cmd = dontCheck repoExists $ command "init" SectionSetup "initialize git-annex" - paramDesc (withParams seek) + paramDesc (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek = withWords start +data InitOptions = InitOptions + { initDesc :: String + , initVersion :: Maybe Version + } -start :: [String] -> CommandStart -start ws = do - showStart "init" description - next $ perform description - where - description = unwords ws +optParser :: CmdParamsDesc -> Parser InitOptions +optParser desc = InitOptions + <$> (unwords <$> cmdParams desc) + <*> optional (option (str >>= parseVersion) + ( long "version" <> metavar paramValue + <> help "Override default annex.version" + )) -perform :: String -> CommandPerform -perform description = do - initialize $ if null description then Nothing else Just description +parseVersion :: Monad m => String -> m Version +parseVersion v + | v `elem` supportedVersions = return v + | otherwise = fail $ v ++ " is not a currently supported repository version" + +seek :: InitOptions -> CommandSeek +seek = commandAction . start + +start :: InitOptions -> CommandStart +start os = do + showStart "init" (initDesc os) + next $ perform os + +perform :: InitOptions -> CommandPerform +perform os = do + initialize + (if null (initDesc os) then Nothing else Just (initDesc os)) + (initVersion os) Annex.SpecialRemote.autoEnable next $ return True diff --git a/Command/Lock.hs b/Command/Lock.hs index 7711ec3b8..741c18c15 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010 Joey Hess <id@joeyh.name> + - Copyright 2010,2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,6 +11,16 @@ import Common.Annex import Command import qualified Annex.Queue import qualified Annex +import Annex.Version +import Annex.Content +import Annex.Link +import Annex.InodeSentinal +import Annex.Perms +import Annex.ReplaceFile +import Utility.InodeCache +import qualified Database.Keys +import qualified Command.Add +import Logs.Location cmd :: Command cmd = notDirect $ withGlobalOptions annexedMatchingOptions $ @@ -19,18 +29,90 @@ cmd = notDirect $ withGlobalOptions annexedMatchingOptions $ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = do - withFilesUnlocked start ps - withFilesUnlockedToBeCommitted start ps +seek ps = ifM versionSupportsUnlockedPointers + ( withFilesInGit (whenAnnexed startNew) ps + , do + withFilesOldUnlocked startOld ps + withFilesOldUnlockedToBeCommitted startOld ps + ) -start :: FilePath -> CommandStart -start file = do +startNew :: FilePath -> Key -> CommandStart +startNew file key = ifM (isJust <$> isAnnexLink file) + ( stop + , do + showStart "lock" file + go =<< isPointerFile file + ) + where + go (Just key') + | key' == key = cont False + | otherwise = errorModified + go Nothing = + ifM (isUnmodified key file) + ( cont False + , ifM (Annex.getState Annex.force) + ( cont True + , errorModified + ) + ) + cont = next . performNew file key + +performNew :: FilePath -> Key -> Bool -> CommandPerform +performNew file key filemodified = do + lockdown =<< calcRepo (gitAnnexLocation key) + Command.Add.addLink file key + =<< withTSDelta (liftIO . genInodeCache file) + next $ cleanupNew file key + where + lockdown obj = do + ifM (catchBoolIO $ sameInodeCache obj =<< Database.Keys.getInodeCaches key) + ( breakhardlink obj + , repopulate obj + ) + whenM (liftIO $ doesFileExist obj) $ + freezeContent obj + + -- It's ok if the file is hard linked to obj, but if some other + -- associated file is, we need to break that link to lock down obj. + breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do + mfc <- withTSDelta (liftIO . genInodeCache file) + unlessM (sameInodeCache obj (maybeToList mfc)) $ do + modifyContent obj $ replaceFile obj $ \tmp -> do + unlessM (checkedCopyFile key obj tmp) $ + error "unable to lock file; need more free disk space" + Database.Keys.storeInodeCaches key [obj] + + -- Try to repopulate obj from an unmodified associated file. + repopulate obj + | filemodified = modifyContent obj $ do + fs <- Database.Keys.getAssociatedFiles key + mfile <- firstM (isUnmodified key) fs + liftIO $ nukeFile obj + case mfile of + Just unmodified -> + unlessM (checkedCopyFile key unmodified obj) + lostcontent + Nothing -> lostcontent + | otherwise = modifyContent obj $ + liftIO $ renameFile file obj + lostcontent = logStatus key InfoMissing + +cleanupNew :: FilePath -> Key -> CommandCleanup +cleanupNew file key = do + Database.Keys.removeAssociatedFile key file + return True + +startOld :: FilePath -> CommandStart +startOld file = do showStart "lock" file - unlessM (Annex.getState Annex.force) $ - error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)" - next $ perform file + unlessM (Annex.getState Annex.force) + errorModified + next $ performOld file -perform :: FilePath -> CommandPerform -perform file = do +performOld :: FilePath -> CommandPerform +performOld file = do Annex.Queue.addCommand "checkout" [Param "--"] [file] - next $ return True -- no cleanup needed + next $ return True + +errorModified :: a +errorModified = error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)" diff --git a/Command/Migrate.hs b/Command/Migrate.hs index d1c7902d7..b8d2eea87 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -72,7 +72,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey go (Just (newkey, knowngoodcontent)) | knowngoodcontent = finish newkey | otherwise = stopUnless checkcontent $ finish newkey - checkcontent = Command.Fsck.checkBackend oldbackend oldkey $ Just file + checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked $ Just file finish newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $ next $ Command.ReKey.cleanup file oldkey newkey genkey = case maybe Nothing (\fm -> fm oldkey newbackend (Just file)) (fastMigrate oldbackend) of diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 2d62b51f3..cbf7f6e3d 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -16,7 +16,9 @@ import qualified Command.Add import qualified Command.Fix import Annex.Direct import Annex.Hook +import Annex.Link import Annex.View +import Annex.Version import Annex.View.ViewedFile import Annex.LockFile import Logs.View @@ -41,17 +43,22 @@ seek ps = lockPreCommitHook $ ifM isDirect withWords startDirect ps runAnnexHook preCommitAnnexHook , do - ifM (liftIO Git.haveFalseIndex) + ifM (not <$> versionSupportsUnlockedPointers <&&> liftIO Git.haveFalseIndex) ( do (fs, cleanup) <- inRepo $ Git.typeChangedStaged ps - whenM (anyM isUnlocked fs) $ + whenM (anyM isOldUnlocked fs) $ error "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 -- fix symlinks to files being committed - withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps + flip withFilesToBeCommitted ps $ \f -> + maybe stop (Command.Fix.start f) + =<< isAnnexLink f -- inject unlocked files into the annex - withFilesUnlockedToBeCommitted startIndirect ps + -- (not needed when repo version uses + -- unlocked pointer files) + unlessM versionSupportsUnlockedPointers $ + withFilesOldUnlockedToBeCommitted startInjectUnlocked ps ) runAnnexHook preCommitAnnexHook -- committing changes to a view updates metadata @@ -64,8 +71,8 @@ seek ps = lockPreCommitHook $ ifM isDirect ) -startIndirect :: FilePath -> CommandStart -startIndirect f = next $ do +startInjectUnlocked :: FilePath -> CommandStart +startInjectUnlocked f = next $ do unlessM (callCommandAction $ Command.Add.start f) $ error $ "failed to add " ++ f ++ "; canceling commit" next $ return True diff --git a/Command/Reinit.hs b/Command/Reinit.hs index 1be692871..e2c00a3d2 100644 --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -38,6 +38,6 @@ perform s = do then return $ toUUID s else Remote.nameToUUID s storeUUID u - initialize' + initialize' Nothing Annex.SpecialRemote.autoEnable next $ return True diff --git a/Command/Smudge.hs b/Command/Smudge.hs new file mode 100644 index 000000000..e6541bc6d --- /dev/null +++ b/Command/Smudge.hs @@ -0,0 +1,135 @@ +{- git-annex command + - + - Copyright 2015 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Smudge where + +import Common.Annex +import Command +import Annex.Content +import Annex.Link +import Annex.MetaData +import Annex.FileMatcher +import Annex.InodeSentinal +import Types.KeySource +import Backend +import Logs.Location +import qualified Database.Keys + +import qualified Data.ByteString.Lazy as B + +cmd :: Command +cmd = noCommit $ noMessages $ + command "smudge" SectionPlumbing + "git smudge filter" + paramFile (seek <$$> optParser) + +data SmudgeOptions = SmudgeOptions + { smudgeFile :: FilePath + , cleanOption :: Bool + } + +optParser :: CmdParamsDesc -> Parser SmudgeOptions +optParser desc = SmudgeOptions + <$> argument str ( metavar desc ) + <*> switch ( long "clean" <> help "clean filter" ) + +seek :: SmudgeOptions -> CommandSeek +seek o = commandAction $ + (if cleanOption o then clean else smudge) (smudgeFile o) + +-- Smudge filter is fed git file content, and if it's a pointer to an +-- available annex object, should output its content. +smudge :: FilePath -> CommandStart +smudge file = do + b <- liftIO $ B.hGetContents stdin + case parseLinkOrPointer b of + Nothing -> liftIO $ B.putStr b + Just k -> do + -- A previous unlocked checkout of the file may have + -- led to the annex object getting modified; + -- don't provide such modified content as it + -- will be confusing. inAnnex will detect such + -- modifications. + ifM (inAnnex k) + ( do + content <- calcRepo (gitAnnexLocation k) + liftIO $ B.putStr . fromMaybe b + =<< catchMaybeIO (B.readFile content) + , liftIO $ B.putStr b + ) + Database.Keys.addAssociatedFile k file + stop + +-- Clean filter is fed file content on stdin, decides if a file +-- should be stored in the annex, and outputs a pointer to its +-- injested content. +clean :: FilePath -> CommandStart +clean file = do + b <- liftIO $ B.hGetContents stdin + if isJust (parseLinkOrPointer b) + then liftIO $ B.hPut stdout b + else ifM (shouldAnnex file) + ( do + k <- ingest file + oldkeys <- filter (/= k) + <$> Database.Keys.getAssociatedKey file + mapM_ (cleanOldKey file) oldkeys + Database.Keys.addAssociatedFile k file + liftIO $ emitPointer k + , liftIO $ B.hPut stdout b + ) + stop + +-- If the file being cleaned was hard linked to the old key's annex object, +-- modifying the file will have caused the object to have the wrong content. +-- Clean up from that, making the +cleanOldKey :: FilePath -> Key -> Annex () +cleanOldKey modifiedfile key = do + obj <- calcRepo (gitAnnexLocation key) + caches <- Database.Keys.getInodeCaches key + unlessM (sameInodeCache obj caches) $ do + unlinkAnnex key + fs <- filter (/= modifiedfile) + <$> Database.Keys.getAssociatedFiles key + fs' <- filterM (`sameInodeCache` caches) fs + case fs' of + -- If linkAnnex fails, the file with the content + -- is still present, so no need for any recovery. + (f:_) -> void $ linkAnnex key f + _ -> lostcontent + where + lostcontent = logStatus key InfoMissing + +shouldAnnex :: FilePath -> Annex Bool +shouldAnnex file = do + matcher <- largeFilesMatcher + checkFileMatcher matcher file + +ingest :: FilePath -> Annex Key +ingest file = do + backend <- chooseBackend file + let source = KeySource + { keyFilename = file + , contentLocation = file + , inodeCache = Nothing + } + k <- fst . fromMaybe (error "failed to generate a key") + <$> genKey source backend + -- Hard link (or copy) file content to annex object + -- to prevent it from being lost when git checks out + -- a branch not containing this file. + r <- linkAnnex k file + case r of + LinkAnnexFailed -> error "Problem adding file to the annex" + LinkAnnexOk -> logStatus k InfoPresent + LinkAnnexNoop -> noop + genMetaData k file + =<< liftIO (getFileStatus file) + return k + +emitPointer :: Key -> IO () +emitPointer = putStr . formatPointer diff --git a/Command/Unannex.hs b/Command/Unannex.hs index fdf976d3e..f7af8cde6 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -15,6 +15,7 @@ import Config import qualified Annex import Annex.Content import Annex.Content.Direct +import Annex.Version import qualified Git.Command import qualified Git.Branch import qualified Git.Ref @@ -32,7 +33,7 @@ seek :: CmdParams -> CommandSeek seek = wrapUnannex . (withFilesInGit $ whenAnnexed start) wrapUnannex :: Annex a -> Annex a -wrapUnannex a = ifM isDirect +wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect) ( a {- Run with the pre-commit hook disabled, to avoid confusing - behavior if an unannexed file is added back to git as diff --git a/Command/Undo.hs b/Command/Undo.hs index c647dfba4..0692dce34 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -72,7 +72,7 @@ perform p = do f <- mkrel di whenM isDirect $ maybe noop (`removeDirect` f) - =<< catKey (srcsha di) (srcmode di) + =<< catKey (srcsha di) liftIO $ nukeFile f forM_ adds $ \di -> do @@ -80,6 +80,6 @@ perform p = do inRepo $ Git.run [Param "checkout", Param "--", File f] whenM isDirect $ maybe noop (`toDirect` f) - =<< catKey (dstsha di) (dstmode di) + =<< catKey (dstsha di) next $ liftIO cleanup diff --git a/Command/Unlock.hs b/Command/Unlock.hs index d1b1d0e90..1cfd4a0b2 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010 Joey Hess <id@joeyh.name> + - Copyright 2010,2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,6 +11,9 @@ import Common.Annex import Command import Annex.Content import Annex.CatFile +import Annex.Version +import Annex.Link +import Annex.ReplaceFile import Utility.CopyFile cmd :: Command @@ -26,14 +29,45 @@ mkcmd n d = notDirect $ withGlobalOptions annexedMatchingOptions $ seek :: CmdParams -> CommandSeek seek = withFilesInGit $ whenAnnexed start -{- The unlock subcommand replaces the symlink with a copy of the file's - - content. -} +{- 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 + - to a pointer. -} start :: FilePath -> Key -> CommandStart -start file key = do - showStart "unlock" file +start file key = ifM (isJust <$> isAnnexLink file) + ( do + showStart "unlock" file + ifM (inAnnex key) + ( ifM versionSupportsUnlockedPointers + ( next $ performNew file key + , startOld file key + ) + , do + warning "content not present; cannot unlock" + next $ next $ return False + ) + , stop + ) + +performNew :: FilePath -> Key -> CommandPerform +performNew dest key = do + src <- calcRepo (gitAnnexLocation key) + replaceFile dest $ \tmp -> do + r <- linkAnnex' key src tmp + case r of + LinkAnnexOk -> return () + _ -> error "linkAnnex failed" + next $ cleanupNew dest key + +cleanupNew :: FilePath -> Key -> CommandCleanup +cleanupNew dest key = do + stagePointerFile dest =<< hashPointerFile key + return True + +startOld :: FilePath -> Key -> CommandStart +startOld file key = ifM (inAnnex key) ( ifM (isJust <$> catKeyFileHEAD file) - ( next $ perform file key + ( next $ performOld file key , do warning "this has not yet been committed to git; cannot unlock it" next $ next $ return False @@ -43,8 +77,8 @@ start file key = do next $ next $ return False ) -perform :: FilePath -> Key -> CommandPerform -perform dest key = ifM (checkDiskSpace Nothing key 0 True) +performOld :: FilePath -> Key -> CommandPerform +performOld dest key = ifM (checkDiskSpace Nothing key 0 True) ( do src <- calcRepo $ gitAnnexLocation key tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key diff --git a/Command/Unused.hs b/Command/Unused.hs index 4756cda5d..4353bd075 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -24,7 +24,6 @@ import qualified Git.Branch import qualified Git.RefLog import qualified Git.LsFiles as LsFiles import qualified Git.DiffTree as DiffTree -import qualified Backend import qualified Remote import qualified Annex.Branch import Annex.CatFile @@ -215,7 +214,7 @@ withKeysReferenced' mdir initial a = do Just dir -> inRepo $ LsFiles.inRepo [dir] go v [] = return v go v (f:fs) = do - x <- Backend.lookupFile f + x <- lookupFile f case x of Nothing -> go v fs Just k -> do @@ -266,7 +265,7 @@ withKeysReferencedInGitRef a ref = do forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a liftIO $ void clean where - tKey True = Backend.lookupFile . getTopFilePath . DiffTree.file + tKey True = lookupFile . getTopFilePath . DiffTree.file tKey False = fileKey . takeFileName . decodeBS <$$> catFile ref . getTopFilePath . DiffTree.file diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index c02a6709f..8a34022e3 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -13,6 +13,7 @@ import Upgrade cmd :: Command cmd = dontCheck repoExists $ -- because an old version may not seem to exist + noDaemonRunning $ -- avoid upgrading repo out from under daemon command "upgrade" SectionMaintenance "upgrade repository layout" paramNothing (withParams seek) diff --git a/Command/Version.hs b/Command/Version.hs index 72bbe4064..c5a9fcef2 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -50,7 +50,8 @@ showVersion = do liftIO $ do showPackageVersion vinfo "local repository version" $ fromMaybe "unknown" v - vinfo "supported repository version" supportedVersion + vinfo "supported repository versions" $ + unwords supportedVersions vinfo "upgrade supported from repository versions" $ unwords upgradableVersions |