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 optVerbose :: Maybe Bool
, optCache :: Maybe Bool , optCache :: Maybe Bool
, optMetaCache :: Maybe Integer , optMetaCache :: Maybe Integer
, optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI , optUrlSource :: Maybe URI
, optNoVerify :: Maybe Bool , optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs , optKeepDirs :: Maybe KeepDirs
@ -116,6 +117,16 @@ opts =
<$> 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" <> 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 <*> optional
(option (option
(eitherReader parseUri) (eitherReader parseUri)

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

@ -131,7 +131,8 @@ updateSettings UserSettings{..} Settings{..} =
urlSource' = fromMaybe urlSource uUrlSource urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting 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 data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion { instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI , instBindist :: Maybe URI
, instSet :: Bool , instSet :: Bool
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
@ -176,18 +175,8 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool = installOpts tool =
(\p (u, v) b is f -> InstallOptions v p u b is f) (\(u, v) b is f -> InstallOptions v 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"
)
)
<*> ( ( (,)
<$> optional <$> optional
(option (option
(eitherReader uriParser) (eitherReader uriParser)
@ -268,11 +257,10 @@ type InstallEffects = '[ AlreadyInstalled
runInstTool :: AppState runInstTool :: AppState
-> Maybe PlatformRequest
-> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a -> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallEffects a) -> IO (VEither InstallEffects a)
runInstTool appstate' mInstPlatform = runInstTool appstate' =
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) flip runReaderT appstate'
. runResourceT . runResourceT
. runE . runE
@InstallEffects @InstallEffects
@ -302,11 +290,10 @@ type InstallGHCEffects = '[ AlreadyInstalled
] ]
runInstGHC :: AppState runInstGHC :: AppState
-> Maybe PlatformRequest
-> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a -> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallGHCEffects a) -> IO (VEither InstallGHCEffects a)
runInstGHC appstate' mInstPlatform = runInstGHC appstate' =
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) flip runReaderT appstate'
. runResourceT . runResourceT
. runE . runE
@InstallGHCEffects @InstallGHCEffects
@ -331,7 +318,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installGHC InstallOptions{..} = do installGHC InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstGHC s' instPlatform $ do Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin liftE $ runBothE' (installGHCBin
(_tvVersion v) (_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 $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
Just uri -> do Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do runInstGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
@ -403,7 +390,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installCabal InstallOptions{..} = do installCabal InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBin liftE $ runBothE' (installCabalBin
v v
@ -412,7 +399,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
pure vi pure vi
Just uri -> do 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 (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBindist liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
@ -452,7 +439,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installHLS InstallOptions{..} = do installHLS InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
liftE $ runBothE' (installHLSBin liftE $ runBothE' (installHLSBin
v v
@ -461,7 +448,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
pure vi pure vi
Just uri -> do 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 (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy -- TODO: support legacy
liftE $ runBothE' (installHLSBindist liftE $ runBothE' (installHLSBindist
@ -502,7 +489,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
installStack InstallOptions{..} = do installStack InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBin liftE $ runBothE' (installStackBin
v v
@ -511,7 +498,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
pure vi pure vi
Just uri -> do 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 (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBindist liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "") (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 urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal defaultDownloader = Internal
@ -198,14 +199,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let appState = do let appState = do
pfreq <- ( pfreq <- case platformOverride settings of
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest Just pfreq' -> return pfreq'
) >>= \case Nothing -> (runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest) >>= \case
VRight r -> pure r VRight r -> pure r
VLeft e -> do VLeft e -> do
runLogger runLogger
(logError $ T.pack $ prettyShow e) (logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
ghcupInfo <- ghcupInfo <-
( flip runReaderT leanAppstate ( flip runReaderT leanAppstate

11
data/config.yaml
View File

@ -75,3 +75,14 @@ url-source:
# AddSource: # AddSource:
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml" # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.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. 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 ## Env variables
This is the complete list of env variables that change GHCup behavior: 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 , uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool , uNoNetwork :: Maybe Bool
, uGPGSetting :: Maybe GPGSetting , uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings 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 -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing = fromSettings Settings{..} Nothing =
@ -328,16 +329,17 @@ fromSettings Settings{..} Nothing =
, uKeyBindings = Nothing , uKeyBindings = Nothing
, uUrlSource = Just urlSource , uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
} }
fromSettings Settings{..} (Just KeyBindings{..}) = fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings let ukb = UserKeyBindings
{ kUp = Just bUp { kUp = Just bUp
, kDown = Just bDown , kDown = Just bDown
, kQuit = Just bQuit , kQuit = Just bQuit
, kInstall = Just bInstall , kInstall = Just bInstall
, kUninstall = Just bUninstall , kUninstall = Just bUninstall
, kSet = Just bSet , kSet = Just bSet
, kChangelog = Just bChangelog , kChangelog = Just bChangelog
, kShowAll = Just bShowAllVersions , kShowAll = Just bShowAllVersions
, kShowAllTools = Just bShowAllTools , kShowAllTools = Just bShowAllTools
} }
@ -352,6 +354,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uKeyBindings = Just ukb , uKeyBindings = Just ukb
, uUrlSource = Just urlSource , uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
} }
data UserKeyBindings = UserKeyBindings data UserKeyBindings = UserKeyBindings
@ -421,16 +424,17 @@ instance NFData LeanAppState
data Settings = Settings data Settings = Settings
{ cache :: Bool { cache :: Bool
, metaCache :: Integer , metaCache :: Integer
, noVerify :: Bool , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool , verbose :: Bool
, urlSource :: URLSource , urlSource :: URLSource
, noNetwork :: Bool , noNetwork :: Bool
, gpgSetting :: GPGSetting , gpgSetting :: GPGSetting
, noColor :: Bool -- this also exists in LoggerConfig , noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
@ -438,7 +442,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 defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False Nothing
instance NFData Settings 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 } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting 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 instance ToJSON Tag where
toJSON Latest = String "Latest" toJSON Latest = String "Latest"