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

.github/workflows/release.yaml

@@ -311,9 +311,9 @@ jobs:
 
  - if: matrix.ARCH == 'ARM'
  uses: docker://hasufell/arm32v7-ubuntu-haskell:focal
- name: Run build (armv7 linux)
+ name: Run test (armv7 linux)
  with:
- run: sh .github/scripts/test.sh
+ args: sh .github/scripts/test.sh
  env:
  ARTIFACT: ${{ matrix.ARTIFACT }}
  ARCH: ${{ matrix.ARCH }}
@@ -322,9 +322,9 @@ jobs:
 
  - if: matrix.ARCH == 'ARM64'
  uses: docker://hasufell/arm64v8-ubuntu-haskell:focal
- name: Run build (aarch64 linux)
+ name: Run test (aarch64 linux)
  with:
- run: sh .github/scripts/test.sh
+ args: sh .github/scripts/test.sh
  env:
  ARTIFACT: ${{ matrix.ARTIFACT }}
  ARCH: ${{ matrix.ARCH }}

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
@@ -116,7 +116,8 @@ opts =
  Options
  <$> 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-caching" <> metavar "SEC" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable"))
+ <*> 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)

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'
 
 
 

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

data/config.yaml

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

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

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
 

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