Warning by introducing officialprefixes in lib/GHCup/Download.hs

Author: qxrein

ghcup.cabal

@@ -123,6 +123,7 @@ common app-common-depends
     , utf8-string            ^>=1.0
     , vector                 >=0.12     && <0.14
     , versions               >=6.0.5      && <6.1
+    , hslogger               >= 1.2 && < 1.4
 
   if flag(yaml-streamly)
     build-depends:

lib/GHCup.hs

@@ -76,10 +76,6 @@ import           System.FilePath
 import           System.IO.Error
 import           System.IO.Temp
 import           Text.Regex.Posix
-import qualified URI.ByteString as URI
-import qualified Data.ByteString.Lazy.Char8 as BL8
-import qualified Data.Text.Encoding as TE
-import Data.ByteString.Builder (toLazyByteString)
 
 import qualified Data.Text                     as T
 
@@ -254,7 +250,6 @@ getDebugInfo :: ( Alternative m
                 , MonadFail m
                 , MonadReader env m
                 , HasDirs env
-                , HasSettings env
                 , HasLog env
                 , MonadCatch m
                 , MonadIO m
@@ -265,28 +260,10 @@ getDebugInfo :: ( Alternative m
                   DebugInfo
 getDebugInfo = do
   diDirs <- lift getDirs
-  settings <- lift getSettings
-  let diChannels = fmap (\c -> (c, GHCup.Version.channelURL c)) [minBound..maxBound]
+  let diChannels = fmap (\c -> (c, channelURL c)) [minBound..maxBound]
   let diShimGenURL = shimGenURL
   diArch         <- lE getArchitecture
   diPlatform     <- liftE getPlatform
-
-  let officialPrefix = "https://raw.githubusercontent.com/haskell/ghcup-metadata/"
-  let isOfficial url = officialPrefix `T.isPrefixOf` T.pack url
-  let maybeMetadataURL = case settings of
-        _ -> Nothing  
-
-  case maybeMetadataURL of
-    Just url | not (isOfficial url) ->
-      logWarn $ "Warning: Using non-official metadata URL: " <> T.pack url
-    _ -> pure ()
-
-  forM_ diChannels $ \(channel, url) -> do
-    let urlText = TE.decodeUtf8 $ BL8.toStrict $ toLazyByteString $ URI.serializeURI url
-    unless (isOfficial (T.unpack urlText)) $
-      logWarn $ "Warning: The channel " <> T.pack (show channel)
-             <> " uses a non-official URL: " <> urlText
-
   pure $ DebugInfo { .. }
 
 
@@ -700,4 +677,3 @@ rmTmp = do
     logDebug $ "rm -rf " <> T.pack (fromGHCupPath f)
     rmPathForcibly f
 
-

lib/GHCup/Download.hs

@@ -89,6 +89,9 @@ 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)
+import System.Log.Logger (warningM)
 
 
 
@@ -103,7 +106,47 @@ 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/"  -- Add your mirror pattern
+  ]
+
+checkUrlPrefix :: String -> IO ()
+checkUrlPrefix url
+  | any (`isPrefixOf` url) officialPrefixes = return ()
+  | otherwise = liftIO $ warningM "ghcup" $ "Warning: The URL " ++ url ++ " is not an official GHCup metadata source and may not be maintained or QA'd by GHCup."
+
 -- | 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 +167,23 @@ getDownloadsF :: ( FromJSONKey Tool
                    GHCupInfo
 getDownloadsF pfreq@(PlatformRequest arch plat _) = do
   Settings { urlSource } <- lift getSettings
+
+  -- Log all URL sources
+  logDebug $ "URL sources in config: " <> T.pack (show urlSource)
+
+  -- 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
+        logDebug $ "Checking URI: " <> T.pack url
+        unless (url `elem` defaultURLs) $ liftIO $ checkUrlPrefix url
+      NewGHCupInfo _ -> 
+        liftIO $ warningM "ghcup" "Warning: Using custom GHCupInfo which is not an official GHCup metadata source"
+      NewSetupInfo _ -> 
+        liftIO $ warningM "ghcup" "Warning: Using custom SetupInfo which is not an official GHCup metadata source"
+      _ -> pure () -- Default sources don't need checking
+
   infos <- liftE $ mapM dl' urlSource
   keys <- if any isRight infos
           then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
@@ -133,7 +193,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 +234,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]