From 4d82c3753987639c90610d0dc6de3ec61b397ac8 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 1 Jan 2023 19:04:00 +0800 Subject: [PATCH] Add --metadata-fetching-mode arg, fixes #440 --- app/ghcup/GHCup/OptParse.hs | 3 ++- app/ghcup/GHCup/OptParse/Config.hs | 5 +++-- app/ghcup/Main.hs | 1 + data/config.yaml | 6 ++++++ lib/GHCup/Download.hs | 12 ++++++++---- lib/GHCup/Types.hs | 13 +++++++++++-- lib/GHCup/Types/JSON.hs | 1 + 7 files changed, 32 insertions(+), 9 deletions(-) diff --git a/app/ghcup/GHCup/OptParse.hs b/app/ghcup/GHCup/OptParse.hs index 151d47b..cf2d582 100644 --- a/app/ghcup/GHCup/OptParse.hs +++ b/app/ghcup/GHCup/OptParse.hs @@ -67,13 +67,13 @@ import URI.ByteString import qualified Data.ByteString.UTF8 as UTF8 - data Options = Options { -- global options optVerbose :: Maybe Bool , optCache :: Maybe Bool , optMetaCache :: Maybe Integer + , optMetaMode :: Maybe MetaMode , optPlatform :: Maybe PlatformRequest , optUrlSource :: Maybe URI , optNoVerify :: Maybe Bool @@ -117,6 +117,7 @@ opts = <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)") <*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)") <*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal)) + <*> optional (option auto (long "metadata-fetching-mode" <> metavar "" <> help "Whether to fail on metadata download failure (Strict) or fall back to cached version (Lax (default))")) <*> optional (option (eitherReader platformParser) diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index b182cf8..26b6428 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -59,7 +59,7 @@ data ConfigCommand --[ Parsers ]-- --------------- - + configP :: Parser ConfigCommand configP = subparser ( command "init" initP @@ -124,6 +124,7 @@ updateSettings :: UserSettings -> Settings -> Settings updateSettings UserSettings{..} Settings{..} = let cache' = fromMaybe cache uCache metaCache' = fromMaybe metaCache uMetaCache + metaMode' = fromMaybe metaMode uMetaMode noVerify' = fromMaybe noVerify uNoVerify keepDirs' = fromMaybe keepDirs uKeepDirs downloader' = fromMaybe downloader uDownloader @@ -132,7 +133,7 @@ updateSettings UserSettings{..} Settings{..} = noNetwork' = fromMaybe noNetwork uNoNetwork gpgSetting' = fromMaybe gpgSetting uGPGSetting platformOverride' = uPlatformOverride <|> platformOverride - in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' + in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c480a62..5cb7a5f 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -79,6 +79,7 @@ toSettings options = do mergeConf Options{..} UserSettings{..} noColor = let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache + metaMode = fromMaybe (fromMaybe (Types.metaMode defaultSettings) uMetaMode) optMetaMode noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs diff --git a/data/config.yaml b/data/config.yaml index 8252ab0..09b56a5 100644 --- a/data/config.yaml +++ b/data/config.yaml @@ -40,6 +40,12 @@ key-bindings: # of the file. These usually are in '~/.ghcup/cache/ghcup-.yaml'. meta-cache: 300 # in seconds +# When trying to download ghcup metadata, this option decides what to do +# when the download fails: +# 1. Lax: use existing ~/.ghcup/cache/ghcup-.yaml as fallback (default) +# 2. Strict: fail hard +meta-mode: Lax # Strict | Lax + # Where to get GHC/cabal/hls download info/versions from. For more detailed explanation # check the 'URLSource' type in the code. url-source: diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 382f6bc..1a5df50 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -162,17 +162,21 @@ getBase :: ( MonadReader env m , MonadMask m ) => URI - -> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo + -> Excepts '[DownloadFailed, GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo getBase uri = do - Settings { noNetwork, downloader } <- lift getSettings + Settings { noNetwork, downloader, metaMode } <- lift getSettings -- try to download yaml... usually this writes it into cache dir, -- but in some cases not (e.g. when using file://), so we honour -- the return filepath, if any mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through then pure Nothing - else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing) - . catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing) + else handleIO (\e -> case metaMode of + Strict -> throwIO e + Lax -> lift (warnCache (displayException e) downloader) >> pure Nothing) + . catchE @_ @_ @'[DownloadFailed] (\e@(DownloadFailed _) -> case metaMode of + Strict -> throwE e + Lax -> lift (warnCache (prettyShow e) downloader) >> pure Nothing) . fmap Just . smartDl $ uri diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 0564534..34f799a 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -297,10 +297,16 @@ instance NFData URLSource instance NFData (URIRef Absolute) where rnf (URI !_ !_ !_ !_ !_) = () +data MetaMode = Strict + | Lax + deriving (Show, Read, Eq, GHC.Generic) + +instance NFData MetaMode data UserSettings = UserSettings { uCache :: Maybe Bool , uMetaCache :: Maybe Integer + , uMetaMode :: Maybe MetaMode , uNoVerify :: Maybe Bool , uVerbose :: Maybe Bool , uKeepDirs :: Maybe KeepDirs @@ -314,13 +320,14 @@ data UserSettings = UserSettings deriving (Show, GHC.Generic) defaultUserSettings :: UserSettings -defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings Settings{..} Nothing = UserSettings { uCache = Just cache , uMetaCache = Just metaCache + , uMetaMode = Just metaMode , uNoVerify = Just noVerify , uVerbose = Just verbose , uKeepDirs = Just keepDirs @@ -346,6 +353,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) = in UserSettings { uCache = Just cache , uMetaCache = Just metaCache + , uMetaMode = Just metaMode , uNoVerify = Just noVerify , uVerbose = Just verbose , uKeepDirs = Just keepDirs @@ -426,6 +434,7 @@ instance NFData LeanAppState data Settings = Settings { cache :: Bool , metaCache :: Integer + , metaMode :: MetaMode , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader @@ -442,7 +451,7 @@ defaultMetaCache :: Integer defaultMetaCache = 300 -- 5 minutes defaultSettings :: Settings -defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False Nothing +defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing instance NFData Settings diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index c209421..e6c8865 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -43,6 +43,7 @@ import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MPC +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MetaMode deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep