From ea0f914261e4747de75339952c2d47374c5a7803 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 9 Jul 2015 19:03:21 -0400
Subject: wip

Current status:

* building again, but several commands are commented out
* still need to implement global options, file matching options, etc
---
 Command/Sync.hs | 77 +++++++++++++++++++++++++++++++--------------------------
 1 file changed, 42 insertions(+), 35 deletions(-)

(limited to 'Command/Sync.hs')

diff --git a/Command/Sync.hs b/Command/Sync.hs
index 2f7c4af7f..a5b601076 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -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)
-
-syncOptions :: [Option]
-syncOptions =
-	[ contentOption
-	, messageOption
-	, allOption
-	]
-
-contentOption :: Option
-contentOption = flagOption [] "content" "also transfer file contents"
-
-messageOption :: Option
-messageOption = fieldOption ['m'] "message" "MSG" "specify commit message"
-
-seek :: CmdParams -> CommandSeek
-seek rs = do
+cmd = command "sync" SectionCommon 
+	"synchronize local repository with remotes"
+	(paramRepeating paramRemote) (seek <$$> optParser)
+
+data SyncOptions  = SyncOptions
+	{ syncWith :: CmdParams
+	, contentOption :: Bool
+	, messageOption :: Maybe String
+	, keyOptions :: Maybe KeyOptions
+	}
+
+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
+
+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 >>=
-- 
cgit v1.2.3