diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 875c3f6e0..edfd58e56 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/data/config.yaml b/data/config.yaml index affd60dee..5c620a08d 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: diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index 72a899773..1484a588b 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 @@ -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 d7ff3f5f8..a7b90782c 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 15a5b9bca..150f0475d 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,12 @@ configSetFooter = [s|Examples: # switch downloader to wget ghcup config set downloader Wget + # set vanilla channel as default + 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: ""}}'|] @@ -216,9 +226,9 @@ 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 oldSources new of + case checkDuplicate (aliasToURI <$> oldSources) (aliasToURI new) of Duplicate | not force -> throwE (DuplicateReleaseChannel new) DuplicateLast -> pure () @@ -237,6 +247,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-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index 2d947c4ea..aeffc3eba 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|] diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 50a8f21e7..3fdd267db 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 [] @@ -154,6 +153,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 4bc2c1aac..31bbdd933 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 !_ !_ !_ !_ !_) = () @@ -453,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 @@ -481,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 @@ -566,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 @@ -595,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/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 1ddc61263..aeb00c8e3 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 e7e96b68b..de5ca4e49 100644 --- a/lib/GHCup/Utils/Parsers.hs +++ b/lib/GHCup/Utils/Parsers.hs @@ -381,18 +381,28 @@ 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 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 3ac33e295..1e0424cae 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 3ec360792..11301f6a7 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")) ]