add fix subcommand
This commit is contained in:
parent
b02a3b3f5b
commit
0c0ae02838
2 changed files with 19 additions and 7 deletions
20
Commands.hs
20
Commands.hs
|
@ -24,7 +24,8 @@ import Core
|
||||||
import qualified Remotes
|
import qualified Remotes
|
||||||
import qualified BackendTypes
|
import qualified BackendTypes
|
||||||
|
|
||||||
data CmdWants = FilesInGit | FilesNotInGit | RepoName | SingleString
|
data CmdWants = FilesInGit | FilesNotInGit | FilesInOrNotInGit |
|
||||||
|
RepoName | SingleString
|
||||||
data Command = Command {
|
data Command = Command {
|
||||||
cmdname :: String,
|
cmdname :: String,
|
||||||
cmdaction :: (String -> Annex ()),
|
cmdaction :: (String -> Annex ()),
|
||||||
|
@ -40,7 +41,7 @@ cmds = [
|
||||||
, (Command "pull" pullCmd RepoName)
|
, (Command "pull" pullCmd RepoName)
|
||||||
, (Command "unannex" unannexCmd FilesInGit)
|
, (Command "unannex" unannexCmd FilesInGit)
|
||||||
, (Command "describe" describeCmd SingleString)
|
, (Command "describe" describeCmd SingleString)
|
||||||
, (Command "fix" fixCmd FilesInGit)
|
, (Command "fix" fixCmd FilesInOrNotInGit)
|
||||||
]
|
]
|
||||||
|
|
||||||
options = [
|
options = [
|
||||||
|
@ -57,6 +58,10 @@ findWanted FilesNotInGit params repo = do
|
||||||
findWanted FilesInGit params repo = do
|
findWanted FilesInGit params repo = do
|
||||||
files <- mapM (Git.inRepo repo) params
|
files <- mapM (Git.inRepo repo) params
|
||||||
return $ foldl (++) [] files
|
return $ foldl (++) [] files
|
||||||
|
findWanted FilesInOrNotInGit params repo = do
|
||||||
|
a <- findWanted FilesInGit params repo
|
||||||
|
b <- findWanted FilesNotInGit params repo
|
||||||
|
return $ union a b
|
||||||
findWanted SingleString params _ = do
|
findWanted SingleString params _ = do
|
||||||
return $ [unwords params]
|
return $ [unwords params]
|
||||||
findWanted RepoName params _ = do
|
findWanted RepoName params _ = do
|
||||||
|
@ -178,20 +183,25 @@ dropCmd file = notinBackend file err $ \(key, backend) -> do
|
||||||
{- Fixes the symlink to an annexed file. -}
|
{- Fixes the symlink to an annexed file. -}
|
||||||
fixCmd :: String -> Annex ()
|
fixCmd :: String -> Annex ()
|
||||||
fixCmd file = notinBackend file err $ \(key, backend) -> do
|
fixCmd file = notinBackend file err $ \(key, backend) -> do
|
||||||
|
liftIO $ putStrLn $ "fix " ++ file
|
||||||
link <- calcGitLink file key
|
link <- calcGitLink file key
|
||||||
checkLegal file
|
checkLegal file link
|
||||||
liftIO $ createDirectoryIfMissing True (parentDir file)
|
liftIO $ createDirectoryIfMissing True (parentDir file)
|
||||||
liftIO $ removeFile file
|
liftIO $ removeFile file
|
||||||
liftIO $ createSymbolicLink link file
|
liftIO $ createSymbolicLink link file
|
||||||
gitAdd file $ Just $ "git-annex fix " ++ file
|
gitAdd file $ Just $ "git-annex fix " ++ file
|
||||||
where
|
where
|
||||||
checkLegal file = do
|
checkLegal file link = do
|
||||||
s <- liftIO $ getSymbolicLinkStatus file
|
s <- liftIO $ getSymbolicLinkStatus file
|
||||||
force <- Annex.flagIsSet Force
|
force <- Annex.flagIsSet Force
|
||||||
if (not (isSymbolicLink s) && not force)
|
if (not (isSymbolicLink s) && not force)
|
||||||
then error $ "not a symbolic link : " ++ file ++
|
then error $ "not a symbolic link : " ++ file ++
|
||||||
" (use --force to override this sanity check)"
|
" (use --force to override this sanity check)"
|
||||||
else return ()
|
else do
|
||||||
|
l <- liftIO $ readSymbolicLink file
|
||||||
|
if (link == l)
|
||||||
|
then error $ "symbolic link already ok for: " ++ file
|
||||||
|
else return ()
|
||||||
err = error $ "not annexed " ++ file
|
err = error $ "not annexed " ++ file
|
||||||
|
|
||||||
{- Pushes all files to a remote repository. -}
|
{- Pushes all files to a remote repository. -}
|
||||||
|
|
6
TODO
6
TODO
|
@ -3,15 +3,17 @@
|
||||||
|
|
||||||
* --push/--pull/--want
|
* --push/--pull/--want
|
||||||
|
|
||||||
* how to handle git mv file?
|
* how to handle git mv file? -> git annex fix -> run automatically?
|
||||||
|
|
||||||
* how to handle git rm file? (should try to drop keys that have no
|
* how to handle git rm file? (should try to drop keys that have no
|
||||||
referring file, if it seems safe..)
|
referring file, if it seems safe..)
|
||||||
|
|
||||||
|
* add a git annex fsck that finds keys that have no referring file
|
||||||
|
|
||||||
* Support for remote git repositories (ssh:// specifically can be made to
|
* Support for remote git repositories (ssh:// specifically can be made to
|
||||||
work, although the other end probably needs to have git-annex installed..)
|
work, although the other end probably needs to have git-annex installed..)
|
||||||
|
|
||||||
* Copy files atomically, don't leaf a partial key on interrupt.
|
* Copy files atomically, don't leave a partial key on interrupt.
|
||||||
(Fix for URL download too..)
|
(Fix for URL download too..)
|
||||||
|
|
||||||
* Find a way to copy a file with a progress bar, while still preserving
|
* Find a way to copy a file with a progress bar, while still preserving
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue