diff options
author | 2015-07-09 16:05:45 -0400 | |
---|---|---|
committer | 2015-07-09 16:05:45 -0400 | |
commit | 525e04af35bb588b4f8a8721cfa77b2b285ac914 (patch) | |
tree | 9d00a7d7066a8ad30c9e6313706d47de2609f82a /Command | |
parent | 87896574f32be5aa1636facc494faeab34cd0845 (diff) |
wip
Diffstat (limited to 'Command')
-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 |
9 files changed, 88 insertions, 70 deletions
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 |