Compare commits

..

3 Commits

Author SHA1 Message Date
e116a2392e Enable arm tests 2023-01-01 21:40:04 +08:00
7dd6f1f4a4 Expose metadata-caching to --help 2023-01-01 19:19:37 +08:00
4d82c37539 Add --metadata-fetching-mode arg, fixes #440 2023-01-01 19:16:32 +08:00
10 changed files with 69 additions and 44 deletions

View File

@@ -87,29 +87,39 @@ download_cabal_cache() {
cd /tmp cd /tmp
case "${RUNNER_OS}" in case "${RUNNER_OS}" in
"Linux") "Linux")
case "${ARCH}" in case "${DISTRO}" in
"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/i386-linux-cabal-cache "Alpine")
case "${ARCH}" in
"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/i386-linux-alpine-cabal-cache-1.0.5.1
;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-linux-alpine-cabal-cache-1.0.5.1
;;
esac
;; ;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-linux-cabal-cache *)
;; case "${ARCH}" in
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-linux-cabal-cache "64") url=https://github.com/haskell-works/cabal-cache/releases/download/v1.0.5.1/cabal-cache-x86_64-linux.gz
;; ;;
"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/armv7-linux-cabal-cache "ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-linux-cabal-cache-1.0.5.1
;;
"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/armv7-linux-cabal-cache-1.0.5.1
;;
esac
;; ;;
esac esac
;; ;;
"FreeBSD") "FreeBSD")
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-portbld-freebsd-cabal-cache url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-freebsd-cabal-cache-1.0.5.1
;; ;;
"Windows") "Windows")
exe=".exe" exe=".exe"
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-mingw64-cabal-cache url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-mingw64-cabal-cache-1.0.5.1.exe
;; ;;
"macOS") "macOS")
case "${ARCH}" in case "${ARCH}" in
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-apple-darwin-cabal-cache "ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-apple-darwin-cabal-cache-1.0.5.1
;; ;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-apple-darwin-cabal-cache "64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-apple-darwin-cabal-cache-1.0.5.1
;; ;;
esac esac
;; ;;
@@ -124,9 +134,8 @@ download_cabal_cache() {
curl -o cabal-cache${exe} -L "${url}" curl -o cabal-cache${exe} -L "${url}"
;; ;;
esac esac
sha_sum cabal-cache${exe} chmod +x cabal-cache${exe}
mv "cabal-cache${exe}" "${dest}${exe}" cp "cabal-cache${exe}" "${dest}${exe}"
chmod +x "${dest}${exe}"
fi fi
) )
} }

View File

@@ -102,7 +102,7 @@ jobs:
- uses: docker://arm64v8/ubuntu:focal - uses: docker://arm64v8/ubuntu:focal
name: Cleanup (aarch64 linux) name: Cleanup (aarch64 linux)
with: with:
args: "find . -mindepth 1 -maxdepth 1 -exec rm -rf -- {} +" args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
- name: git config - name: git config
run: | run: |
@@ -297,7 +297,7 @@ jobs:
- uses: docker://arm64v8/ubuntu:focal - uses: docker://arm64v8/ubuntu:focal
name: Cleanup (aarch64 linux) name: Cleanup (aarch64 linux)
with: with:
args: "find . -mindepth 1 -maxdepth 1 -exec rm -rf -- {} +" args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
- name: Checkout code - name: Checkout code
uses: actions/checkout@v3 uses: actions/checkout@v3
@@ -311,7 +311,7 @@ jobs:
- if: matrix.ARCH == 'ARM' - if: matrix.ARCH == 'ARM'
uses: docker://hasufell/arm32v7-ubuntu-haskell:focal uses: docker://hasufell/arm32v7-ubuntu-haskell:focal
name: Run build (armv7 linux) name: Run test (armv7 linux)
with: with:
args: sh .github/scripts/test.sh args: sh .github/scripts/test.sh
env: env:
@@ -322,7 +322,7 @@ jobs:
- if: matrix.ARCH == 'ARM64' - if: matrix.ARCH == 'ARM64'
uses: docker://hasufell/arm64v8-ubuntu-haskell:focal uses: docker://hasufell/arm64v8-ubuntu-haskell:focal
name: Run build (aarch64 linux) name: Run test (aarch64 linux)
with: with:
args: sh .github/scripts/test.sh args: sh .github/scripts/test.sh
env: env:

View File

@@ -67,13 +67,13 @@ import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
data Options = Options data Options = Options
{ {
-- global options -- global options
optVerbose :: Maybe Bool optVerbose :: Maybe Bool
, optCache :: Maybe Bool , optCache :: Maybe Bool
, optMetaCache :: Maybe Integer , optMetaCache :: Maybe Integer
, optMetaMode :: Maybe MetaMode
, optPlatform :: Maybe PlatformRequest , optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI , optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool , optNoVerify :: Maybe Bool
@@ -116,7 +116,8 @@ opts =
Options Options
<$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)") <$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")
<*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (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 <*> optional
(option (option
(eitherReader platformParser) (eitherReader platformParser)

View File

@@ -59,7 +59,7 @@ data ConfigCommand
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
configP :: Parser ConfigCommand configP :: Parser ConfigCommand
configP = subparser configP = subparser
( command "init" initP ( command "init" initP
@@ -124,6 +124,7 @@ updateSettings :: UserSettings -> Settings -> Settings
updateSettings UserSettings{..} Settings{..} = updateSettings UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache let cache' = fromMaybe cache uCache
metaCache' = fromMaybe metaCache uMetaCache metaCache' = fromMaybe metaCache uMetaCache
metaMode' = fromMaybe metaMode uMetaMode
noVerify' = fromMaybe noVerify uNoVerify noVerify' = fromMaybe noVerify uNoVerify
keepDirs' = fromMaybe keepDirs uKeepDirs keepDirs' = fromMaybe keepDirs uKeepDirs
downloader' = fromMaybe downloader uDownloader downloader' = fromMaybe downloader uDownloader
@@ -132,7 +133,7 @@ updateSettings UserSettings{..} Settings{..} =
noNetwork' = fromMaybe noNetwork uNoNetwork noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting gpgSetting' = fromMaybe gpgSetting uGPGSetting
platformOverride' = uPlatformOverride <|> platformOverride 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 = mergeConf Options{..} UserSettings{..} noColor =
let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache
metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache
metaMode = fromMaybe (fromMaybe (Types.metaMode defaultSettings) uMetaMode) optMetaMode
noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs 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'. # of the file. These usually are in '~/.ghcup/cache/ghcup-<ver>.yaml'.
meta-cache: 300 # in seconds 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 # Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
# check the 'URLSource' type in the code. # check the 'URLSource' type in the code.
url-source: url-source:

View File

@@ -162,17 +162,21 @@ getBase :: ( MonadReader env m
, MonadMask m , MonadMask m
) )
=> URI => URI
-> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo -> Excepts '[DownloadFailed, GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
getBase uri = do 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, -- try to download yaml... usually this writes it into cache dir,
-- but in some cases not (e.g. when using file://), so we honour -- but in some cases not (e.g. when using file://), so we honour
-- the return filepath, if any -- the return filepath, if any
mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
then pure Nothing then pure Nothing
else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing) else handleIO (\e -> case metaMode of
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing) 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 . fmap Just
. smartDl . smartDl
$ uri $ uri

View File

@@ -297,10 +297,16 @@ instance NFData URLSource
instance NFData (URIRef Absolute) where instance NFData (URIRef Absolute) where
rnf (URI !_ !_ !_ !_ !_) = () rnf (URI !_ !_ !_ !_ !_) = ()
data MetaMode = Strict
| Lax
deriving (Show, Read, Eq, GHC.Generic)
instance NFData MetaMode
data UserSettings = UserSettings data UserSettings = UserSettings
{ uCache :: Maybe Bool { uCache :: Maybe Bool
, uMetaCache :: Maybe Integer , uMetaCache :: Maybe Integer
, uMetaMode :: Maybe MetaMode
, uNoVerify :: Maybe Bool , uNoVerify :: Maybe Bool
, uVerbose :: Maybe Bool , uVerbose :: Maybe Bool
, uKeepDirs :: Maybe KeepDirs , uKeepDirs :: Maybe KeepDirs
@@ -314,13 +320,14 @@ data UserSettings = UserSettings
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings 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 -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing = fromSettings Settings{..} Nothing =
UserSettings { UserSettings {
uCache = Just cache uCache = Just cache
, uMetaCache = Just metaCache , uMetaCache = Just metaCache
, uMetaMode = Just metaMode
, uNoVerify = Just noVerify , uNoVerify = Just noVerify
, uVerbose = Just verbose , uVerbose = Just verbose
, uKeepDirs = Just keepDirs , uKeepDirs = Just keepDirs
@@ -346,6 +353,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
in UserSettings { in UserSettings {
uCache = Just cache uCache = Just cache
, uMetaCache = Just metaCache , uMetaCache = Just metaCache
, uMetaMode = Just metaMode
, uNoVerify = Just noVerify , uNoVerify = Just noVerify
, uVerbose = Just verbose , uVerbose = Just verbose
, uKeepDirs = Just keepDirs , uKeepDirs = Just keepDirs
@@ -426,6 +434,7 @@ instance NFData LeanAppState
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
, metaCache :: Integer , metaCache :: Integer
, metaMode :: MetaMode
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
@@ -442,7 +451,7 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings 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 instance NFData Settings

View File

@@ -43,6 +43,7 @@ import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC import qualified Text.Megaparsec.Char as MPC
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MetaMode
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep

View File

@@ -465,22 +465,15 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadMask m , MonadMask m
, MonadIO m) , MonadIO m)
=> m GHCupPath => m GHCupPath
withGHCupTmpDir = do withGHCupTmpDir = snd <$> withRunInIO (\run ->
Settings{keepDirs} <- getSettings run
snd <$> withRunInIO (\run -> $ allocate
run (run mkGhcupTmpDir)
$ allocate (\fp ->
(run mkGhcupTmpDir) handleIO (\e -> run
(\fp -> if -- we don't know whether there was a failure, so can only $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
-- decide for 'Always' . removePathForcibly
| keepDirs == Always -> pure () $ fp))
| otherwise -> handleIO (\e -> run
$ logDebug ("Resource cleanup failed for "
<> T.pack (fromGHCupPath fp)
<> ", error was: "
<> T.pack (displayException e)))
. removePathForcibly
$ fp))