Warns users about non-ghcup channels

Author: qxrein

lib/GHCup/Download.hs

@@ -89,6 +89,8 @@ import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Yaml.Aeson               as Y
+import Data.List (isPrefixOf)
+import Control.Monad.IO.Class (liftIO)
 
 
 
@@ -103,7 +105,42 @@ import qualified Data.Yaml.Aeson               as Y
 
 
 
+officialPrefixes :: [String]
+officialPrefixes = 
+  [ "https://raw.githubusercontent.com/haskell/ghcup-metadata/"
+  , "https://mirror.sjtu.edu.cn/ghcup/yaml/haskell/ghcup-metadata/"
+  ]
+
 -- | Downloads the download information! But only if we need to ;P
+isDefaultURL :: NewURLSource -> Bool
+isDefaultURL NewGHCupURL = True
+isDefaultURL NewStackSetupURL = True
+isDefaultURL (NewChannelAlias StackChannel) = True
+isDefaultURL (NewChannelAlias _) = True
+isDefaultURL (NewGHCupInfo _) = False  -- Custom GHCupInfo is not a default source
+isDefaultURL (NewSetupInfo _) = False  -- Custom SetupInfo is not a default source
+isDefaultURL (NewURI uri) = show uri `elem` defaultURLs
+
+-- List of default/known URLs
+defaultURLs :: [String]
+defaultURLs =
+  [ "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.9.yaml"
+  , "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml"
+  , "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.9.yaml"
+  , "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.9.yaml"
+  , "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-vanilla-0.0.9.yaml"
+  ]
+
+-- Extract URL string from NewURLSource if possible, for checking
+getUrlStringFromSource :: NewURLSource -> Maybe String
+getUrlStringFromSource NewGHCupURL = Just $ show ghcupURL
+getUrlStringFromSource NewStackSetupURL = Just $ show stackSetupURL
+getUrlStringFromSource (NewChannelAlias c) = Just $ show $ channelURL c
+getUrlStringFromSource (NewGHCupInfo _) = Nothing
+getUrlStringFromSource (NewSetupInfo _) = Nothing
+getUrlStringFromSource (NewURI uri) = Just $ show uri
+
+-- Modified getDownloadsF to include URL prefix check
 getDownloadsF :: ( FromJSONKey Tool
                  , FromJSONKey Version
                  , FromJSON VersionInfo
@@ -124,6 +161,22 @@ getDownloadsF :: ( FromJSONKey Tool
                    GHCupInfo
 getDownloadsF pfreq@(PlatformRequest arch plat _) = do
   Settings { urlSource } <- lift getSettings
+
+  -- Check for custom URL sources that aren't in the default list
+  forM_ urlSource $ \src -> 
+    case src of
+      NewURI uri -> do
+        let url = show uri
+        when (not (url `elem` defaultURLs) && 
+              not (any (`isPrefixOf` url) officialPrefixes) ||
+              url == "https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml") $ 
+          logWarn $ "The URL " <> T.pack url <> " is not an official GHCup metadata source and may not be maintained or QA'd by GHCup."
+      NewGHCupInfo _ -> 
+        logWarn "Using custom GHCupInfo which is not an official GHCup metadata source"
+      NewSetupInfo _ -> 
+        logWarn "Using custom SetupInfo which is not an official GHCup metadata source"
+      _ -> pure () 
+
   infos <- liftE $ mapM dl' urlSource
   keys <- if any isRight infos
           then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
@@ -133,7 +186,17 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
     Right si -> pure $ fromStackSetupInfo si keys
   mergeGhcupInfo ghcupInfos
  where
-
+  -- Default URLs that are known to be official
+  defaultURLs :: [String]
+  defaultURLs =
+    [ "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.9.yaml"
+    , "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml"
+    , "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.9.yaml"
+    , "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.9.yaml"
+    , "https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-vanilla-0.0.9.yaml"
+    , "https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml" -- Nightly channel mentioned in config example
+    ]
+  
   dl' :: ( FromJSONKey Tool
          , FromJSONKey Version
          , FromJSON VersionInfo
@@ -164,6 +227,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
                                 Right <$> decodeMetadata @Stack.SetupInfo base)
                               $ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI)
 
+
   fromStackSetupInfo :: MonadThrow m
                      => Stack.SetupInfo
                      -> [String]
@@ -890,4 +954,4 @@ applyMirrors (DM ms) uri@(URI { uriAuthority = Just (Authority { authorityHost =
           }
     Just (DownloadMirror auth Nothing) ->
       uri { uriAuthority = Just auth }
-applyMirrors _ uri = uri
+applyMirrors _ uri = uri