Merge remote-tracking branch 'origin/dn-channel-aliases'

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)

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:

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 "<URL_SOURCE|cross|prereleases|vanilla>"
             <> help "Alternative ghcup download info"
             <> internal
             <> completer urlSourceCompleter

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
 

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 "<JSON_VALUE | YAML_KEY>") <*> 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 "<URL_SOURCE|cross|prereleases|vanilla>" <> 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 <key> <value> configuration pair
-  ghcup config set <key> <value>|]
+  ghcup config set <key> <value>
 
+  # 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: "<url>"}}'|]
 
@@ -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

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|]
 

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

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
 

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

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

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|]

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"))
   ]