Add --metadata-fetching-mode arg, fixes #440

This commit is contained in:
Julian Ospald 2023-01-01 19:04:00 +08:00
parent 801b1edfa7
commit 4d82c37539
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
7 changed files with 32 additions and 9 deletions

View File

@ -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 "<Strict|Lax>" <> help "Whether to fail on metadata download failure (Strict) or fall back to cached version (Lax (default))"))
<*> optional
(option
(eitherReader platformParser)

View File

@ -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'

View File

@ -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

View File

@ -40,6 +40,12 @@ key-bindings:
# of the file. These usually are in '~/.ghcup/cache/ghcup-<ver>.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-<ver>.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:

View File

@ -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

View File

@ -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

View File

@ -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