wip
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:
parent
e59ba5a70b
commit
820b92abab
9 changed files with 133 additions and 100 deletions
|
@ -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 >>=
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue