diff options
| -rw-r--r-- | CmdLine/GitAnnex.hs | 28 | ||||
| -rw-r--r-- | Command.hs | 12 | ||||
| -rw-r--r-- | Command/Copy.hs | 2 | ||||
| -rw-r--r-- | Command/Fsck.hs | 11 | ||||
| -rw-r--r-- | Command/FuzzTest.hs | 6 | ||||
| -rw-r--r-- | Command/Get.hs | 44 | ||||
| -rw-r--r-- | Command/Info.hs | 4 | ||||
| -rw-r--r-- | Command/Move.hs | 2 | ||||
| -rw-r--r-- | Command/TransferKey.hs | 63 | ||||
| -rw-r--r-- | Command/TransferKeys.hs | 8 | ||||
| -rw-r--r-- | Command/Version.hs | 18 |
11 files changed, 114 insertions, 84 deletions
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index fc323a49b..c42ba2a2d 100644 --- a/CmdLine/GitAnnex.hs +++ b/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 diff --git a/Command.hs b/Command.hs index e3508d68c..df72ad2a7 100644 --- a/Command.hs +++ b/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 diff --git a/Command/Copy.hs b/Command/Copy.hs index a4f157e2f..1c817f67c 100644 --- a/Command/Copy.hs +++ b/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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index dbeeefbcd..0c5251ecb 100644 --- a/Command/Fsck.hs +++ b/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 diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index e15632c81..fd888e0df 100644 --- a/Command/FuzzTest.hs +++ b/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 diff --git a/Command/Get.hs b/Command/Get.hs index 297f5d27b..3af09b642 100644 --- a/Command/Get.hs +++ b/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 diff --git a/Command/Info.hs b/Command/Info.hs index 3012d4649..9b9e8f6ca 100644 --- a/Command/Info.hs +++ b/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 diff --git a/Command/Move.hs b/Command/Move.hs index 153114f8b..087ea0a7b 100644 --- a/Command/Move.hs +++ b/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 diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index de4568f3a..04dbc1799 100644 --- a/Command/TransferKey.hs +++ b/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) - -transferKeyOptions :: [Option] -transferKeyOptions = fileOption : fromToOptions - -fileOption :: Option -fileOption = fieldOption [] "file" paramFile "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 - -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" - -toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform -toPerform remote key file = go Upload file $ + paramKey (seek <--< optParser) + +data TransferKeyOptions = TransferKeyOptions + { keyOptions :: CmdParams + , fromToOptions :: FromToOptions + , fileOption :: AssociatedFile + } + +optParser :: CmdParamsDesc -> Parser TransferKeyOptions +optParser desc = TransferKeyOptions + <$> cmdParams desc + <*> parseFromToOptions + <*> optional (strOption + ( long "file" <> metavar paramFile + <> help "the associated file" + )) + +instance DeferredParseClass TransferKeyOptions where + finishParse v = TransferKeyOptions + <$> pure (keyOptions v) + <*> finishParse (fromToOptions v) + <*> pure (fileOption v) + +seek :: TransferKeyOptions -> CommandSeek +seek o = withKeys (start o) (keyOptions o) + +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 diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 755a7ef3e..67f201024 100644 --- a/Command/TransferKeys.hs +++ b/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 diff --git a/Command/Version.hs b/Command/Version.hs index 38c799675..9896f671e 100644 --- a/Command/Version.hs +++ b/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 |