Improve the way we pick the package-set to upgrade to (#721)

Author: f-f

.github/workflows/build.yml

@@ -56,7 +56,7 @@ jobs:
         shell: bash
 
       - name: Build
-        run: stack build
+        run: stack build --pedantic
         shell: bash
 
       - name: Install

package.yaml

@@ -16,6 +16,7 @@ ghc-options:
   - -Wincomplete-record-updates
   - -Wredundant-constraints
   - -fprint-potential-instances
+  - -optP-Wno-nonportable-include-path
 
 flags:
   static:

spago.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: c5171d8aacb92261a66e4da21145765f3560a8cc8d8e794ef140a95e58c1b3de
+-- hash: 8a93a8d0d935703bc0cef9a60dfcacc9776c88e3e5ae6c5f7bc004e775ef1a92
 
 name:           spago
-version:        0.18.0
+version:        0.18.1
 description:    Please see the README on GitHub at <https://github.com/purescript/spago#readme>
 homepage:       https://github.com/purescript/spago#readme
 bug-reports:    https://github.com/purescript/spago/issues

src/Spago/Config.hs

@@ -30,11 +30,11 @@ import qualified Dhall.TypeCheck
 import qualified Web.Bower.PackageMeta as Bower
 
 import qualified Spago.Dhall           as Dhall
-import qualified Spago.GitHub          as GitHub
 import qualified Spago.Messages        as Messages
 import qualified Spago.PackageSet      as PackageSet
 import qualified Spago.PscPackage      as PscPackage
 import qualified Spago.Templates       as Templates
+import qualified Spago.Purs            as Purs
 
 
 type Expr = Dhall.DhallExpr Dhall.Import
@@ -164,17 +164,20 @@ ensureConfig = do
 -- | Create a Config in memory
 -- | For use by `spago script` and `spago repl`
 makeTempConfig
-  :: (HasLogFunc env, HasGlobalCache env)
+  :: HasLogFunc env
   => [PackageName]
   -> Maybe Text
   -> [SourcePath]
   -> Maybe Text
   -> RIO env Config
 makeTempConfig dependencies alternateBackend configSourcePaths maybeTag = do
   tag <- case maybeTag of
-    Nothing -> GitHub.getLatestPackageSetsTag "purescript" "package-sets" >>= (\case
-      Left _ -> die [ "Failed to fetch latest package set tag" ]
-      Right tag -> pure tag)
+    Nothing -> do
+      Purs.pursVersion >>= \case
+        Left err -> die [ display err ]
+        Right compilerVersion -> (PackageSet.getLatestSetForCompilerVersion compilerVersion "purescript" "package-sets") >>= \case
+          Left _ -> die [ "spago script: failed to fetch latest package set tag" ]
+          Right tag -> pure tag
     Just tag -> pure tag
 
   expr <- liftIO $ Dhall.inputExpr $ "https://github.com/purescript/package-sets/releases/download/" <> tag <> "/packages.dhall"

src/Spago/GitHub.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE ViewPatterns #-}
-module Spago.GitHub where
+module Spago.GitHub
+  ( getLatestPackageSetsTag
+  , getLatestReleasesFile
+  ) where
 
 import           Spago.Prelude
 import           Spago.Env
@@ -10,13 +13,12 @@ import qualified Data.Text           as Text
 import qualified Data.Text.Encoding
 import qualified Network.HTTP.Client as Http
 import qualified Network.HTTP.Simple as Http
+import qualified Data.Versions       as Version
+import qualified Data.Map.Strict     as Map
 
 import qualified Spago.Messages      as Messages
 
 
-tokenCacheFile :: IsString t => t
-tokenCacheFile = "github-token.txt"
-
 tagCacheFile :: Text -> Text -> Text
 tagCacheFile org repo = org <> "-" <> repo <> "-tag.txt"
 
@@ -63,3 +65,15 @@ getLatestPackageSetsTag org repo = do
           logWarn "Error following GitHub redirect, response:"
           logWarn $ displayShow response
           empty
+
+getLatestReleasesFile
+  :: (HasLogFunc env, MonadReader env m, MonadThrow m, MonadIO m)
+  => Text -> Text -> m (Map Version.SemVer Text)
+getLatestReleasesFile org repo = do
+  logDebug $ "Getting `latest-compatible-sets.json` from " <> display org <> "/" <> display repo
+  request <- Http.parseRequest $ "https://raw.githubusercontent.com/" <> (Text.unpack org) <> "/" <> (Text.unpack repo) <> "/master/latest-compatible-sets.json"
+  response <- Http.responseBody <$> Http.httpJSON request
+  let parseVersion (k, v) = case Version.semver k of
+        Left _ -> Nothing
+        Right version -> Just (version, v)
+  pure $ Map.fromList $ mapMaybe parseVersion $ Map.toList response

src/Spago/Messages.hs

@@ -170,6 +170,14 @@ failedToCopyToGlobalCache err = makeMessage
   , tshow err
   ]
 
+incompatiblePurs :: [Text] -> Text
+incompatiblePurs versions = makeMessage $
+  [ "It seems that you're using a compiler version that is not supported by package-sets at the moment."
+  , "Please install one of the following versions of the compiler and try again: "
+  ]
+  <> map ("- " <>) versions
+  <> [""]
+
 pursVersionMismatch :: Text -> Text -> Text
 pursVersionMismatch currentVersion minVersion = makeMessage
   [ "Oh noes! It looks like the PureScript version installed on your system is not compatible with the package-set you're using."
@@ -180,7 +188,7 @@ pursVersionMismatch currentVersion minVersion = makeMessage
   , "There are a few ways to solve this:"
   , "- install a compatible `purs` version (i.e. in the same 'semver range' as the one in the package set)"
   , "- if the `purs` version is 'too new', you can try using `spago upgrade-set` to upgrade to the latest package set"
-  , "- if you know what you're doing and you want to avoid this check, you can override the `version` of the `metadata` package in the packages.dhall:"
+  , "- if you know what you're doing and you want to disable this check, you can override the `version` of the `metadata` package in the packages.dhall:"
   , ""
   , "  let overrides = { metadata = upstream.metadata // { version = \"v" <> currentVersion <> "\" } }"
   , ""

src/Spago/PackageSet.hs

@@ -1,5 +1,6 @@
 module Spago.PackageSet
   ( updatePackageSetVersion
+  , getLatestSetForCompilerVersion
   , checkPursIsUpToDate
   , makePackageSetFile
   , freeze
@@ -13,6 +14,8 @@ import           Spago.Env
 
 import qualified Control.Exception as Exception
 import           Data.Dynamic (fromDynamic)
+import qualified Data.List       as List
+import qualified Data.Map.Strict as Map
 import qualified Data.Text       as Text
 import qualified Data.Versions   as Version
 import qualified Dhall.Freeze
@@ -45,6 +48,26 @@ makePackageSetFile force comments = do
     else logWarn $ display $ Messages.foundExistingProject packagesPath
   Dhall.format packagesPath
 
+getLatestSetForCompilerVersion
+  :: HasLogFunc env
+  => Version.SemVer
+  -> Text
+  -> Text
+  -> RIO env (Either SomeException Text)
+getLatestSetForCompilerVersion compilerVersion org repo = do
+  logDebug $ "Got a compiler version: " <> displayShow compilerVersion
+  -- we first try getting the file with the index of the latest sets
+  eitherLatestReleases <- try $ GitHub.getLatestReleasesFile org repo
+  logDebug $ "Latest releases: " <> displayShow eitherLatestReleases
+  for eitherLatestReleases $ \latestReleases -> do
+    -- if we get that, we just try to pick a set for the current compiler
+    case Map.lookup compilerVersion latestReleases of
+      -- but if the current compiler is not there we complain about compatibility
+      Nothing -> die [ display $ Messages.incompatiblePurs (Version.prettySemVer <$> List.reverse (Map.keys latestReleases))]
+      Just newTag -> do
+        logDebug $ "Found a new tag in the releases file: " <> display newTag
+        pure $ newTag
+
 -- | Use the specified version of the package set (if specified).
 --   Otherwise, get the latest version of the package set if possible
 updatePackageSetVersion
@@ -65,30 +88,37 @@ updatePackageSetVersion maybeTag = do
 
   maybe
     (useLatestRelease org repo currentTag)
-    (useSpecificRelease org repo currentTag)
+    (updateTag org repo currentTag)
     maybeTag
   where
-    -- | Tries to upgrade the Package-Sets release of the local package set.
-    --   It will:
-    --   - try to read the latest tag from GitHub
-    --   - try to read the current package-set file
-    --   - try to replace the git tag to which the package-set imports point to
-    --     (if they point to the Package-Sets repo. This can be eventually made GitHub generic)
-    --   - if all of this succeeds, it will regenerate the hashes and write to file
+    -- | Try to fetch the latest compatible tag in various ways, and updates
+    --   the packages.dhall with it
     useLatestRelease
       :: Text -> Text -> Text -> RIO env ()
     useLatestRelease org repo currentTag = do
-      GitHub.getLatestPackageSetsTag org repo >>= \case
-        Right tag -> updateTag org repo currentTag tag
-        Left (err :: SomeException) -> do
-          logWarn "Was not possible to upgrade the package-sets release"
-          logDebug $ "Error: " <> display err
-
-    useSpecificRelease
-      :: Text -> Text -> Text -> Text -> RIO env ()
-    useSpecificRelease org repo currentTag tag =
-      updateTag org repo currentTag tag
+      let getLatestFromGitHub = GitHub.getLatestPackageSetsTag org repo >>= \case
+            Right tag -> updateTag org repo currentTag tag
+            Left (err :: SomeException) -> do
+              logWarn "Was not possible to upgrade the package-sets release"
+              logDebug $ "Error: " <> display err
+      -- first let's get the current compiler version
+      Purs.pursVersion >>= \case
+        Left err -> do
+          -- if we cannot we just get the latest release from GitHub
+          logDebug $ display err
+          getLatestFromGitHub
+        Right compilerVersion ->
+          getLatestSetForCompilerVersion compilerVersion org repo >>= \case
+            Right newTag -> updateTag org repo currentTag newTag
+            -- if that fails then we fetch the latest set from GitHub
+            -- TODO: check that it's compatible with the current compiler
+            Left _err -> getLatestFromGitHub
 
+    -- | Tries to upgrade the package-sets release of the local package set.
+    --   It will:
+    --   - try to read the current package-set file
+    --   - try to replace the git tag to which the package-set imports point to
+    --   - if all of this succeeds, it will regenerate the hashes and write to file
     updateTag :: Text -> Text -> Text -> Text -> RIO env ()
     updateTag org repo currentTag specificTag =  do
       let quotedTag = surroundQuote specificTag
@@ -136,7 +166,7 @@ updatePackageSetVersion maybeTag = do
       } = [(org, repo, currentTag)]
     getCurrentTag _ = []
 
-    -- | Given an import and a new purescript/package-sets tag,
+    -- | Given an import and a new package-sets tag,
     --   upgrades the import to the tag and resets the hash
     upgradeImports :: Text -> Text -> Text -> Dhall.Import -> Dhall.Import
     upgradeImports org repo newTag (Dhall.Import