Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Warns users about non-ghcup channels #1230

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
+45 −3
Open

Warns users about non-ghcup channels #1230

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
48 changes: 45 additions & 3 deletions lib/GHCup/Download.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)



Expand All @@ -102,6 +104,33 @@ import qualified Data.Yaml.Aeson as Y
------------------


formatURI :: URI -> T.Text
formatURI uri =
let scheme = E.decodeUtf8 $ schemeBS $ uriScheme uri
auth = case uriAuthority uri of
Just a -> "//" <> E.decodeUtf8 (hostBS $ authorityHost a)
Nothing -> ""
path = E.decodeUtf8 $ uriPath uri
in scheme <> ":" <> auth <> path

-- | Logic to check if it is an Official Channel
isOfficialURI :: URI -> Bool
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This will trigger on file:// URLs... which we don't want.

isOfficialURI uri = any (`isURIPrefix` uri) officialURIs
where
officialURIs = [isGitHubMetadata]
isGitHubMetadata uri' =
schemeBS (uriScheme uri') == "https" &&
maybe False (\a -> hostBS (authorityHost a) == "raw.githubusercontent.com") (uriAuthority uri') &&
pathStartsWith "/haskell/ghcup-metadata/" (uriPath uri')
pathStartsWith prefix path = prefix `B.isPrefixOf` path
isURIPrefix predicate uri' = predicate uri'

-- | Special case to check for nightlies URL
isNightliesURI :: URI -> Bool
isNightliesURI uri =
schemeBS (uriScheme uri) == "https" &&
maybe False (\a -> hostBS (authorityHost a) == "ghc.gitlab.haskell.org") (uriAuthority uri) &&
uriPath uri == "/ghcup-metadata/ghcup-nightlies-0.0.7.yaml"

-- | Downloads the download information! But only if we need to ;P
getDownloadsF :: ( FromJSONKey Tool
Expand All @@ -124,6 +153,17 @@ getDownloadsF :: ( FromJSONKey Tool
GHCupInfo
getDownloadsF pfreq@(PlatformRequest arch plat _) = do
Settings { urlSource } <- lift getSettings
forM_ urlSource $ \src ->
case src of
NewURI uri -> do
when (not (isOfficialURI uri) || isNightliesURI uri) $
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

  1. we do not want to emit a warning every time a download is issued... instead we want to emit a warning if a user adds a new channel (either via ghcup config add-release-channel or ghcup config set url-source)
  2. nightlies are no exception... they are not maintained by GHCup, so we want to warn

logWarn $ "Warning: Using non-official metadata source: " <> formatURI uri <>
"\nThis source is not maintained or verified by the GHCup team."
NewGHCupInfo _ ->
logWarn "Warning: Using custom GHCupInfo data that is not from an official GHCup metadata source"
NewSetupInfo _ ->
logWarn "Warning: Using custom SetupInfo data that is not from an official GHCup metadata source"
_ -> pure ()
infos <- liftE $ mapM dl' urlSource
keys <- if any isRight infos
then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
Expand All @@ -133,7 +173,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
Right si -> pure $ fromStackSetupInfo si keys
mergeGhcupInfo ghcupInfos
where

dl' :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
Expand Down Expand Up @@ -162,7 +202,9 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
catchE @JSONError (\(JSONDecodeError s) -> do
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: " <> T.pack s
Right <$> decodeMetadata @Stack.SetupInfo base)
$ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI)
$ fmap Left (decodeMetadata @GHCupInfo base >>= \gI ->
warnOnMetadataUpdate uri gI >> pure gI)


fromStackSetupInfo :: MonadThrow m
=> Stack.SetupInfo
Expand Down Expand Up @@ -890,4 +932,4 @@ applyMirrors (DM ms) uri@(URI { uriAuthority = Just (Authority { authorityHost =
}
Just (DownloadMirror auth Nothing) ->
uri { uriAuthority = Just auth }
applyMirrors _ uri = uri
applyMirrors _ uri = uri