hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Allow to statically overwrite distro detection, fixes #421

Browse Source
This commit is contained in:
Julian Ospald 2022-11-12 14:12:13 +08:00
parent 010db93b93
commit e924ad8278
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
8 changed files with 85 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
app/ghcup/GHCup/OptParse.hs
View File

@ -74,6 +74,7 @@ data Options = Options
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
, optMetaCache :: Maybe Integer
, optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
@ -116,6 +117,16 @@ 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
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> optional
(option
(eitherReader parseUri)

3
app/ghcup/GHCup/OptParse/Config.hs
View File

@ -131,7 +131,8 @@ updateSettings UserSettings{..} Settings{..} =
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
platformOverride' = uPlatformOverride <|> platformOverride
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'

41
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -66,7 +66,6 @@ data InstallCommand = InstallGHC InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
@ -176,18 +175,8 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b is f -> InstallOptions v p u b is f)
<$> optional
(option
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> ( ( (,)
(\(u, v) b is f -> InstallOptions v u b is f)
<$> ( ( (,)
<$> optional
(option
(eitherReader uriParser)
@ -268,11 +257,10 @@ type InstallEffects = '[ AlreadyInstalled
runInstTool :: AppState
-> Maybe PlatformRequest
-> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallEffects a)
runInstTool appstate' mInstPlatform =
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
runInstTool appstate' =
flip runReaderT appstate'
. runResourceT
. runE
@InstallEffects
@ -302,11 +290,10 @@ type InstallGHCEffects = '[ AlreadyInstalled
]
runInstGHC :: AppState
-> Maybe PlatformRequest
-> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallGHCEffects a)
runInstGHC appstate' mInstPlatform =
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
runInstGHC appstate' =
flip runReaderT appstate'
. runResourceT
. runE
@InstallGHCEffects
@ -331,7 +318,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installGHC InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstGHC s' instPlatform $ do
Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin
(_tvVersion v)
@ -342,7 +329,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
pure vi
Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
runInstGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
@ -403,7 +390,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installCabal InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBin
v
@ -412,7 +399,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "")
@ -452,7 +439,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installHLS InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
liftE $ runBothE' (installHLSBin
v
@ -461,7 +448,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy
liftE $ runBothE' (installHLSBindist
@ -502,7 +489,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installStack InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBin
v
@ -511,7 +498,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "")

17
app/ghcup/Main.hs
View File

@ -87,6 +87,7 @@ toSettings options = do
urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
@ -198,14 +199,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let appState = do
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
pfreq <- case platformOverride settings of
Just pfreq' -> return pfreq'
Nothing -> (runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
ghcupInfo <-
( flip runReaderT leanAppstate

11
data/config.yaml
View File

@ -75,3 +75,14 @@ url-source:
# AddSource:
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
# This is a way to override platform detection, e.g. when you're running
# a Ubuntu derivate based on 18.04, you could do:
#
# platform-override:
# arch: A_64
# platform:
# contents: Ubuntu
# tag: Linux
# version: '18.04'
platform-override: null

14
docs/guide.md
View File

@ -71,6 +71,20 @@ explaining all possible configurations can be found in this repo: [config.yaml](
Partial configuration is fine. Command line options always override the config file settings.
## Overriding distro detection
If you're running e.g. an Ubuntu derivate based on 18.04 and ghcup is picking bindists that
don't work well, you could do this in `config.yaml`:
```yml
platform-override:
arch: A_64
platform:
contents: Ubuntu
tag: Linux
version: '18.04'
```
## Env variables
This is the complete list of env variables that change GHCup behavior:

42
lib/GHCup/Types.hs
View File

@ -309,11 +309,12 @@ data UserSettings = UserSettings
, uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool
, uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing =
@ -328,16 +329,17 @@ fromSettings Settings{..} Nothing =
, uKeyBindings = Nothing
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
}
fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings
{ kUp = Just bUp
, kDown = Just bDown
, kQuit = Just bQuit
, kInstall = Just bInstall
, kUninstall = Just bUninstall
, kSet = Just bSet
, kChangelog = Just bChangelog
{ kUp = Just bUp
, kDown = Just bDown
, kQuit = Just bQuit
, kInstall = Just bInstall
, kUninstall = Just bUninstall
, kSet = Just bSet
, kChangelog = Just bChangelog
, kShowAll = Just bShowAllVersions
, kShowAllTools = Just bShowAllTools
}
@ -352,6 +354,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uKeyBindings = Just ukb
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
}
data UserKeyBindings = UserKeyBindings
@ -421,16 +424,17 @@ instance NFData LeanAppState
data Settings = Settings
{ cache :: Bool
, metaCache :: Integer
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
, urlSource :: URLSource
, noNetwork :: Bool
, gpgSetting :: GPGSetting
, noColor :: Bool -- this also exists in LoggerConfig
{ cache :: Bool
, metaCache :: Integer
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
, urlSource :: URLSource
, noNetwork :: Bool
, gpgSetting :: GPGSetting
, noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest
}
deriving (Show, GHC.Generic)
@ -438,7 +442,7 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings
defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False
defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False Nothing
instance NFData Settings

1
lib/GHCup/Types/JSON.hs
View File

@ -56,6 +56,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Global
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "r-") . T.pack . kebab . tail $ str' } ''PlatformRequest
instance ToJSON Tag where
toJSON Latest = String "Latest"