wip

CmdLine/GitAnnex.hs

@@ -36,7 +36,7 @@ import qualified Command.SetPresentKey
 import qualified Command.ReadPresentKey
 import qualified Command.CheckPresentKey
 import qualified Command.ReKey
-import qualified Command.MetaData
+--import qualified Command.MetaData
 import qualified Command.View
 import qualified Command.VAdd
 import qualified Command.VFilter
@@ -50,8 +50,8 @@ import qualified Command.InitRemote
 import qualified Command.EnableRemote
 import qualified Command.Expire
 import qualified Command.Repair
-import qualified Command.Unused
-import qualified Command.DropUnused
+--import qualified Command.Unused
+--import qualified Command.DropUnused
 import qualified Command.AddUnused
 import qualified Command.Unlock
 import qualified Command.Lock
@@ -59,7 +59,7 @@ import qualified Command.PreCommit
 import qualified Command.Find
 import qualified Command.FindRef
 import qualified Command.Whereis
-import qualified Command.List
+--import qualified Command.List
 import qualified Command.Log
 import qualified Command.Merge
 import qualified Command.ResolveMerge
@@ -72,16 +72,16 @@ import qualified Command.NumCopies
 import qualified Command.Trust
 import qualified Command.Untrust
 import qualified Command.Semitrust
-import qualified Command.Dead
+--import qualified Command.Dead
 import qualified Command.Group
 import qualified Command.Wanted
 import qualified Command.GroupWanted
 import qualified Command.Required
 import qualified Command.Schedule
 import qualified Command.Ungroup
-import qualified Command.Vicfg
+--import qualified Command.Vicfg
 import qualified Command.Sync
-import qualified Command.Mirror
+--import qualified Command.Mirror
 import qualified Command.AddUrl
 #ifdef WITH_FEED
 import qualified Command.ImportFeed
@@ -130,7 +130,7 @@ cmds =
 	, Command.Unlock.editcmd
 	, Command.Lock.cmd
 	, Command.Sync.cmd
-	, Command.Mirror.cmd
+--	, Command.Mirror.cmd
 	, Command.AddUrl.cmd
 #ifdef WITH_FEED
 	, Command.ImportFeed.cmd
@@ -150,14 +150,14 @@ cmds =
 	, Command.Trust.cmd
 	, Command.Untrust.cmd
 	, Command.Semitrust.cmd
-	, Command.Dead.cmd
+--	, Command.Dead.cmd
 	, Command.Group.cmd
 	, Command.Wanted.cmd
 	, Command.GroupWanted.cmd
 	, Command.Required.cmd
 	, Command.Schedule.cmd
 	, Command.Ungroup.cmd
-	, Command.Vicfg.cmd
+--	, Command.Vicfg.cmd
 	, Command.LookupKey.cmd
 	, Command.ContentLocation.cmd
 	, Command.ExamineKey.cmd
@@ -171,7 +171,7 @@ cmds =
 	, Command.ReadPresentKey.cmd
 	, Command.CheckPresentKey.cmd
 	, Command.ReKey.cmd
-	, Command.MetaData.cmd
+--	, Command.MetaData.cmd
 	, Command.View.cmd
 	, Command.VAdd.cmd
 	, Command.VFilter.cmd
@@ -180,13 +180,13 @@ cmds =
 	, Command.Fix.cmd
 	, Command.Expire.cmd
 	, Command.Repair.cmd
-	, Command.Unused.cmd
-	, Command.DropUnused.cmd
+--	, Command.Unused.cmd
+--	, Command.DropUnused.cmd
 	, Command.AddUnused.cmd
 	, Command.Find.cmd
 	, Command.FindRef.cmd
 	, Command.Whereis.cmd
-	, Command.List.cmd
+--	, Command.List.cmd
 	, Command.Log.cmd
 	, Command.Merge.cmd
 	, Command.ResolveMerge.cmd

Command.hs

@@ -8,6 +8,7 @@
 module Command (
 	command,
 	withParams,
+	(<--<),
 	noRepo,
 	noCommit,
 	noMessages,
@@ -46,6 +47,17 @@ command name section desc paramdesc mkparser =
 withParams :: (CmdParams -> v) -> CmdParamsDesc -> O.Parser v
 withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc
 
+{- Uses the supplied option parser, which yields a deferred parse,
+ - and calls finishParse on the result before passing it to the
+ - CommandSeek constructor. -}
+(<--<) :: DeferredParseClass a
+	=> (a -> CommandSeek) 
+	-> (CmdParamsDesc -> Parser a)
+	-> CmdParamsDesc
+	-> Parser CommandSeek
+(<--<) mkseek optparser paramsdesc = 
+	(mkseek <=< finishParse) <$> optparser paramsdesc
+
 {- Indicates that a command doesn't need to commit any changes to
  - the git-annex branch. -}
 noCommit :: Command -> Command

Command/Copy.hs

@@ -17,7 +17,7 @@ import Annex.NumCopies
 cmd :: Command
 cmd = command "copy" SectionCommon
 	"copy content of files to/from another repository"
-	paramPaths ((seek <=< finishParse) <$$> optParser)
+	paramPaths (seek <--< optParser)
 
 data CopyOptions = CopyOptions
 	{ moveOptions :: Command.Move.MoveOptions

Command/Fsck.hs

@@ -34,7 +34,6 @@ import Types.CleanupActions
 import Utility.HumanTime
 import Utility.CopyFile
 import Git.FilePath
-import Git.Types (RemoteName)
 import Utility.PID
 import qualified Database.Fsck as FsckDb
 
@@ -48,11 +47,13 @@ cmd = command "fsck" SectionMaintenance
 
 data FsckOptions = FsckOptions
 	{ fsckFiles :: CmdParams
-	, fsckFromOption :: Maybe RemoteName
+	, fsckFromOption :: Maybe (DeferredParse Remote)
 	, incrementalOpt :: Maybe IncrementalOpt
 	, keyOptions :: Maybe KeyOptions
 	}
 
+-- TODO: annexedMatchingOptions
+
 data IncrementalOpt
 	= StartIncrementalO
 	| MoreIncrementalO
@@ -61,7 +62,7 @@ data IncrementalOpt
 optParser :: CmdParamsDesc -> Parser FsckOptions
 optParser desc = FsckOptions
 	<$> cmdParams desc
-	<*> optional (strOption 
+	<*> optional (parseRemoteOption $ strOption 
 		( long "from" <> short 'f' <> metavar paramRemote 
 		<> help "check remote"
 		))
@@ -82,11 +83,9 @@ optParser desc = FsckOptions
 			<> help "schedule incremental fscking"
 			))
 
--- TODO: annexedMatchingOptions
-
 seek :: FsckOptions -> CommandSeek
 seek o = do
-	from <- Remote.byNameWithUUID (fsckFromOption o)
+	from <- maybe (pure Nothing) (Just <$$> getParsed) (fsckFromOption o)
 	u <- maybe getUUID (pure . Remote.uuid) from
 	i <- prepIncremental u (incrementalOpt o)
 	withKeyOptions (keyOptions o) False

Command/FuzzTest.hs

@@ -55,9 +55,9 @@ guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
 
 fuzz :: Handle -> Annex ()
 fuzz logh = do
-	action <- genFuzzAction
-	record logh $ flip Started action
-	result <- tryNonAsync $ runFuzzAction action
+	fuzzer <- genFuzzAction
+	record logh $ flip Started fuzzer
+	result <- tryNonAsync $ runFuzzAction fuzzer
 	record logh $ flip Finished $
 		either (const False) (const True) result
 

Command/Get.hs

@@ -17,29 +17,39 @@ import Annex.Wanted
 import qualified Command.Move
 
 cmd :: Command
-cmd = withOptions getOptions $ 
-	command "get" SectionCommon 
-		"make content of annexed files available"
-		paramPaths (withParams seek)
+cmd = command "get" SectionCommon 
+	"make content of annexed files available"
+	paramPaths (seek <$$> optParser)
 
-getOptions :: [Option]
-getOptions = fromOption : autoOption : jobsOption : annexedMatchingOptions
-	++ incompleteOption : keyOptions
+data GetOptions = GetOptions
+	{ getFiles :: CmdParams
+	, getFrom :: Maybe (DeferredParse Remote)
+	, autoMode :: Bool
+	, keyOptions :: Maybe KeyOptions
+	}
 
-seek :: CmdParams -> CommandSeek
-seek ps = do
-	from <- getOptionField fromOption Remote.byNameWithUUID
-	auto <- getOptionFlag autoOption
-	withKeyOptions auto
+optParser :: CmdParamsDesc -> Parser GetOptions
+optParser desc = GetOptions
+	<$> cmdParams desc
+	<*> optional parseFromOption
+	<*> parseAutoOption
+	<*> optional (parseKeyOptions True)
+
+-- TODO: jobsOption, annexedMatchingOptions
+
+seek :: GetOptions -> CommandSeek
+seek o = do
+	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)
+	withKeyOptions (keyOptions o) (autoMode o)
 		(startKeys from)
-		(withFilesInGit $ whenAnnexed $ start auto from)
-		ps
+		(withFilesInGit $ whenAnnexed $ start o from)
+		(getFiles o)
 
-start :: Bool -> Maybe Remote -> FilePath -> Key -> CommandStart
-start auto from file key = start' expensivecheck from key (Just file)
+start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart
+start o from file key = start' expensivecheck from key (Just file)
   where
 	expensivecheck
-		| auto = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file)
+		| autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file)
 		| otherwise = return True
 
 startKeys :: Maybe Remote -> Key -> CommandStart

Command/Info.hs

@@ -135,8 +135,8 @@ fileInfo file k = showCustom (unwords ["info", file]) $ do
 
 remoteInfo :: Remote -> Annex ()
 remoteInfo r = showCustom (unwords ["info", Remote.name r]) $ do
-	info <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r
-	l <- selStats (remote_fast_stats r ++ info) (uuid_slow_stats (Remote.uuid r))
+	i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r
+	l <- selStats (remote_fast_stats r ++ i) (uuid_slow_stats (Remote.uuid r))
 	evalStateT (mapM_ showStat l) emptyStatInfo
 	return True
 

Command/Move.hs

@@ -20,7 +20,7 @@ import Logs.Presence
 cmd :: Command
 cmd = command "move" SectionCommon
 	"move content of files to/from another repository"
-	paramPaths ((seek <=< finishParse) <$$> optParser)
+	paramPaths (seek <--< optParser)
 
 data MoveOptions = MoveOptions
 	{ moveFiles :: CmdParams

Command/TransferKey.hs

@@ -16,41 +16,50 @@ import qualified Remote
 import Types.Remote
 
 cmd :: Command
-cmd = withOptions transferKeyOptions $ noCommit $
+cmd = noCommit $
 	command "transferkey" SectionPlumbing
 		"transfers a key from or to a remote"
-		paramKey (withParams seek)
+		paramKey (seek <--< optParser)
 
-transferKeyOptions :: [Option]
-transferKeyOptions = fileOption : fromToOptions
+data TransferKeyOptions = TransferKeyOptions
+	{ keyOptions :: CmdParams 
+	, fromToOptions :: FromToOptions
+	, fileOption :: AssociatedFile
+	}
 
-fileOption :: Option
-fileOption = fieldOption [] "file" paramFile "the associated file"
+optParser :: CmdParamsDesc -> Parser TransferKeyOptions
+optParser desc  = TransferKeyOptions
+	<$> cmdParams desc
+	<*> parseFromToOptions
+	<*> optional (strOption
+		( long "file" <> metavar paramFile
+		<> help "the associated file"
+		))
 
-seek :: CmdParams -> CommandSeek
-seek ps = do
-	to <- getOptionField toOption Remote.byNameWithUUID
-	from <- getOptionField fromOption Remote.byNameWithUUID
-	file <- getOptionField fileOption return
-	withKeys (start to from file) ps
+instance DeferredParseClass TransferKeyOptions where
+	finishParse v = TransferKeyOptions
+		<$> pure (keyOptions v)
+		<*> finishParse (fromToOptions v)
+		<*> pure (fileOption v)
 
-start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart
-start to from file key =
-	case (from, to) of
-		(Nothing, Just dest) -> next $ toPerform dest key file
-		(Just src, Nothing) -> next $ fromPerform src key file
-		_ -> error "specify either --from or --to"
+seek :: TransferKeyOptions -> CommandSeek
+seek o = withKeys (start o) (keyOptions o)
 
-toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
-toPerform remote key file = go Upload file $
+start :: TransferKeyOptions -> Key -> CommandStart
+start o key = case fromToOptions o of
+	ToRemote dest -> next $ toPerform key (fileOption o) =<< getParsed dest
+	FromRemote src -> next $ fromPerform key (fileOption o) =<< getParsed src
+
+toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
+toPerform key file remote = go Upload file $
 	upload (uuid remote) key file forwardRetry noObserver $ \p -> do
 		ok <- Remote.storeKey remote key file p
 		when ok $
 			Remote.logStatus remote key InfoPresent
 		return ok
 
-fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
-fromPerform remote key file = go Upload file $
+fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
+fromPerform key file remote = go Upload file $
 	download (uuid remote) key file forwardRetry noObserver $ \p ->
 		getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
 

Command/TransferKeys.hs

@@ -45,7 +45,7 @@ start = do
 			download (Remote.uuid remote) key file forwardRetry observer $ \p ->
 				getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
 	
-	observer False t info = recordFailedTransfer t info
+	observer False t tinfo = recordFailedTransfer t tinfo
 	observer True _ _ = noop
 
 runRequests
@@ -80,14 +80,14 @@ runRequests readh writeh a = do
 		hFlush writeh
 
 sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
-sendRequest t info h = do
+sendRequest t tinfo h = do
 	hPutStr h $ intercalate fieldSep
 		[ serialize (transferDirection t)
 		, maybe (serialize (fromUUID (transferUUID t)))
 			(serialize . Remote.name)
-			(transferRemote info)
+			(transferRemote tinfo)
 		, serialize (transferKey t)
-		, serialize (associatedFile info)
+		, serialize (associatedFile tinfo)
 		, "" -- adds a trailing null
 		]
 	hFlush h

Command/Version.hs

@@ -44,9 +44,9 @@ start = do
 	liftIO $ do
 
 		showPackageVersion
-		info "local repository version" $ fromMaybe "unknown" v
-		info "supported repository version" supportedVersion
-		info "upgrade supported from repository versions" $
+		vinfo "local repository version" $ fromMaybe "unknown" v
+		vinfo "supported repository version" supportedVersion
+		vinfo "upgrade supported from repository versions" $
 			unwords upgradableVersions
 	stop
 
@@ -55,10 +55,10 @@ startNoRepo _ = showPackageVersion
 
 showPackageVersion :: IO ()
 showPackageVersion = do
-	info "git-annex version" SysConfig.packageversion
-	info "build flags" $ unwords buildFlags
-	info "key/value backends" $ unwords $ map B.name Backend.list
-	info "remote types" $ unwords $ map R.typename Remote.remoteTypes
+	vinfo "git-annex version" SysConfig.packageversion
+	vinfo "build flags" $ unwords buildFlags
+	vinfo "key/value backends" $ unwords $ map B.name Backend.list
+	vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes
 
-info :: String -> String -> IO ()
-info k v = putStrLn $ k ++ ": " ++ v
+vinfo :: String -> String -> IO ()
+vinfo k v = putStrLn $ k ++ ": " ++ v