From a5fb313f889cedc1ecdb8f7dfcbb52c86250909c Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 15 Nov 2024 19:13:06 +0900 Subject: [PATCH 1/5] Support aliases in config, 'config add-release-channel' and '--url-source' Add the URIs of known release channels in code, and allow choosing them via aliases. --- lib-opt/GHCup/OptParse.hs | 2 +- lib-opt/GHCup/OptParse/Common.hs | 2 +- lib-opt/GHCup/OptParse/Config.hs | 19 +++++++++++++++---- lib/GHCup/Download.hs | 1 + lib/GHCup/Types.hs | 13 +++++++++++++ lib/GHCup/Types/JSON.hs | 14 +++++++++++++- lib/GHCup/Utils/Parsers.hs | 9 ++++++++- lib/GHCup/Version.hs | 6 ++++++ test/optparse-test/ConfigTest.hs | 11 ++++++++++- 9 files changed, 68 insertions(+), 9 deletions(-) diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index 72a89977..1e8a412e 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -143,7 +143,7 @@ opts = (eitherReader parseUrlSource) ( short 's' <> long "url-source" - <> metavar "URL_SOURCE" + <> metavar "" <> help "Alternative ghcup download info" <> internal <> completer urlSourceCompleter diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index d7ff3f5f..a7b90782 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -148,7 +148,7 @@ urlSourceCompleter = mkCompleter $ urlSourceCompleter' [] urlSourceCompleter' :: [String] -> String -> IO [String] urlSourceCompleter' add str' = do - let static = ["GHCupURL", "StackSetupURL"] + let static = ["GHCupURL", "StackSetupURL", "cross", "prereleases", "vanilla"] file <- fileUri' add str' pure $ static ++ file diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index 15a5b9bc..f6fcc9e1 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -19,6 +19,7 @@ import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ import GHCup.OptParse.Common +import GHCup.Version #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -75,8 +76,9 @@ configP = subparser showP = info (pure ShowConfig) (progDesc "Show current config (default)") setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter)) argsP = SetConfig <$> argument str (metavar "") <*> optional (argument str (metavar "YAML_VALUE")) - addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader parseNewUrlSource) (metavar "URL_SOURCE" <> completer urlSourceCompleter)) - (progDesc "Add a release channel, e.g. from a URI") + addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") + <*> argument (eitherReader parseNewUrlSource) (metavar "" <> completer urlSourceCompleter)) + (progDesc "Add a release channel, e.g. from a URI or using alias") @@ -96,8 +98,10 @@ configFooter = [s|Examples: ghcup config init # set configuration pair - ghcup config set |] + ghcup config set + # add a release channel + ghcup config add-release-channel prereleases|] configSetFooter :: String configSetFooter = [s|Examples: @@ -107,6 +111,9 @@ configSetFooter = [s|Examples: # switch downloader to wget ghcup config set downloader Wget + # set vanilla channel as default + ghcup config set '{url-source: vanilla}' + # set mirror for ghcup metadata ghcup config set '{url-source: { OwnSource: ""}}'|] @@ -218,7 +225,7 @@ config configCommand settings userConf keybindings runLogger = case configComman r <- runE @'[DuplicateReleaseChannel] $ do let oldSources = fromURLSource (urlSource settings) let merged = oldSources ++ [new] - case checkDuplicate oldSources new of + case checkDuplicate (aliasToURI <$> oldSources) (aliasToURI new) of Duplicate | not force -> throwE (DuplicateReleaseChannel new) DuplicateLast -> pure () @@ -237,6 +244,10 @@ config configCommand settings userConf keybindings runLogger = case configComman | a `elem` xs = Duplicate | otherwise = NoDuplicate + aliasToURI :: NewURLSource -> NewURLSource + aliasToURI (NewChannelAlias a) = NewURI (channelURL a) + aliasToURI v = v + doConfig :: MonadIO m => UserSettings -> m () doConfig usersettings = do let settings' = updateSettings usersettings userConf diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 50a8f21e..9925cf45 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -154,6 +154,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do m (Either GHCupInfo Stack.SetupInfo) dl' NewGHCupURL = fmap Left $ liftE (getBase ghcupURL) >>= liftE . decodeMetadata @GHCupInfo dl' NewStackSetupURL = fmap Right $ liftE (getBase stackSetupURL) >>= liftE . decodeMetadata @Stack.SetupInfo + dl' (NewChannelAlias c) = fmap Left $ liftE (getBase $ channelURL c) >>= liftE . decodeMetadata @GHCupInfo dl' (NewGHCupInfo gi) = pure (Left gi) dl' (NewSetupInfo si) = pure (Right si) dl' (NewURI uri) = do diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 4bc2c1aa..ef6a95ee 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -390,10 +390,22 @@ data NewURLSource = NewGHCupURL | NewGHCupInfo GHCupInfo | NewSetupInfo SetupInfo | NewURI URI + | NewChannelAlias ChannelAlias deriving (Eq, GHC.Generic, Show) instance NFData NewURLSource +-- | Alias for ease of URLSource selection +data ChannelAlias = CrossChannel + | PrereleasesChannel + | VanillaChannel + deriving (Eq, GHC.Generic, Show, Enum, Bounded) + +channelAliasText :: ChannelAlias -> Text +channelAliasText CrossChannel = "cross" +channelAliasText PrereleasesChannel = "prereleases" +channelAliasText VanillaChannel = "vanilla" + fromURLSource :: URLSource -> [NewURLSource] fromURLSource GHCupURL = [NewGHCupURL] fromURLSource StackSetupURL = [NewStackSetupURL] @@ -409,6 +421,7 @@ convert' (Left (Right si)) = NewSetupInfo si convert' (Right uri) = NewURI uri instance NFData URLSource +instance NFData ChannelAlias instance NFData (URIRef Absolute) where rnf (URI !_ !_ !_ !_ !_) = () diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 1ddc6126..aeb00c8e 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -318,10 +318,21 @@ instance ToJSON NewURLSource where toJSON (NewGHCupInfo gi) = object [ "ghcup-info" .= gi ] toJSON (NewSetupInfo si) = object [ "setup-info" .= si ] toJSON (NewURI uri) = toJSON uri + toJSON (NewChannelAlias c) = toJSON c instance ToJSON URLSource where toJSON = toJSON . fromURLSource +instance ToJSON ChannelAlias where + toJSON = String . channelAliasText + +instance FromJSON ChannelAlias where + parseJSON = withText "ChannelAlias" $ \t -> + let aliases = map (\c -> (channelAliasText c, c)) [minBound..maxBound] + in case lookup t aliases of + Just c -> pure c + Nothing -> fail $ "Unexpected ChannelAlias: " <> T.unpack t + deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port @@ -428,8 +439,9 @@ lenientInfoParser o = do pure $ Right r instance FromJSON NewURLSource where - parseJSON v = uri v <|> url v <|> gi v <|> si v + parseJSON v = uri v <|> url v <|> alias v <|> gi v <|> si v where + alias = withText "NewURLSource" $ \t -> NewChannelAlias <$> parseJSON (String t) uri = withText "NewURLSource" $ \t -> NewURI <$> parseJSON (String t) url = withText "NewURLSource" $ \t -> case T.unpack t of "GHCupURL" -> pure NewGHCupURL diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs index e7e96b68..4aa291cf 100644 --- a/lib/GHCup/Utils/Parsers.hs +++ b/lib/GHCup/Utils/Parsers.hs @@ -390,9 +390,16 @@ parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') parseNewUrlSource :: String -> Either String NewURLSource parseNewUrlSource "GHCupURL" = pure NewGHCupURL parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL -parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') +parseNewUrlSource s' = (fmap NewChannelAlias . parseChannelAlias $ s') + <|> (eitherDecode . LE.encodeUtf8 . LT.pack $ s') <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') +parseChannelAlias :: String -> Either String ChannelAlias +parseChannelAlias s = + let aliases = map (\c -> (T.unpack (channelAliasText c), c)) [minBound..maxBound] + in case lookup s aliases of + Just c -> Right c + Nothing -> Left $ "Unexpected ChannelAlias: " <> s #if MIN_VERSION_transformers(0,6,0) instance Alternative (Either [a]) where diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs index 3ac33e29..1e0424ca 100644 --- a/lib/GHCup/Version.hs +++ b/lib/GHCup/Version.hs @@ -86,3 +86,9 @@ versionToPVP v = case parse pvp'' "Version->PVP" $ V.prettyVer v of pvpFromList :: [Int] -> V.PVP pvpFromList = V.PVP . NE.fromList . fmap fromIntegral + +channelURL :: ChannelAlias -> URI +channelURL = \case + CrossChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml|] + PrereleasesChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml|] + VanillaChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-vanilla-0.0.8.yaml|] diff --git a/test/optparse-test/ConfigTest.hs b/test/optparse-test/ConfigTest.hs index 3ec36079..11301f6a 100644 --- a/test/optparse-test/ConfigTest.hs +++ b/test/optparse-test/ConfigTest.hs @@ -5,7 +5,7 @@ module ConfigTest where import Test.Tasty import Test.Tasty.HUnit import GHCup.OptParse -import GHCup.Types (NewURLSource(..)) +import GHCup.Types (NewURLSource(..), ChannelAlias(..)) import Utils import Control.Monad.IO.Class import URI.ByteString.QQ @@ -32,6 +32,15 @@ checkList = , ("config add-release-channel StackSetupURL" , AddReleaseChannel False NewStackSetupURL ) + , ("config add-release-channel cross" + , AddReleaseChannel False (NewChannelAlias CrossChannel) + ) + , ("config add-release-channel prereleases" + , AddReleaseChannel False (NewChannelAlias PrereleasesChannel) + ) + , ("config add-release-channel vanilla" + , AddReleaseChannel False (NewChannelAlias VanillaChannel) + ) , ("config set cache true", SetConfig "cache" (Just "true")) ] From 9fa8514da7366b7e94caa34380b2dbe38b7894d4 Mon Sep 17 00:00:00 2001 From: Divam Date: Sat, 21 Dec 2024 22:16:37 +0900 Subject: [PATCH 2/5] Use channel aliases in data/config.yaml --- data/config.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/data/config.yaml b/data/config.yaml index affd60de..5c620a08 100644 --- a/data/config.yaml +++ b/data/config.yaml @@ -61,11 +61,11 @@ url-source: # - StackSetupURL ## Add pre-release channel - # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml + # - prereleases ## Add nightly channel # - https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml ## Add cross compiler channel - # - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml + # - cross ## Use dwarf bindist for 9.4.7 for ghcup metadata # - ghcup-info: From 930da8d0b43c944b9c2e7645c11d8c81bbe1e164 Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 26 Dec 2024 16:18:15 +0900 Subject: [PATCH 3/5] Add command to revert to using default channel, and simplify command for vanilla --- lib-opt/GHCup/OptParse/Config.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index f6fcc9e1..9cdcf050 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -112,7 +112,10 @@ configSetFooter = [s|Examples: ghcup config set downloader Wget # set vanilla channel as default - ghcup config set '{url-source: vanilla}' + ghcup config set url-source vanilla + + # use the default GHCup channel + ghcup config set url-source GHCupURL # set mirror for ghcup metadata ghcup config set '{url-source: { OwnSource: ""}}'|] From 13def98cf62f6399eda3cae01b838c93a8047f6d Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 26 Dec 2024 17:45:34 +0900 Subject: [PATCH 4/5] Change optUrlSource to use NewURLSource, this allows use of ChannelAlias While still maintaining backward compatibility with URLSource --- app/ghcup/Main.hs | 2 +- lib-opt/GHCup/OptParse.hs | 2 +- lib-opt/GHCup/OptParse/Config.hs | 2 +- lib/GHCup/Download.hs | 3 +-- lib/GHCup/Types.hs | 8 ++++---- lib/GHCup/Utils/Parsers.hs | 11 +++++++---- 6 files changed, 15 insertions(+), 13 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 875c3f6e..edfd58e5 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -89,7 +89,7 @@ toSettings noColor pagerCmd options = do keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings - urlSource = fromMaybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) optUrlSource + urlSource = fromMaybe (maybe (Types.urlSource defaultSettings) fromURLSource uUrlSource) optUrlSource noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings) diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index 1e8a412e..1484a588 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -81,7 +81,7 @@ data Options = Options , optMetaCache :: Maybe Integer , optMetaMode :: Maybe MetaMode , optPlatform :: Maybe PlatformRequest - , optUrlSource :: Maybe URLSource + , optUrlSource :: Maybe [NewURLSource] , optNoVerify :: Maybe Bool , optKeepDirs :: Maybe KeepDirs , optsDownloader :: Maybe Downloader diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index 9cdcf050..150f0475 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -226,7 +226,7 @@ config configCommand settings userConf keybindings runLogger = case configComman AddReleaseChannel force new -> do r <- runE @'[DuplicateReleaseChannel] $ do - let oldSources = fromURLSource (urlSource settings) + let oldSources = urlSource settings let merged = oldSources ++ [new] case checkDuplicate (aliasToURI <$> oldSources) (aliasToURI new) of Duplicate diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 9925cf45..3fdd267d 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -124,8 +124,7 @@ getDownloadsF :: ( FromJSONKey Tool GHCupInfo getDownloadsF pfreq@(PlatformRequest arch plat _) = do Settings { urlSource } <- lift getSettings - let newUrlSources = fromURLSource urlSource - infos <- liftE $ mapM dl' newUrlSources + infos <- liftE $ mapM dl' urlSource keys <- if any isRight infos then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq else pure [] diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index ef6a95ee..31bbdd93 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -466,7 +466,7 @@ fromSettings Settings{..} Nothing = , uDownloader = Just downloader , uNoNetwork = Just noNetwork , uKeyBindings = Nothing - , uUrlSource = Just urlSource + , uUrlSource = Just (SimpleList urlSource) , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors @@ -494,7 +494,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) = , uDownloader = Just downloader , uNoNetwork = Just noNetwork , uKeyBindings = Just ukb - , uUrlSource = Just urlSource + , uUrlSource = Just (SimpleList urlSource) , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors @@ -579,7 +579,7 @@ data Settings = Settings , keepDirs :: KeepDirs , downloader :: Downloader , verbose :: Bool - , urlSource :: URLSource + , urlSource :: [NewURLSource] , noNetwork :: Bool , gpgSetting :: GPGSetting , noColor :: Bool -- this also exists in LoggerConfig @@ -608,7 +608,7 @@ defaultMetaCache :: Integer defaultMetaCache = 300 -- 5 minutes defaultSettings :: Settings -defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) [] defaultPagerConfig +defaultSettings = Settings False defaultMetaCache Lax False Never Curl False [NewGHCupURL] False GPGNone False Nothing (DM mempty) [] defaultPagerConfig instance NFData Settings diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs index 4aa291cf..de5ca4e4 100644 --- a/lib/GHCup/Utils/Parsers.hs +++ b/lib/GHCup/Utils/Parsers.hs @@ -381,10 +381,13 @@ fromVersion' (SetToolTag t') tool = throwE $ TagNotFound t' tool -parseUrlSource :: String -> Either String URLSource -parseUrlSource "GHCupURL" = pure GHCupURL -parseUrlSource "StackSetupURL" = pure StackSetupURL -parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') +parseUrlSource :: String -> Either String [NewURLSource] +parseUrlSource s = (fromURLSource <$> parseUrlSource' s) <|> ((:[]) <$> parseNewUrlSource s) + +parseUrlSource' :: String -> Either String URLSource +parseUrlSource' "GHCupURL" = pure GHCupURL +parseUrlSource' "StackSetupURL" = pure StackSetupURL +parseUrlSource' s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s') parseNewUrlSource :: String -> Either String NewURLSource From a68ba987bd977cfbe6942b9a15a17b6e96f812d3 Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 26 Dec 2024 17:46:33 +0900 Subject: [PATCH 5/5] Add an example of using channel alias with 'ghcup install ghc' --- lib-opt/GHCup/OptParse/Install.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index 2d947c4e..aeffc3eb 100644 --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -170,6 +170,9 @@ Examples: # install GHC 8.10.2 ghcup install ghc 8.10.2 + # install GHC 8.10.2 from vanilla channel + ghcup -s vanilla install ghc 8.10.2 + # install GHC head fedora bindist ghcup install ghc -u 'https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz?job=x86_64-linux-fedora33-release' head|]