diff --git a/ghcup.cabal b/ghcup.cabal index dcc40c74..c99e6421 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -331,6 +331,7 @@ library ghcup-optparse GHCup.OptParse.List GHCup.OptParse.Nuke GHCup.OptParse.Prefetch + GHCup.OptParse.Reset GHCup.OptParse.Rm GHCup.OptParse.Run GHCup.OptParse.Set diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index 5a4faa2e..5cbc1d5b 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -57,7 +57,6 @@ import GHCup.Utils.Parsers (gpgParser, downloaderParser, keepOnParser, #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif -import Control.Monad.Reader import Data.Either import Data.Functor import Data.Maybe diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index a7d67d3a..72782613 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -19,6 +18,7 @@ import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ import GHCup.OptParse.Common +import GHCup.OptParse.Reset (resetUserConfig, toUserSettingsKey) import GHCup.Version #if !MIN_VERSION_base(4,13,0) @@ -28,6 +28,7 @@ import Control.Monad (when) import Control.Exception ( displayException ) import Control.Monad.Reader import Control.Monad.Trans.Resource +import Data.Foldable (foldl') import Data.Functor import Data.Maybe import Data.Variant.Excepts @@ -52,10 +53,13 @@ import Control.Exception.Safe (MonadMask) data ConfigCommand = ShowConfig | SetConfig String (Maybe String) + | ResetConfig ResetCommand | InitConfig | AddReleaseChannel Bool NewURLSource deriving (Eq, Show) +data ResetCommand = ResetKeys [String] | ResetAll + deriving (Eq, Show) --------------- @@ -67,6 +71,7 @@ configP :: Parser ConfigCommand configP = subparser ( command "init" initP <> command "set" setP -- [set] KEY VALUE at help lhs + <> command "reset" resetP <> command "show" showP <> command "add-release-channel" addP ) @@ -74,15 +79,24 @@ configP = subparser where initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml") showP = info (pure ShowConfig) (progDesc "Show current config (default)") - setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter)) - argsP = SetConfig <$> argument str (metavar "") <*> optional (argument str (metavar "YAML_VALUE")) + setP = info setArgsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter)) + setArgsP = SetConfig <$> argument str (metavar "") <*> optional (argument str (metavar "YAML_VALUE")) + resetP = info resetArgsP + (progDesc "Reset the whole config or just specific keys" <> footerDoc (Just $ text configResetFooter)) + resetArgsP = ResetConfig <$> subparser + ( command "all" + (info (pure ResetAll) (progDesc "Reset the whole config")) + <> command "keys" + (info resetKeysP (progDesc "Reset specific keys of the config")) + ) + resetKeysP = ResetKeys <$> some (strArgument + ( metavar "YAML_KEY" + <> help "Specify key(s)" )) addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader parseNewUrlSource) (metavar "" <> completer urlSourceCompleter)) (progDesc "Add a release channel, e.g. from a URI or using alias") - - -------------- --[ Footer ]-- -------------- @@ -100,6 +114,9 @@ configFooter = [s|Examples: # set configuration pair ghcup config set + # reset config key(s) + ghcup config reset keys ... + # add a release channel ghcup config add-release-channel prereleases|] @@ -120,6 +137,16 @@ configSetFooter = [s|Examples: # set mirror for ghcup metadata ghcup config set '{url-source: { OwnSource: ""}}'|] +configResetFooter :: String +configResetFooter = [s|Examples: + # reset the whole config + ghcup config reset all + + # reset one key (cache) + ghcup config reset keys cache + + # reset some keys (cache, url-source and downloader) + ghcup config reset keys cache url-source downloader|] ----------------- @@ -224,6 +251,29 @@ config configCommand settings userConf keybindings runLogger = case configComman VLeft e -> do runLogger (logError $ T.pack $ prettyHFError e) pure $ ExitFailure 65 + (ResetConfig resetCommand) -> do + r <- runE @'[ParseError] $ do + case resetCommand of + ResetAll -> do + lift $ doReset defaultUserSettings + pure () + ResetKeys stringKeys -> do + lift $ runLogger $ logDebug $ "Raw keys: " <> T.pack (show stringKeys) + let eKeys = traverse toUserSettingsKey stringKeys + lift $ runLogger $ logDebug $ "Handled keys: " <> T.pack (show eKeys) + case eKeys of + Left invalidString -> do + throwE $ ParseError $ "Key <<" <> invalidString <> ">> is invalid" + Right keys -> do + lift $ runLogger $ logDebug $ "userConf: " <> T.pack (show userConf) + let newUserConf = foldl' (\conf key -> resetUserConfig conf key ) userConf keys + lift $ doReset newUserConf + pure () + case r of + VRight _ -> pure ExitSuccess + VLeft e -> do + runLogger (logError $ T.pack $ prettyHFError e) + pure $ ExitFailure 65 AddReleaseChannel force new -> do r <- runE @'[DuplicateReleaseChannel] $ do @@ -260,4 +310,11 @@ config configCommand settings userConf keybindings runLogger = case configComman runLogger $ logDebug $ T.pack $ show settings' pure () + doReset :: MonadIO m => UserSettings -> m () + doReset resetUserSettings = do + path <- liftIO getConfigFilePath + liftIO $ writeFile path $ formatConfig $ resetUserSettings + runLogger $ logDebug $ "reset to config: " <> T.pack (show resetUserSettings) + pure () + decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString diff --git a/lib-opt/GHCup/OptParse/Reset.hs b/lib-opt/GHCup/OptParse/Reset.hs new file mode 100644 index 00000000..a89a1ba2 --- /dev/null +++ b/lib-opt/GHCup/OptParse/Reset.hs @@ -0,0 +1,65 @@ +module GHCup.OptParse.Reset where + +import GHCup.Types (UserSettings(..)) + +-- UserSettingsKey constructors correspond to UserSettings fields +data UserSettingsKey + = Cache + | MetaCache + | MetaMode + | NoVerify + | Verbose + | KeepDirs + | Downloader + | KeyBindings + | UrlSource + | NoNetwork + | GPGSetting + | PlatformOverride + | Mirrors + | DefGHCConfOptions + | Pager + | GuessVersion + deriving (Show, Eq) + +toUserSettingsKey :: String -> Either String UserSettingsKey +toUserSettingsKey = \case + "cache" -> Right Cache + "meta-cache" -> Right MetaCache + "meta-mode" -> Right MetaMode + "no-verify" -> Right NoVerify + "verbose" -> Right Verbose + "keep-dirs" -> Right KeepDirs + "downloader" -> Right Downloader + "key-bindings" -> Right KeyBindings + "url-source" -> Right UrlSource + "no-network" -> Right NoNetwork + "gpg-setting" -> Right GPGSetting + "platform-override" -> Right PlatformOverride + "mirrors" -> Right Mirrors + "def-ghc-conf-options" -> Right DefGHCConfOptions + "pager" -> Right Pager + "guess-version" -> Right GuessVersion + invalidString -> Left invalidString + +resetUserConfig :: + UserSettings -> UserSettingsKey -> UserSettings +resetUserConfig settings key = case key of + Cache -> settings { uCache = Nothing } + MetaCache -> settings { uMetaCache = Nothing } + MetaMode -> settings { uMetaMode = Nothing } + NoVerify -> settings { uNoVerify = Nothing } + Verbose -> settings { uVerbose = Nothing } + KeepDirs -> settings { uKeepDirs = Nothing } + Downloader -> settings { uDownloader = Nothing } + KeyBindings -> settings { uKeyBindings = Nothing } + UrlSource -> settings { uUrlSource = Nothing } + NoNetwork -> settings { uNoNetwork = Nothing } + GPGSetting -> settings { uGPGSetting = Nothing } + PlatformOverride -> settings { uPlatformOverride = Nothing } + Mirrors -> settings { uMirrors = Nothing } + DefGHCConfOptions -> settings { uDefGHCConfOptions = Nothing } + Pager -> settings { uPager = Nothing } + GuessVersion -> settings { uGuessVersion = Nothing } + + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 8151368d..788d9196 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -400,6 +400,8 @@ data MetaMode = Strict instance NFData MetaMode +-- If you add, remove, or rename any fields, +-- make sure to update the GHCup.OptParse.Reset module as well. data UserSettings = UserSettings { uCache :: Maybe Bool , uMetaCache :: Maybe Integer diff --git a/test/optparse-test/ConfigTest.hs b/test/optparse-test/ConfigTest.hs index 883913b3..28fd6e41 100644 --- a/test/optparse-test/ConfigTest.hs +++ b/test/optparse-test/ConfigTest.hs @@ -48,6 +48,24 @@ checkList = , AddReleaseChannel False (NewChannelAlias VanillaChannel) ) , ("config set cache true", SetConfig "cache" (Just "true")) + , ("config reset all", ResetConfig ResetAll) + , ("config reset keys cache downloader", ResetConfig (ResetKeys ["cache", "downloader"])) + , ("config reset keys cache", ResetConfig (ResetKeys ["cache"])) + , ("config reset keys meta-cache", ResetConfig (ResetKeys ["meta-cache"])) + , ("config reset keys meta-mode", ResetConfig (ResetKeys ["meta-mode"])) + , ("config reset keys no-verify", ResetConfig (ResetKeys ["no-verify"])) + , ("config reset keys verbose", ResetConfig (ResetKeys ["verbose"])) + , ("config reset keys keep-dirs", ResetConfig (ResetKeys ["keep-dirs"])) + , ("config reset keys downloader", ResetConfig (ResetKeys ["downloader"])) + , ("config reset keys key-bindings", ResetConfig (ResetKeys ["key-bindings"])) + , ("config reset keys url-source", ResetConfig (ResetKeys ["url-source"])) + , ("config reset keys no-network", ResetConfig (ResetKeys ["no-network"])) + , ("config reset keys gpg-setting", ResetConfig (ResetKeys ["gpg-setting"])) + , ("config reset keys platform-override", ResetConfig (ResetKeys ["platform-override"])) + , ("config reset keys mirrors", ResetConfig (ResetKeys ["mirrors"])) + , ("config reset keys def-ghc-conf-options", ResetConfig (ResetKeys ["def-ghc-conf-options"])) + , ("config reset keys pager", ResetConfig (ResetKeys ["pager"])) + , ("config reset keys guess-version", ResetConfig (ResetKeys ["guess-version"])) ] configParseWith :: [String] -> IO ConfigCommand