cd865c3b8f
This allows the git repository to be moved while git-annex is running in it, with fewer problems. On Windows, this avoids some of the problems with the absurdly small MAX_PATH of 260 bytes. In particular, git-annex repositories should work in deeper/longer directory structures than before. See http://git-annex.branchable.com/bugs/__34__git-annex:_direct:_1_failed__34___on_Windows/ There are several possible ways this change could break git-annex: 1. If it changes its working directory while it's running, that would be Bad News. Good news everyone! git-annex never does so. It would also break thread safety, so all such things were stomped out long ago. 2. parentDir "." -> "" which is not a valid path. I had to fix one instace of this, and I should probably wipe all calls to parentDir out of the git-annex code base; it was never a good idea. 3. Things like relPathDirToFile require absolute input paths, and code assumes that the git repo path is absolute and passes it to it as-is. In the case of relPathDirToFile, I converted it to not make this assumption. Currently, the test suite has 16 failures.
90 lines
2.3 KiB
Haskell
90 lines
2.3 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Status where
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import Annex.CatFile
|
|
import Annex.Content.Direct
|
|
import Config
|
|
import qualified Git.LsFiles as LsFiles
|
|
import qualified Git.Ref
|
|
import qualified Git
|
|
|
|
cmd :: [Command]
|
|
cmd = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $
|
|
command "status" paramPaths seek SectionCommon
|
|
"show the working tree status"]
|
|
|
|
seek :: CommandSeek
|
|
seek = withWords start
|
|
|
|
start :: [FilePath] -> CommandStart
|
|
start [] = do
|
|
-- Like git status, when run without a directory, behave as if
|
|
-- given the path to the top of the repository.
|
|
top <- fromRepo Git.repoPath
|
|
d <- liftIO $ relPathCwdToFile top
|
|
start' [d]
|
|
start locs = start' locs
|
|
|
|
start' :: [FilePath] -> CommandStart
|
|
start' locs = do
|
|
(l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs
|
|
getstatus <- ifM isDirect
|
|
( return statusDirect
|
|
, return $ Just <$$> statusIndirect
|
|
)
|
|
forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f
|
|
void $ liftIO cleanup
|
|
stop
|
|
|
|
data Status
|
|
= NewFile
|
|
| DeletedFile
|
|
| ModifiedFile
|
|
|
|
showStatus :: Status -> String
|
|
showStatus NewFile = "?"
|
|
showStatus DeletedFile = "D"
|
|
showStatus ModifiedFile = "M"
|
|
|
|
showFileStatus :: FilePath -> Status -> Annex ()
|
|
showFileStatus f s = unlessM (showFullJSON [("status", ss), ("file", f)]) $
|
|
liftIO $ putStrLn $ ss ++ " " ++ f
|
|
where
|
|
ss = showStatus s
|
|
|
|
statusDirect :: FilePath -> Annex (Maybe Status)
|
|
statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f)
|
|
where
|
|
checkstatus Nothing = return $ Just DeletedFile
|
|
checkstatus (Just s)
|
|
-- Git thinks that present direct mode files are modifed,
|
|
-- so have to check.
|
|
| not (isSymbolicLink s) = checkkey s =<< catKeyFile f
|
|
| otherwise = Just <$> checkNew f
|
|
|
|
checkkey s (Just k) = ifM (sameFileStatus k s)
|
|
( return Nothing
|
|
, return $ Just ModifiedFile
|
|
)
|
|
checkkey _ Nothing = Just <$> checkNew f
|
|
|
|
statusIndirect :: FilePath -> Annex Status
|
|
statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f))
|
|
( checkNew f
|
|
, return DeletedFile
|
|
)
|
|
where
|
|
|
|
checkNew :: FilePath -> Annex Status
|
|
checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f))
|
|
( return ModifiedFile
|
|
, return NewFile
|
|
)
|