Current status:

* building again, but several commands are commented out
* still need to implement global options, file matching options, etc
This commit is contained in:
Joey Hess 2015-07-09 19:03:21 -04:00
parent e59ba5a70b
commit 820b92abab
9 changed files with 133 additions and 100 deletions

View file

@ -52,26 +52,32 @@ import Control.Concurrent.MVar
import qualified Data.Map as M
cmd :: Command
cmd = withOptions syncOptions $
command "sync" SectionCommon
"synchronize local repository with remotes"
(paramRepeating paramRemote) (withParams seek)
cmd = command "sync" SectionCommon
"synchronize local repository with remotes"
(paramRepeating paramRemote) (seek <$$> optParser)
syncOptions :: [Option]
syncOptions =
[ contentOption
, messageOption
, allOption
]
data SyncOptions = SyncOptions
{ syncWith :: CmdParams
, contentOption :: Bool
, messageOption :: Maybe String
, keyOptions :: Maybe KeyOptions
}
contentOption :: Option
contentOption = flagOption [] "content" "also transfer file contents"
optParser :: CmdParamsDesc -> Parser SyncOptions
optParser desc = SyncOptions
<$> cmdParams desc
<*> switch
( long "content"
<> help "also transfer file contents"
)
<*> optional (strOption
( long "message" <> short 'm' <> metavar "MSG"
<> help "commit message"
))
<*> optional parseAllOption
messageOption :: Option
messageOption = fieldOption ['m'] "message" "MSG" "specify commit message"
seek :: CmdParams -> CommandSeek
seek rs = do
seek :: SyncOptions -> CommandSeek
seek o = do
prepMerge
-- There may not be a branch checked out until after the commit,
@ -90,20 +96,20 @@ seek rs = do
)
let withbranch a = a =<< getbranch
remotes <- syncRemotes rs
remotes <- syncRemotes (syncWith o)
let gitremotes = filter Remote.gitSyncableRemote remotes
let dataremotes = filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes
-- Syncing involves many actions, any of which can independently
-- fail, without preventing the others from running.
seekActions $ return $ concat
[ [ commit ]
[ [ commit o ]
, [ withbranch mergeLocal ]
, map (withbranch . pullRemote) gitremotes
, [ mergeAnnex ]
]
whenM (Annex.getFlag $ optionName contentOption) $
whenM (seekSyncContent dataremotes) $
when (contentOption o) $
whenM (seekSyncContent o dataremotes) $
-- Transferring content can take a while,
-- and other changes can be pushed to the git-annex
-- branch on the remotes in the meantime, so pull
@ -151,15 +157,14 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
fastest = fromMaybe [] . headMaybe . Remote.byCost
commit :: CommandStart
commit = ifM (annexAutoCommit <$> Annex.getGitConfig)
commit :: SyncOptions -> CommandStart
commit o = ifM (annexAutoCommit <$> Annex.getGitConfig)
( go
, stop
)
where
go = next $ next $ do
commitmessage <- maybe commitMsg return
=<< Annex.getField (optionName messageOption)
commitmessage <- maybe commitMsg return (messageOption o)
showStart "commit" ""
Annex.Branch.commit "update"
ifM isDirect
@ -372,14 +377,16 @@ newer remote b = do
-
- If any file movements were generated, returns true.
-}
seekSyncContent :: [Remote] -> Annex Bool
seekSyncContent rs = do
seekSyncContent :: SyncOptions -> [Remote] -> Annex Bool
seekSyncContent o rs = do
mvar <- liftIO newEmptyMVar
bloom <- ifM (Annex.getFlag "all")
( Just <$> genBloomFilter (seekworktree mvar [])
, seekworktree mvar [] (const noop) >> pure Nothing
)
withKeyOptions' False (seekkeys mvar bloom) (const noop) []
bloom <- case keyOptions o of
Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])
_ -> seekworktree mvar [] (const noop) >> pure Nothing
withKeyOptions' (keyOptions o) False
(seekkeys mvar bloom)
(const noop)
[]
liftIO $ not <$> isEmptyMVar mvar
where
seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>=