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
134
Annex.hs
134
Annex.hs
|
@ -8,26 +8,18 @@
|
||||||
module Annex (
|
module Annex (
|
||||||
Annex,
|
Annex,
|
||||||
AnnexState(..),
|
AnnexState(..),
|
||||||
getState,
|
|
||||||
new,
|
new,
|
||||||
run,
|
run,
|
||||||
eval,
|
eval,
|
||||||
|
getState,
|
||||||
|
changeState,
|
||||||
gitRepo,
|
gitRepo,
|
||||||
gitRepoChange,
|
|
||||||
backendsChange,
|
|
||||||
FlagName,
|
|
||||||
Flag(..),
|
|
||||||
flagIsSet,
|
|
||||||
flagChange,
|
|
||||||
flagGet,
|
|
||||||
queue,
|
queue,
|
||||||
queueGet,
|
|
||||||
queueRun,
|
queueRun,
|
||||||
setConfig
|
setConfig
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import qualified Data.Map as M
|
|
||||||
|
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
import qualified GitQueue
|
import qualified GitQueue
|
||||||
|
@ -37,40 +29,42 @@ import qualified TypeInternals
|
||||||
type Annex = StateT AnnexState IO
|
type Annex = StateT AnnexState IO
|
||||||
|
|
||||||
-- internal state storage
|
-- internal state storage
|
||||||
data AnnexState = AnnexState {
|
data AnnexState = AnnexState
|
||||||
repo :: Git.Repo,
|
{ repo :: Git.Repo
|
||||||
backends :: [TypeInternals.Backend Annex],
|
, backends :: [TypeInternals.Backend Annex]
|
||||||
supportedBackends :: [TypeInternals.Backend Annex],
|
, supportedBackends :: [TypeInternals.Backend Annex]
|
||||||
flags :: M.Map FlagName Flag,
|
, repoqueue :: GitQueue.Queue
|
||||||
repoqueue :: GitQueue.Queue,
|
, quiet :: Bool
|
||||||
quiet :: Bool
|
, force :: Bool
|
||||||
} deriving (Show)
|
, defaultbackend :: Maybe String
|
||||||
|
, defaultkey :: Maybe String
|
||||||
|
, toremote :: Maybe String
|
||||||
|
, fromremote :: Maybe String
|
||||||
|
, exclude :: [String]
|
||||||
|
, remotesread :: Bool
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
-- command-line flags
|
newState :: Git.Repo -> [TypeInternals.Backend Annex] -> AnnexState
|
||||||
type FlagName = String
|
newState gitrepo allbackends = AnnexState
|
||||||
data Flag =
|
{ repo = gitrepo
|
||||||
FlagBool Bool |
|
, backends = []
|
||||||
FlagString String
|
, supportedBackends = allbackends
|
||||||
deriving (Eq, Read, Show)
|
, repoqueue = GitQueue.empty
|
||||||
|
, quiet = False
|
||||||
|
, force = False
|
||||||
|
, defaultbackend = Nothing
|
||||||
|
, defaultkey = Nothing
|
||||||
|
, toremote = Nothing
|
||||||
|
, fromremote = Nothing
|
||||||
|
, exclude = []
|
||||||
|
, remotesread = False
|
||||||
|
}
|
||||||
|
|
||||||
{- Create and returns an Annex state object for the specified git repo. -}
|
{- Create and returns an Annex state object for the specified git repo. -}
|
||||||
new :: Git.Repo -> [TypeInternals.Backend Annex] -> IO AnnexState
|
new :: Git.Repo -> [TypeInternals.Backend Annex] -> IO AnnexState
|
||||||
new gitrepo allbackends = do
|
new gitrepo allbackends = do
|
||||||
let s = AnnexState {
|
gitrepo' <- liftIO $ Git.configRead gitrepo
|
||||||
repo = gitrepo,
|
return $ newState gitrepo' allbackends
|
||||||
backends = [],
|
|
||||||
supportedBackends = allbackends,
|
|
||||||
flags = M.empty,
|
|
||||||
repoqueue = GitQueue.empty,
|
|
||||||
quiet = False
|
|
||||||
}
|
|
||||||
(_,s') <- Annex.run s prep
|
|
||||||
return s'
|
|
||||||
where
|
|
||||||
prep = do
|
|
||||||
-- read git config and update state
|
|
||||||
gitrepo' <- liftIO $ Git.configRead gitrepo
|
|
||||||
Annex.gitRepoChange gitrepo'
|
|
||||||
|
|
||||||
{- performs an action in the Annex monad -}
|
{- performs an action in the Annex monad -}
|
||||||
run :: AnnexState -> Annex a -> IO (a, AnnexState)
|
run :: AnnexState -> Annex a -> IO (a, AnnexState)
|
||||||
|
@ -78,50 +72,26 @@ run state action = runStateT action state
|
||||||
eval :: AnnexState -> Annex a -> IO a
|
eval :: AnnexState -> Annex a -> IO a
|
||||||
eval state action = evalStateT action state
|
eval state action = evalStateT action state
|
||||||
|
|
||||||
{- gets a value from the internal Annex state -}
|
{- Gets a value from the internal state, selected by the passed value
|
||||||
|
- constructor. -}
|
||||||
getState :: (AnnexState -> a) -> Annex a
|
getState :: (AnnexState -> a) -> Annex a
|
||||||
getState a = do
|
getState c = do
|
||||||
state <- get
|
state <- get
|
||||||
return (a state)
|
return (c state)
|
||||||
|
|
||||||
|
{- Applies a state mutation function to change the internal state.
|
||||||
|
-
|
||||||
|
- Example: changeState (\s -> s { quiet = True })
|
||||||
|
-}
|
||||||
|
changeState :: (AnnexState -> AnnexState) -> Annex ()
|
||||||
|
changeState a = do
|
||||||
|
state <- get
|
||||||
|
put (a state)
|
||||||
|
|
||||||
{- Returns the git repository being acted on -}
|
{- Returns the git repository being acted on -}
|
||||||
gitRepo :: Annex Git.Repo
|
gitRepo :: Annex Git.Repo
|
||||||
gitRepo = getState repo
|
gitRepo = getState repo
|
||||||
|
|
||||||
{- Changes the git repository being acted on. -}
|
|
||||||
gitRepoChange :: Git.Repo -> Annex ()
|
|
||||||
gitRepoChange r = do
|
|
||||||
state <- get
|
|
||||||
put state { repo = r }
|
|
||||||
|
|
||||||
{- Sets the backends to use. -}
|
|
||||||
backendsChange :: [TypeInternals.Backend Annex] -> Annex ()
|
|
||||||
backendsChange b = do
|
|
||||||
state <- get
|
|
||||||
put state { backends = b }
|
|
||||||
|
|
||||||
{- Return True if a Bool flag is set. -}
|
|
||||||
flagIsSet :: FlagName -> Annex Bool
|
|
||||||
flagIsSet name = do
|
|
||||||
state <- get
|
|
||||||
case (M.lookup name $ flags state) of
|
|
||||||
Just (FlagBool True) -> return True
|
|
||||||
_ -> return False
|
|
||||||
|
|
||||||
{- Sets the value of a flag. -}
|
|
||||||
flagChange :: FlagName -> Flag -> Annex ()
|
|
||||||
flagChange name val = do
|
|
||||||
state <- get
|
|
||||||
put state { flags = M.insert name val $ flags state }
|
|
||||||
|
|
||||||
{- Gets the value of a String flag (or "" if there is no such String flag) -}
|
|
||||||
flagGet :: FlagName -> Annex String
|
|
||||||
flagGet name = do
|
|
||||||
state <- get
|
|
||||||
case (M.lookup name $ flags state) of
|
|
||||||
Just (FlagString s) -> return s
|
|
||||||
_ -> return ""
|
|
||||||
|
|
||||||
{- Adds a git command to the queue. -}
|
{- Adds a git command to the queue. -}
|
||||||
queue :: String -> [String] -> FilePath -> Annex ()
|
queue :: String -> [String] -> FilePath -> Annex ()
|
||||||
queue command params file = do
|
queue command params file = do
|
||||||
|
@ -129,12 +99,6 @@ queue command params file = do
|
||||||
let q = repoqueue state
|
let q = repoqueue state
|
||||||
put state { repoqueue = GitQueue.add q command params file }
|
put state { repoqueue = GitQueue.add q command params file }
|
||||||
|
|
||||||
{- Returns the queue. -}
|
|
||||||
queueGet :: Annex GitQueue.Queue
|
|
||||||
queueGet = do
|
|
||||||
state <- get
|
|
||||||
return (repoqueue state)
|
|
||||||
|
|
||||||
{- Runs (and empties) the queue. -}
|
{- Runs (and empties) the queue. -}
|
||||||
queueRun :: Annex ()
|
queueRun :: Annex ()
|
||||||
queueRun = do
|
queueRun = do
|
||||||
|
@ -146,9 +110,9 @@ queueRun = do
|
||||||
|
|
||||||
{- Changes a git config setting in both internal state and .git/config -}
|
{- Changes a git config setting in both internal state and .git/config -}
|
||||||
setConfig :: String -> String -> Annex ()
|
setConfig :: String -> String -> Annex ()
|
||||||
setConfig key value = do
|
setConfig k value = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
liftIO $ Git.run g ["config", key, value]
|
liftIO $ Git.run g ["config", k, value]
|
||||||
-- re-read git config and update the repo's state
|
-- re-read git config and update the repo's state
|
||||||
g' <- liftIO $ Git.configRead g
|
g' <- liftIO $ Git.configRead g
|
||||||
Annex.gitRepoChange g'
|
Annex.changeState $ \s -> s { Annex.repo = g' }
|
||||||
|
|
28
Backend.hs
28
Backend.hs
|
@ -48,20 +48,24 @@ list = do
|
||||||
if not $ null l
|
if not $ null l
|
||||||
then return l
|
then return l
|
||||||
else do
|
else do
|
||||||
|
s <- getstandard
|
||||||
|
d <- Annex.getState Annex.defaultbackend
|
||||||
|
handle d s
|
||||||
|
where
|
||||||
|
parseBackendList l [] = l
|
||||||
|
parseBackendList bs s = map (lookupBackendName bs) $ words s
|
||||||
|
handle Nothing s = return s
|
||||||
|
handle (Just "") s = return s
|
||||||
|
handle (Just name) s = do
|
||||||
|
bs <- Annex.getState Annex.supportedBackends
|
||||||
|
let l' = (lookupBackendName bs name):s
|
||||||
|
Annex.changeState $ \state -> state { Annex.backends = l' }
|
||||||
|
return l'
|
||||||
|
getstandard = do
|
||||||
bs <- Annex.getState Annex.supportedBackends
|
bs <- Annex.getState Annex.supportedBackends
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
let defaults = parseBackendList bs $ Git.configGet g "annex.backends" ""
|
return $ parseBackendList bs $
|
||||||
backendflag <- Annex.flagGet "backend"
|
Git.configGet g "annex.backends" ""
|
||||||
let l' = if not $ null backendflag
|
|
||||||
then (lookupBackendName bs backendflag):defaults
|
|
||||||
else defaults
|
|
||||||
Annex.backendsChange l'
|
|
||||||
return l'
|
|
||||||
where
|
|
||||||
parseBackendList bs s =
|
|
||||||
if null s
|
|
||||||
then bs
|
|
||||||
else map (lookupBackendName bs) $ words s
|
|
||||||
|
|
||||||
{- Looks up a backend in a list. May fail if unknown. -}
|
{- Looks up a backend in a list. May fail if unknown. -}
|
||||||
lookupBackendName :: [Backend Annex] -> String -> Backend Annex
|
lookupBackendName :: [Backend Annex] -> String -> Backend Annex
|
||||||
|
|
|
@ -90,7 +90,7 @@ copyKeyFile key file = do
|
||||||
- error if not. -}
|
- error if not. -}
|
||||||
checkRemoveKey :: Key -> Maybe Int -> Annex Bool
|
checkRemoveKey :: Key -> Maybe Int -> Annex Bool
|
||||||
checkRemoveKey key numcopiesM = do
|
checkRemoveKey key numcopiesM = do
|
||||||
force <- Annex.flagIsSet "force"
|
force <- Annex.getState Annex.force
|
||||||
if force || numcopiesM == Just 0
|
if force || numcopiesM == Just 0
|
||||||
then return True
|
then return True
|
||||||
else do
|
else do
|
||||||
|
|
|
@ -102,7 +102,7 @@ startup = do
|
||||||
{- Cleanup actions. -}
|
{- Cleanup actions. -}
|
||||||
shutdown :: Integer -> Annex ()
|
shutdown :: Integer -> Annex ()
|
||||||
shutdown errnum = do
|
shutdown errnum = do
|
||||||
q <- Annex.queueGet
|
q <- Annex.getState Annex.repoqueue
|
||||||
unless (q == GitQueue.empty) $ do
|
unless (q == GitQueue.empty) $ do
|
||||||
showSideAction "Recording state in git..."
|
showSideAction "Recording state in git..."
|
||||||
Annex.queueRun
|
Annex.queueRun
|
||||||
|
|
21
Command.hs
21
Command.hs
|
@ -179,11 +179,11 @@ backendPairs a files = do
|
||||||
filterFiles :: [FilePath] -> Annex [FilePath]
|
filterFiles :: [FilePath] -> Annex [FilePath]
|
||||||
filterFiles l = do
|
filterFiles l = do
|
||||||
let l' = filter notState l
|
let l' = filter notState l
|
||||||
exclude <- Annex.flagGet "exclude"
|
exclude <- Annex.getState Annex.exclude
|
||||||
if null exclude
|
if null exclude
|
||||||
then return l'
|
then return l'
|
||||||
else do
|
else do
|
||||||
let regexp = compile ("^" ++ wildToRegex exclude) []
|
let regexp = compile (toregex exclude) []
|
||||||
return $ filter (notExcluded regexp) l'
|
return $ filter (notExcluded regexp) l'
|
||||||
where
|
where
|
||||||
notState f = stateLoc /= take stateLocLen f
|
notState f = stateLoc /= take stateLocLen f
|
||||||
|
@ -191,6 +191,10 @@ filterFiles l = do
|
||||||
notExcluded r f = case match r f [] of
|
notExcluded r f = case match r f [] of
|
||||||
Nothing -> True
|
Nothing -> True
|
||||||
Just _ -> False
|
Just _ -> False
|
||||||
|
toregex exclude = "^(" ++ toregex' exclude "" ++ ")"
|
||||||
|
toregex' [] c = c
|
||||||
|
toregex' (w:ws) "" = toregex' ws (wildToRegex w)
|
||||||
|
toregex' (w:ws) c = toregex' ws (c ++ "|" ++ wildToRegex w)
|
||||||
|
|
||||||
{- filter out symlinks -}
|
{- filter out symlinks -}
|
||||||
notSymlink :: FilePath -> IO Bool
|
notSymlink :: FilePath -> IO Bool
|
||||||
|
@ -219,3 +223,16 @@ paramName :: String
|
||||||
paramName = "NAME"
|
paramName = "NAME"
|
||||||
paramNothing :: String
|
paramNothing :: String
|
||||||
paramNothing = ""
|
paramNothing = ""
|
||||||
|
|
||||||
|
{- The Key specified by the --key and --backend parameters. -}
|
||||||
|
cmdlineKey :: Annex Key
|
||||||
|
cmdlineKey = do
|
||||||
|
k <- Annex.getState Annex.defaultkey
|
||||||
|
backends <- Backend.list
|
||||||
|
return $ genKey (head backends) (keyname' k)
|
||||||
|
where
|
||||||
|
keyname' Nothing = badkey
|
||||||
|
keyname' (Just "") = badkey
|
||||||
|
keyname' (Just n) = n
|
||||||
|
badkey = error "please specify the key with --key"
|
||||||
|
|
||||||
|
|
|
@ -28,7 +28,7 @@ start keyname = do
|
||||||
backends <- Backend.list
|
backends <- Backend.list
|
||||||
let key = genKey (head backends) keyname
|
let key = genKey (head backends) keyname
|
||||||
present <- inAnnex key
|
present <- inAnnex key
|
||||||
force <- Annex.flagIsSet "force"
|
force <- Annex.getState Annex.force
|
||||||
if not present
|
if not present
|
||||||
then return Nothing
|
then return Nothing
|
||||||
else if not force
|
else if not force
|
||||||
|
|
|
@ -10,7 +10,7 @@ module Command.FromKey where
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import Control.Monad (when, unless)
|
import Control.Monad (unless)
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
@ -30,22 +30,21 @@ seek = [withFilesMissing start]
|
||||||
{- Adds a file pointing at a manually-specified key -}
|
{- Adds a file pointing at a manually-specified key -}
|
||||||
start :: CommandStartString
|
start :: CommandStartString
|
||||||
start file = do
|
start file = do
|
||||||
keyname <- Annex.flagGet "key"
|
key <- cmdlineKey
|
||||||
when (null keyname) $ error "please specify the key with --key"
|
|
||||||
backends <- Backend.list
|
|
||||||
let key = genKey (head backends) keyname
|
|
||||||
|
|
||||||
inbackend <- Backend.hasKey key
|
inbackend <- Backend.hasKey key
|
||||||
unless inbackend $ error $
|
unless inbackend $ error $
|
||||||
"key ("++keyname++") is not present in backend"
|
"key ("++keyName key++") is not present in backend"
|
||||||
showStart "fromkey" file
|
showStart "fromkey" file
|
||||||
return $ Just $ perform file key
|
return $ Just $ perform file
|
||||||
perform :: FilePath -> Key -> CommandPerform
|
|
||||||
perform file key = do
|
perform :: FilePath -> CommandPerform
|
||||||
|
perform file = do
|
||||||
|
key <- cmdlineKey
|
||||||
link <- calcGitLink file key
|
link <- calcGitLink file key
|
||||||
liftIO $ createDirectoryIfMissing True (parentDir file)
|
liftIO $ createDirectoryIfMissing True (parentDir file)
|
||||||
liftIO $ createSymbolicLink link file
|
liftIO $ createSymbolicLink link file
|
||||||
return $ Just $ cleanup file
|
return $ Just $ cleanup file
|
||||||
|
|
||||||
cleanup :: FilePath -> CommandCleanup
|
cleanup :: FilePath -> CommandCleanup
|
||||||
cleanup file = do
|
cleanup file = do
|
||||||
Annex.queue "add" ["--"] file
|
Annex.queue "add" ["--"] file
|
||||||
|
|
|
@ -34,12 +34,16 @@ seek = [withFilesInGit $ start True]
|
||||||
- moving data in the key-value backend. -}
|
- moving data in the key-value backend. -}
|
||||||
start :: Bool -> CommandStartString
|
start :: Bool -> CommandStartString
|
||||||
start move file = do
|
start move file = do
|
||||||
fromName <- Annex.flagGet "fromrepository"
|
to <- Annex.getState Annex.toremote
|
||||||
toName <- Annex.flagGet "torepository"
|
from <- Annex.getState Annex.fromremote
|
||||||
case (fromName, toName) of
|
case (from, to) of
|
||||||
("", "") -> error "specify either --from or --to"
|
(Nothing, Nothing) -> error "specify either --from or --to"
|
||||||
("", _) -> toStart move file
|
(Nothing, Just name) -> do
|
||||||
(_ , "") -> fromStart move file
|
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"
|
(_ , _) -> error "only one of --from or --to can be specified"
|
||||||
|
|
||||||
showAction :: Bool -> FilePath -> Annex ()
|
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
|
- A file's content can be moved even if there are insufficient copies to
|
||||||
- allow it to be dropped.
|
- allow it to be dropped.
|
||||||
-}
|
-}
|
||||||
toStart :: Bool -> CommandStartString
|
toStart :: Git.Repo -> Bool -> CommandStartString
|
||||||
toStart move file = isAnnexed file $ \(key, _) -> do
|
toStart dest move file = isAnnexed file $ \(key, _) -> do
|
||||||
ishere <- inAnnex key
|
ishere <- inAnnex key
|
||||||
if not ishere
|
if not ishere
|
||||||
then return Nothing -- not here, so nothing to do
|
then return Nothing -- not here, so nothing to do
|
||||||
else do
|
else do
|
||||||
showAction move file
|
showAction move file
|
||||||
return $ Just $ toPerform move key
|
return $ Just $ toPerform dest move key
|
||||||
toPerform :: Bool -> Key -> CommandPerform
|
toPerform :: Git.Repo -> Bool -> Key -> CommandPerform
|
||||||
toPerform move key = do
|
toPerform dest move key = do
|
||||||
Remotes.readConfigs
|
Remotes.readConfigs
|
||||||
-- checking the remote is expensive, so not done in the start step
|
-- checking the remote is expensive, so not done in the start step
|
||||||
remote <- Remotes.commandLineRemote
|
isthere <- Remotes.inAnnex dest key
|
||||||
isthere <- Remotes.inAnnex remote key
|
|
||||||
case isthere of
|
case isthere of
|
||||||
Left err -> do
|
Left err -> do
|
||||||
showNote $ show err
|
showNote $ show err
|
||||||
return Nothing
|
return Nothing
|
||||||
Right False -> do
|
Right False -> do
|
||||||
showNote $ "to " ++ Git.repoDescribe remote ++ "..."
|
showNote $ "to " ++ Git.repoDescribe dest ++ "..."
|
||||||
ok <- Remotes.copyToRemote remote key
|
ok <- Remotes.copyToRemote dest key
|
||||||
if ok
|
if ok
|
||||||
then return $ Just $ toCleanup move remote key
|
then return $ Just $ toCleanup dest move key
|
||||||
else return Nothing -- failed
|
else return Nothing -- failed
|
||||||
Right True -> return $ Just $ toCleanup move remote key
|
Right True -> return $ Just $ toCleanup dest move key
|
||||||
toCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
|
toCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup
|
||||||
toCleanup move remote key = do
|
toCleanup dest move key = do
|
||||||
remoteHasKey remote key True
|
remoteHasKey dest key True
|
||||||
if move
|
if move
|
||||||
then Command.Drop.cleanup key
|
then Command.Drop.cleanup key
|
||||||
else return True
|
else return True
|
||||||
|
@ -103,36 +106,34 @@ toCleanup move remote key = do
|
||||||
- If the current repository already has the content, it is still removed
|
- If the current repository already has the content, it is still removed
|
||||||
- from the other repository when moving.
|
- from the other repository when moving.
|
||||||
-}
|
-}
|
||||||
fromStart :: Bool -> CommandStartString
|
fromStart :: Git.Repo -> Bool -> CommandStartString
|
||||||
fromStart move file = isAnnexed file $ \(key, _) -> do
|
fromStart src move file = isAnnexed file $ \(key, _) -> do
|
||||||
remote <- Remotes.commandLineRemote
|
|
||||||
(trusted, untrusted, _) <- Remotes.keyPossibilities key
|
(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
|
then return Nothing
|
||||||
else do
|
else do
|
||||||
showAction move file
|
showAction move file
|
||||||
return $ Just $ fromPerform move key
|
return $ Just $ fromPerform src move key
|
||||||
fromPerform :: Bool -> Key -> CommandPerform
|
fromPerform :: Git.Repo -> Bool -> Key -> CommandPerform
|
||||||
fromPerform move key = do
|
fromPerform src move key = do
|
||||||
remote <- Remotes.commandLineRemote
|
|
||||||
ishere <- inAnnex key
|
ishere <- inAnnex key
|
||||||
if ishere
|
if ishere
|
||||||
then return $ Just $ fromCleanup move remote key
|
then return $ Just $ fromCleanup src move key
|
||||||
else do
|
else do
|
||||||
showNote $ "from " ++ Git.repoDescribe remote ++ "..."
|
showNote $ "from " ++ Git.repoDescribe src ++ "..."
|
||||||
ok <- getViaTmp key $ Remotes.copyFromRemote remote key
|
ok <- getViaTmp key $ Remotes.copyFromRemote src key
|
||||||
if ok
|
if ok
|
||||||
then return $ Just $ fromCleanup move remote key
|
then return $ Just $ fromCleanup src move key
|
||||||
else return Nothing -- fail
|
else return Nothing -- fail
|
||||||
fromCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
|
fromCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup
|
||||||
fromCleanup True remote key = do
|
fromCleanup src True key = do
|
||||||
ok <- Remotes.onRemote remote (boolSystem, False) "dropkey"
|
ok <- Remotes.onRemote src (boolSystem, False) "dropkey"
|
||||||
["--quiet", "--force",
|
["--quiet", "--force",
|
||||||
"--backend=" ++ backendName key,
|
"--backend=" ++ backendName key,
|
||||||
keyName 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
|
-- even if it seemed to fail; the failure could have occurred
|
||||||
-- after it really dropped it
|
-- after it really dropped it
|
||||||
remoteHasKey remote key False
|
remoteHasKey src key False
|
||||||
return ok
|
return ok
|
||||||
fromCleanup False _ _ = return True
|
fromCleanup _ False _ = return True
|
||||||
|
|
|
@ -8,14 +8,10 @@
|
||||||
module Command.SetKey where
|
module Command.SetKey where
|
||||||
|
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
import Control.Monad (when)
|
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
import qualified Annex
|
|
||||||
import Utility
|
import Utility
|
||||||
import qualified Backend
|
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Types
|
|
||||||
import Content
|
import Content
|
||||||
import Messages
|
import Messages
|
||||||
|
|
||||||
|
@ -29,26 +25,24 @@ seek = [withTempFile start]
|
||||||
{- Sets cached content for a key. -}
|
{- Sets cached content for a key. -}
|
||||||
start :: CommandStartString
|
start :: CommandStartString
|
||||||
start file = do
|
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
|
showStart "setkey" file
|
||||||
return $ Just $ perform file key
|
return $ Just $ perform file
|
||||||
perform :: FilePath -> Key -> CommandPerform
|
|
||||||
perform file key = do
|
perform :: FilePath -> CommandPerform
|
||||||
|
perform file = do
|
||||||
|
key <- cmdlineKey
|
||||||
-- the file might be on a different filesystem, so mv is used
|
-- 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
|
ok <- getViaTmp key $ \dest -> do
|
||||||
if dest /= file
|
if dest /= file
|
||||||
then liftIO $ boolSystem "mv" [file, dest]
|
then liftIO $ boolSystem "mv" [file, dest]
|
||||||
else return True
|
else return True
|
||||||
if ok
|
if ok
|
||||||
then return $ Just $ cleanup key
|
then return $ Just $ cleanup
|
||||||
else error "mv failed!"
|
else error "mv failed!"
|
||||||
|
|
||||||
cleanup :: Key -> CommandCleanup
|
cleanup :: CommandCleanup
|
||||||
cleanup key = do
|
cleanup = do
|
||||||
|
key <- cmdlineKey
|
||||||
logStatus key ValuePresent
|
logStatus key ValuePresent
|
||||||
return True
|
return True
|
||||||
|
|
||||||
|
|
14
GitAnnex.hs
14
GitAnnex.hs
|
@ -13,6 +13,7 @@ import qualified GitRepo as Git
|
||||||
import CmdLine
|
import CmdLine
|
||||||
import Command
|
import Command
|
||||||
import Options
|
import Options
|
||||||
|
import qualified Annex
|
||||||
|
|
||||||
import qualified Command.Add
|
import qualified Command.Add
|
||||||
import qualified Command.Unannex
|
import qualified Command.Unannex
|
||||||
|
@ -65,15 +66,20 @@ cmds = concat
|
||||||
|
|
||||||
options :: [Option]
|
options :: [Option]
|
||||||
options = commonOptions ++
|
options = commonOptions ++
|
||||||
[ Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
|
[ Option ['k'] ["key"] (ReqArg setkey paramKey)
|
||||||
"specify a key to use"
|
"specify a key to use"
|
||||||
, Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
|
, Option ['t'] ["to"] (ReqArg setto paramRemote)
|
||||||
"specify to where to transfer content"
|
"specify to where to transfer content"
|
||||||
, Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
|
, Option ['f'] ["from"] (ReqArg setfrom paramRemote)
|
||||||
"specify from where to transfer content"
|
"specify from where to transfer content"
|
||||||
, Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
|
, Option ['x'] ["exclude"] (ReqArg addexclude paramGlob)
|
||||||
"skip files matching the glob pattern"
|
"skip files matching the glob pattern"
|
||||||
]
|
]
|
||||||
|
where
|
||||||
|
setkey v = Annex.changeState $ \s -> s { Annex.defaultkey = Just v }
|
||||||
|
setto v = Annex.changeState $ \s -> s { Annex.toremote = Just v }
|
||||||
|
setfrom v = Annex.changeState $ \s -> s { Annex.fromremote = Just v }
|
||||||
|
addexclude v = Annex.changeState $ \s -> s { Annex.exclude = v:(Annex.exclude s) }
|
||||||
|
|
||||||
header :: String
|
header :: String
|
||||||
header = "Usage: git-annex command [option ..]"
|
header = "Usage: git-annex command [option ..]"
|
||||||
|
|
|
@ -17,7 +17,7 @@ import qualified Annex
|
||||||
|
|
||||||
verbose :: Annex () -> Annex ()
|
verbose :: Annex () -> Annex ()
|
||||||
verbose a = do
|
verbose a = do
|
||||||
q <- Annex.flagIsSet "quiet"
|
q <- Annex.getState Annex.quiet
|
||||||
unless q a
|
unless q a
|
||||||
|
|
||||||
showSideAction :: String -> Annex ()
|
showSideAction :: String -> Annex ()
|
||||||
|
|
17
Options.hs
17
Options.hs
|
@ -18,19 +18,18 @@ import Command
|
||||||
-}
|
-}
|
||||||
type Option = OptDescr (Annex ())
|
type Option = OptDescr (Annex ())
|
||||||
|
|
||||||
storeOptBool :: Annex.FlagName -> Bool -> Annex ()
|
|
||||||
storeOptBool name val = Annex.flagChange name $ Annex.FlagBool val
|
|
||||||
storeOptString :: Annex.FlagName -> String -> Annex ()
|
|
||||||
storeOptString name val = Annex.flagChange name $ Annex.FlagString val
|
|
||||||
|
|
||||||
commonOptions :: [Option]
|
commonOptions :: [Option]
|
||||||
commonOptions =
|
commonOptions =
|
||||||
[ Option ['f'] ["force"] (NoArg (storeOptBool "force" True))
|
[ Option ['f'] ["force"] (NoArg (setforce True))
|
||||||
"allow actions that may lose annexed data"
|
"allow actions that may lose annexed data"
|
||||||
, Option ['q'] ["quiet"] (NoArg (storeOptBool "quiet" True))
|
, Option ['q'] ["quiet"] (NoArg (setquiet True))
|
||||||
"avoid verbose output"
|
"avoid verbose output"
|
||||||
, Option ['v'] ["verbose"] (NoArg (storeOptBool "quiet" False))
|
, Option ['v'] ["verbose"] (NoArg (setquiet False))
|
||||||
"allow verbose output"
|
"allow verbose output"
|
||||||
, Option ['b'] ["backend"] (ReqArg (storeOptString "backend") paramName)
|
, Option ['b'] ["backend"] (ReqArg setdefaultbackend paramName)
|
||||||
"specify default key-value backend to use"
|
"specify default key-value backend to use"
|
||||||
]
|
]
|
||||||
|
where
|
||||||
|
setforce v = Annex.changeState $ \s -> s { Annex.force = v }
|
||||||
|
setquiet v = Annex.changeState $ \s -> s { Annex.quiet = v }
|
||||||
|
setdefaultbackend v = Annex.changeState $ \s -> s { Annex.defaultbackend = Just v }
|
||||||
|
|
30
Remotes.hs
30
Remotes.hs
|
@ -11,7 +11,6 @@ module Remotes (
|
||||||
keyPossibilities,
|
keyPossibilities,
|
||||||
inAnnex,
|
inAnnex,
|
||||||
same,
|
same,
|
||||||
commandLineRemote,
|
|
||||||
byName,
|
byName,
|
||||||
copyFromRemote,
|
copyFromRemote,
|
||||||
copyToRemote,
|
copyToRemote,
|
||||||
|
@ -69,7 +68,7 @@ tryGitConfigRead r
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
let l = Git.remotes g
|
let l = Git.remotes g
|
||||||
let g' = Git.remotesAdd g $ exchange l r'
|
let g' = Git.remotesAdd g $ exchange l r'
|
||||||
Annex.gitRepoChange g'
|
Annex.changeState $ \s -> s { Annex.repo = g' }
|
||||||
return $ Right r'
|
return $ Right r'
|
||||||
exchange [] _ = []
|
exchange [] _ = []
|
||||||
exchange (old:ls) new =
|
exchange (old:ls) new =
|
||||||
|
@ -93,7 +92,7 @@ tryGitConfigRead r
|
||||||
readConfigs :: Annex ()
|
readConfigs :: Annex ()
|
||||||
readConfigs = do
|
readConfigs = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
remotesread <- Annex.flagIsSet "remotesread"
|
remotesread <- Annex.getState Annex.remotesread
|
||||||
unless remotesread $ do
|
unless remotesread $ do
|
||||||
allremotes <- filterM repoNotIgnored $ Git.remotes g
|
allremotes <- filterM repoNotIgnored $ Git.remotes g
|
||||||
let cheap = filter (not . Git.repoIsUrl) allremotes
|
let cheap = filter (not . Git.repoIsUrl) allremotes
|
||||||
|
@ -105,7 +104,7 @@ readConfigs = do
|
||||||
let todo = cheap ++ doexpensive
|
let todo = cheap ++ doexpensive
|
||||||
unless (null todo) $ do
|
unless (null todo) $ do
|
||||||
_ <- mapM tryGitConfigRead todo
|
_ <- mapM tryGitConfigRead todo
|
||||||
Annex.flagChange "remotesread" $ Annex.FlagBool True
|
Annex.changeState $ \s -> s { Annex.remotesread = True }
|
||||||
where
|
where
|
||||||
cachedUUID r = do
|
cachedUUID r = do
|
||||||
u <- getUUID r
|
u <- getUUID r
|
||||||
|
@ -204,27 +203,22 @@ repoCost r = do
|
||||||
repoNotIgnored :: Git.Repo -> Annex Bool
|
repoNotIgnored :: Git.Repo -> Annex Bool
|
||||||
repoNotIgnored r = do
|
repoNotIgnored r = do
|
||||||
ignored <- repoConfig r "ignore" "false"
|
ignored <- repoConfig r "ignore" "false"
|
||||||
fromName <- Annex.flagGet "fromrepository"
|
to <- match Annex.toremote
|
||||||
toName <- Annex.flagGet "torepository"
|
from <- match Annex.fromremote
|
||||||
let name = if null fromName then toName else fromName
|
if to || from
|
||||||
if not $ null name
|
then return True
|
||||||
then return $ match name
|
|
||||||
else return $ not $ Git.configTrue ignored
|
else return $ not $ Git.configTrue ignored
|
||||||
where
|
where
|
||||||
match name = name == Git.repoRemoteName r
|
match a = do
|
||||||
|
name <- Annex.getState a
|
||||||
|
case name of
|
||||||
|
Nothing -> return False
|
||||||
|
Just n -> return $ n == Git.repoRemoteName r
|
||||||
|
|
||||||
{- Checks if two repos are the same, by comparing their remote names. -}
|
{- Checks if two repos are the same, by comparing their remote names. -}
|
||||||
same :: Git.Repo -> Git.Repo -> Bool
|
same :: Git.Repo -> Git.Repo -> Bool
|
||||||
same a b = Git.repoRemoteName a == Git.repoRemoteName b
|
same a b = Git.repoRemoteName a == Git.repoRemoteName b
|
||||||
|
|
||||||
{- Returns the remote specified by --from or --to, may fail with error. -}
|
|
||||||
commandLineRemote :: Annex Git.Repo
|
|
||||||
commandLineRemote = do
|
|
||||||
fromName <- Annex.flagGet "fromrepository"
|
|
||||||
toName <- Annex.flagGet "torepository"
|
|
||||||
let name = if null fromName then toName else fromName
|
|
||||||
byName name
|
|
||||||
|
|
||||||
{- Looks up a remote by name. -}
|
{- Looks up a remote by name. -}
|
||||||
byName :: String -> Annex Git.Repo
|
byName :: String -> Annex Git.Repo
|
||||||
byName name = do
|
byName name = do
|
||||||
|
|
1
debian/changelog
vendored
1
debian/changelog
vendored
|
@ -1,6 +1,7 @@
|
||||||
git-annex (0.19) UNRELEASED; urgency=low
|
git-annex (0.19) UNRELEASED; urgency=low
|
||||||
|
|
||||||
* Support using the uuidgen command if the uuid command is not available.
|
* Support using the uuidgen command if the uuid command is not available.
|
||||||
|
* Allow --exclude to be specified more than once.
|
||||||
|
|
||||||
-- Joey Hess <joeyh@debian.org> Wed, 19 Jan 2011 18:07:51 -0400
|
-- Joey Hess <joeyh@debian.org> Wed, 19 Jan 2011 18:07:51 -0400
|
||||||
|
|
||||||
|
|
|
@ -258,6 +258,8 @@ Many git-annex commands will stage changes for later `git commit` by you.
|
||||||
Skips files matching the glob pattern. The glob is matched relative to
|
Skips files matching the glob pattern. The glob is matched relative to
|
||||||
the current directory.
|
the current directory.
|
||||||
|
|
||||||
|
This option can be specified multiple times.
|
||||||
|
|
||||||
* --backend=name
|
* --backend=name
|
||||||
|
|
||||||
Specifies which key-value backend to use.
|
Specifies which key-value backend to use.
|
||||||
|
|
Loading…
Add table
Reference in a new issue