rework config storage
Moved away from a map of flags to storing config directly in the AnnexState structure. Got rid of most accessor functions in Annex. This allowed supporting multiple --exclude flags.
This commit is contained in:
parent
082b022f9a
commit
6a97b10fcb
15 changed files with 179 additions and 198 deletions
|
@ -28,7 +28,7 @@ start keyname = do
|
|||
backends <- Backend.list
|
||||
let key = genKey (head backends) keyname
|
||||
present <- inAnnex key
|
||||
force <- Annex.flagIsSet "force"
|
||||
force <- Annex.getState Annex.force
|
||||
if not present
|
||||
then return Nothing
|
||||
else if not force
|
||||
|
|
|
@ -10,7 +10,7 @@ module Command.FromKey where
|
|||
import Control.Monad.State (liftIO)
|
||||
import System.Posix.Files
|
||||
import System.Directory
|
||||
import Control.Monad (when, unless)
|
||||
import Control.Monad (unless)
|
||||
|
||||
import Command
|
||||
import qualified Annex
|
||||
|
@ -30,22 +30,21 @@ seek = [withFilesMissing start]
|
|||
{- Adds a file pointing at a manually-specified key -}
|
||||
start :: CommandStartString
|
||||
start file = do
|
||||
keyname <- Annex.flagGet "key"
|
||||
when (null keyname) $ error "please specify the key with --key"
|
||||
backends <- Backend.list
|
||||
let key = genKey (head backends) keyname
|
||||
|
||||
key <- cmdlineKey
|
||||
inbackend <- Backend.hasKey key
|
||||
unless inbackend $ error $
|
||||
"key ("++keyname++") is not present in backend"
|
||||
"key ("++keyName key++") is not present in backend"
|
||||
showStart "fromkey" file
|
||||
return $ Just $ perform file key
|
||||
perform :: FilePath -> Key -> CommandPerform
|
||||
perform file key = do
|
||||
return $ Just $ perform file
|
||||
|
||||
perform :: FilePath -> CommandPerform
|
||||
perform file = do
|
||||
key <- cmdlineKey
|
||||
link <- calcGitLink file key
|
||||
liftIO $ createDirectoryIfMissing True (parentDir file)
|
||||
liftIO $ createSymbolicLink link file
|
||||
return $ Just $ cleanup file
|
||||
|
||||
cleanup :: FilePath -> CommandCleanup
|
||||
cleanup file = do
|
||||
Annex.queue "add" ["--"] file
|
||||
|
|
|
@ -34,12 +34,16 @@ seek = [withFilesInGit $ start True]
|
|||
- moving data in the key-value backend. -}
|
||||
start :: Bool -> CommandStartString
|
||||
start move file = do
|
||||
fromName <- Annex.flagGet "fromrepository"
|
||||
toName <- Annex.flagGet "torepository"
|
||||
case (fromName, toName) of
|
||||
("", "") -> error "specify either --from or --to"
|
||||
("", _) -> toStart move file
|
||||
(_ , "") -> fromStart move file
|
||||
to <- Annex.getState Annex.toremote
|
||||
from <- Annex.getState Annex.fromremote
|
||||
case (from, to) of
|
||||
(Nothing, Nothing) -> error "specify either --from or --to"
|
||||
(Nothing, Just name) -> do
|
||||
dest <- Remotes.byName name
|
||||
toStart dest move file
|
||||
(Just name, Nothing) -> do
|
||||
src <- Remotes.byName name
|
||||
fromStart src move file
|
||||
(_ , _) -> error "only one of --from or --to can be specified"
|
||||
|
||||
showAction :: Bool -> FilePath -> Annex ()
|
||||
|
@ -65,34 +69,33 @@ remoteHasKey remote key present = do
|
|||
- A file's content can be moved even if there are insufficient copies to
|
||||
- allow it to be dropped.
|
||||
-}
|
||||
toStart :: Bool -> CommandStartString
|
||||
toStart move file = isAnnexed file $ \(key, _) -> do
|
||||
toStart :: Git.Repo -> Bool -> CommandStartString
|
||||
toStart dest move file = isAnnexed file $ \(key, _) -> do
|
||||
ishere <- inAnnex key
|
||||
if not ishere
|
||||
then return Nothing -- not here, so nothing to do
|
||||
else do
|
||||
showAction move file
|
||||
return $ Just $ toPerform move key
|
||||
toPerform :: Bool -> Key -> CommandPerform
|
||||
toPerform move key = do
|
||||
return $ Just $ toPerform dest move key
|
||||
toPerform :: Git.Repo -> Bool -> Key -> CommandPerform
|
||||
toPerform dest move key = do
|
||||
Remotes.readConfigs
|
||||
-- checking the remote is expensive, so not done in the start step
|
||||
remote <- Remotes.commandLineRemote
|
||||
isthere <- Remotes.inAnnex remote key
|
||||
isthere <- Remotes.inAnnex dest key
|
||||
case isthere of
|
||||
Left err -> do
|
||||
showNote $ show err
|
||||
return Nothing
|
||||
Right False -> do
|
||||
showNote $ "to " ++ Git.repoDescribe remote ++ "..."
|
||||
ok <- Remotes.copyToRemote remote key
|
||||
showNote $ "to " ++ Git.repoDescribe dest ++ "..."
|
||||
ok <- Remotes.copyToRemote dest key
|
||||
if ok
|
||||
then return $ Just $ toCleanup move remote key
|
||||
then return $ Just $ toCleanup dest move key
|
||||
else return Nothing -- failed
|
||||
Right True -> return $ Just $ toCleanup move remote key
|
||||
toCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
|
||||
toCleanup move remote key = do
|
||||
remoteHasKey remote key True
|
||||
Right True -> return $ Just $ toCleanup dest move key
|
||||
toCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup
|
||||
toCleanup dest move key = do
|
||||
remoteHasKey dest key True
|
||||
if move
|
||||
then Command.Drop.cleanup key
|
||||
else return True
|
||||
|
@ -103,36 +106,34 @@ toCleanup move remote key = do
|
|||
- If the current repository already has the content, it is still removed
|
||||
- from the other repository when moving.
|
||||
-}
|
||||
fromStart :: Bool -> CommandStartString
|
||||
fromStart move file = isAnnexed file $ \(key, _) -> do
|
||||
remote <- Remotes.commandLineRemote
|
||||
fromStart :: Git.Repo -> Bool -> CommandStartString
|
||||
fromStart src move file = isAnnexed file $ \(key, _) -> do
|
||||
(trusted, untrusted, _) <- Remotes.keyPossibilities key
|
||||
if null $ filter (\r -> Remotes.same r remote) (trusted ++ untrusted)
|
||||
if null $ filter (\r -> Remotes.same r src) (trusted ++ untrusted)
|
||||
then return Nothing
|
||||
else do
|
||||
showAction move file
|
||||
return $ Just $ fromPerform move key
|
||||
fromPerform :: Bool -> Key -> CommandPerform
|
||||
fromPerform move key = do
|
||||
remote <- Remotes.commandLineRemote
|
||||
return $ Just $ fromPerform src move key
|
||||
fromPerform :: Git.Repo -> Bool -> Key -> CommandPerform
|
||||
fromPerform src move key = do
|
||||
ishere <- inAnnex key
|
||||
if ishere
|
||||
then return $ Just $ fromCleanup move remote key
|
||||
then return $ Just $ fromCleanup src move key
|
||||
else do
|
||||
showNote $ "from " ++ Git.repoDescribe remote ++ "..."
|
||||
ok <- getViaTmp key $ Remotes.copyFromRemote remote key
|
||||
showNote $ "from " ++ Git.repoDescribe src ++ "..."
|
||||
ok <- getViaTmp key $ Remotes.copyFromRemote src key
|
||||
if ok
|
||||
then return $ Just $ fromCleanup move remote key
|
||||
then return $ Just $ fromCleanup src move key
|
||||
else return Nothing -- fail
|
||||
fromCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
|
||||
fromCleanup True remote key = do
|
||||
ok <- Remotes.onRemote remote (boolSystem, False) "dropkey"
|
||||
fromCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup
|
||||
fromCleanup src True key = do
|
||||
ok <- Remotes.onRemote src (boolSystem, False) "dropkey"
|
||||
["--quiet", "--force",
|
||||
"--backend=" ++ backendName key,
|
||||
keyName key]
|
||||
-- better safe than sorry: assume the remote dropped the key
|
||||
-- better safe than sorry: assume the src dropped the key
|
||||
-- even if it seemed to fail; the failure could have occurred
|
||||
-- after it really dropped it
|
||||
remoteHasKey remote key False
|
||||
remoteHasKey src key False
|
||||
return ok
|
||||
fromCleanup False _ _ = return True
|
||||
fromCleanup _ False _ = return True
|
||||
|
|
|
@ -8,14 +8,10 @@
|
|||
module Command.SetKey where
|
||||
|
||||
import Control.Monad.State (liftIO)
|
||||
import Control.Monad (when)
|
||||
|
||||
import Command
|
||||
import qualified Annex
|
||||
import Utility
|
||||
import qualified Backend
|
||||
import LocationLog
|
||||
import Types
|
||||
import Content
|
||||
import Messages
|
||||
|
||||
|
@ -29,26 +25,24 @@ seek = [withTempFile start]
|
|||
{- Sets cached content for a key. -}
|
||||
start :: CommandStartString
|
||||
start file = do
|
||||
keyname <- Annex.flagGet "key"
|
||||
when (null keyname) $ error "please specify the key with --key"
|
||||
backends <- Backend.list
|
||||
let key = genKey (head backends) keyname
|
||||
showStart "setkey" file
|
||||
return $ Just $ perform file key
|
||||
perform :: FilePath -> Key -> CommandPerform
|
||||
perform file key = do
|
||||
return $ Just $ perform file
|
||||
|
||||
perform :: FilePath -> CommandPerform
|
||||
perform file = do
|
||||
key <- cmdlineKey
|
||||
-- the file might be on a different filesystem, so mv is used
|
||||
-- rather than simply calling moveToObjectDir key file
|
||||
-- rather than simply calling moveToObjectDir
|
||||
ok <- getViaTmp key $ \dest -> do
|
||||
if dest /= file
|
||||
then liftIO $ boolSystem "mv" [file, dest]
|
||||
else return True
|
||||
if ok
|
||||
then return $ Just $ cleanup key
|
||||
then return $ Just $ cleanup
|
||||
else error "mv failed!"
|
||||
|
||||
cleanup :: Key -> CommandCleanup
|
||||
cleanup key = do
|
||||
cleanup :: CommandCleanup
|
||||
cleanup = do
|
||||
key <- cmdlineKey
|
||||
logStatus key ValuePresent
|
||||
return True
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue