diff options
| -rw-r--r-- | CmdLine/GitAnnex.hs | 12 | ||||
| -rw-r--r-- | Command/Forget.hs | 40 | ||||
| -rw-r--r-- | Command/TestRemote.hs | 43 |
3 files changed, 51 insertions, 44 deletions
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index dd159385a..a4d73877d 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -92,10 +92,10 @@ import qualified Command.Map import qualified Command.Direct import qualified Command.Indirect import qualified Command.Upgrade ---import qualified Command.Forget +import qualified Command.Forget import qualified Command.Proxy import qualified Command.DiffDriver ---import qualified Command.Undo +import qualified Command.Undo import qualified Command.Version #ifdef WITH_ASSISTANT --import qualified Command.Watch @@ -111,7 +111,7 @@ import qualified Command.RemoteDaemon import qualified Command.Test #ifdef WITH_TESTSUITE import qualified Command.FuzzTest ---import qualified Command.TestRemote +import qualified Command.TestRemote #endif #ifdef WITH_EKG import System.Remote.Monitoring @@ -197,10 +197,10 @@ cmds = , Command.Direct.cmd , Command.Indirect.cmd , Command.Upgrade.cmd --- , Command.Forget.cmd + , Command.Forget.cmd , Command.Proxy.cmd , Command.DiffDriver.cmd --- , Command.Undo.cmd + , Command.Undo.cmd , Command.Version.cmd #ifdef WITH_ASSISTANT -- , Command.Watch.cmd @@ -216,7 +216,7 @@ cmds = , Command.Test.cmd #ifdef WITH_TESTSUITE , Command.FuzzTest.cmd --- , Command.TestRemote.cmd + , Command.TestRemote.cmd #endif ] diff --git a/Command/Forget.hs b/Command/Forget.hs index 24789fe44..584b56f8a 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -16,28 +16,30 @@ import qualified Annex import Data.Time.Clock.POSIX cmd :: Command -cmd = withOptions forgetOptions $ - command "forget" SectionMaintenance - "prune git-annex branch history" - paramNothing (withParams seek) - -forgetOptions :: [Option] -forgetOptions = [dropDeadOption] - -dropDeadOption :: Option -dropDeadOption = flagOption [] "drop-dead" "drop references to dead repositories" - -seek :: CmdParams -> CommandSeek -seek ps = do - dropdead <- getOptionFlag dropDeadOption - withNothing (start dropdead) ps - -start :: Bool -> CommandStart -start dropdead = do +cmd = command "forget" SectionMaintenance + "prune git-annex branch history" + paramNothing (seek <$$> optParser) + +data ForgetOptions = ForgetOptions + { dropDead :: Bool + } + +optParser :: CmdParamsDesc -> Parser ForgetOptions +optParser _ = ForgetOptions + <$> switch + ( long "drop-dead" + <> help "drop references to dead repositories" + ) + +seek :: ForgetOptions -> CommandSeek +seek = commandAction . start + +start :: ForgetOptions -> CommandStart +start o = do showStart "forget" "git-annex" now <- liftIO getPOSIXTime let basets = addTransition now ForgetGitHistory noTransitions - let ts = if dropdead + let ts = if dropDead o then addTransition now ForgetDeadRemotes basets else basets next $ perform ts =<< Annex.getState Annex.force diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 250c6f41a..e51dcaeb3 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -27,6 +27,7 @@ import Messages import Types.Messages import Remote.Helper.Chunked import Locations +import Git.Types import Test.Tasty import Test.Tasty.Runners @@ -37,25 +38,29 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as M cmd :: Command -cmd = withOptions [sizeOption] $ - command "testremote" SectionTesting - "test transfers to/from a remote" - paramRemote (withParams seek) - -sizeOption :: Option -sizeOption = fieldOption [] "size" paramSize "base key size (default 1MiB)" - -seek :: CmdParams -> CommandSeek -seek ps = do - basesz <- fromInteger . fromMaybe (1024 * 1024) - <$> getOptionField sizeOption (pure . getsize) - withWords (start basesz) ps - where - getsize v = v >>= readSize dataUnits - -start :: Int -> [String] -> CommandStart -start basesz ws = do - let name = unwords ws +cmd = command "testremote" SectionTesting + "test transfers to/from a remote" + paramRemote (seek <$$> optParser) + +data TestRemoteOptions = TestRemoteOptions + { testRemote :: RemoteName + , sizeOption :: ByteSize + } + +optParser :: CmdParamsDesc -> Parser TestRemoteOptions +optParser desc = TestRemoteOptions + <$> argument str ( metavar desc ) + <*> option (str >>= maybe (fail "parse error") return . readSize dataUnits) + ( long "size" <> metavar paramSize + <> value (1024 * 1024) + <> help "base key size (default 1MiB)" + ) + +seek :: TestRemoteOptions -> CommandSeek +seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o) + +start :: Int -> RemoteName -> CommandStart +start basesz name = do showStart "testremote" name r <- either error id <$> Remote.byName' name showSideAction "generating test keys" |