Require all packages to solve / compile and include all valid compilers in their metadata

SPEC.md

@@ -234,11 +234,12 @@ For example:
 
 All packages in the registry have an associated metadata file, which is located in the `metadata` directory of the `registry` repository under the package name. For example, the metadata for the `aff` package is located at: https://github.com/purescript/registry/blob/main/metadata/aff.json. Metadata files are the source of truth on all published and unpublished versions for a particular package for what there content is and where the package is located. Metadata files are produced by the registry, not by package authors, though they take some information from package manifests.
 
-Each published version of a package records three fields:
+Each published version of a package records four fields:
 
 - `hash`: a [`Sha256`](#Sha256) of the compressed archive fetched by the registry for the given version
 - `bytes`: the size of the tarball in bytes
 - `publishedTime`: the time the package was published as an `ISO8601` string
+- `compilers`: compiler versions this package is known to work with. This field can be in one of two states: a single version indicates that the package worked with a specific compiler on upload but has not yet been tested with all compilers, whereas a non-empty array of versions indicates the package has been tested with all compilers the registry supports.
 
 Each unpublished version of a package records three fields:
 

app/fixtures/registry/metadata/prelude.json

@@ -6,6 +6,7 @@
   "published": {
     "6.0.1": {
       "bytes": 31142,
+      "compilers": ["0.15.10", "0.15.11", "0.15.12"],
       "hash": "sha256-o8p6SLYmVPqzXZhQFd2hGAWEwBoXl1swxLG/scpJ0V0=",
       "publishedTime": "2022-08-18T20:04:00.000Z",
       "ref": "v6.0.1"

app/fixtures/registry/metadata/type-equality.json

@@ -6,6 +6,7 @@
   "published": {
     "4.0.1": {
       "bytes": 2184,
+      "compilers": ["0.15.9", "0.15.10", "0.15.11"],
       "hash": "sha256-Hs9D6Y71zFi/b+qu5NSbuadUQXe5iv5iWx0226vOHUw=",
       "publishedTime": "2022-04-27T18:00:18.000Z",
       "ref": "v4.0.1"

app/src/App/CLI/Purs.purs

@@ -21,6 +21,22 @@ data CompilerFailure
   | MissingCompiler
 
 derive instance Eq CompilerFailure
+derive instance Ord CompilerFailure
+
+compilerFailureCodec :: JsonCodec CompilerFailure
+compilerFailureCodec = CA.codec' decode encode
+  where
+  decode :: Json -> Either JsonDecodeError CompilerFailure
+  decode json =
+    map CompilationError (CA.decode (CA.array compilerErrorCodec) json)
+      <|> map UnknownError (CA.decode CA.string json)
+      <|> map (const MissingCompiler) (CA.decode CA.null json)
+
+  encode :: CompilerFailure -> Json
+  encode = case _ of
+    CompilationError errors -> CA.encode (CA.array compilerErrorCodec) errors
+    UnknownError message -> CA.encode CA.string message
+    MissingCompiler -> CA.encode CA.null unit
 
 type CompilerError =
   { position :: SourcePosition

app/src/App/Effect/Cache.purs

@@ -168,7 +168,6 @@ handleMemoryFs env = case _ of
           case inFs of
             Nothing -> pure $ reply Nothing
             Just entry -> do
-              Log.debug $ "Fell back to on-disk entry for " <> memory
               putMemoryImpl env.ref unit (Key memory (Const entry))
               pure $ reply $ Just $ unCache entry
         Just cached ->
@@ -226,8 +225,7 @@ getMemoryImpl ref (Key id (Reply reply)) = do
   let (unCache :: CacheValue -> b) = unsafeCoerce
   cache <- Run.liftEffect $ Ref.read ref
   case Map.lookup id cache of
-    Nothing -> do
-      Log.debug $ "No cache entry found for " <> id <> " in memory."
+    Nothing ->
       pure $ reply Nothing
     Just cached -> do
       pure $ reply $ Just $ unCache cached
@@ -236,7 +234,6 @@ putMemoryImpl :: forall x r a. CacheRef -> a -> MemoryEncoding Const a x -> Run
 putMemoryImpl ref next (Key id (Const value)) = do
   let (toCache :: x -> CacheValue) = unsafeCoerce
   Run.liftEffect $ Ref.modify_ (Map.insert id (toCache value)) ref
-  Log.debug $ "Wrote cache entry for " <> id <> " in memory."
   pure next
 
 deleteMemoryImpl :: forall x r a. CacheRef -> MemoryEncoding Ignore a x -> Run (LOG + EFFECT + r) a
@@ -275,7 +272,6 @@ getFsImpl cacheDir = case _ of
     let path = Path.concat [ cacheDir, safePath id ]
     Run.liftAff (Aff.attempt (FS.Aff.readFile path)) >>= case _ of
       Left _ -> do
-        Log.debug $ "No cache found for " <> id <> " at path " <> path
         pure $ reply Nothing
       Right buf -> do
         pure $ reply $ Just buf
@@ -284,7 +280,6 @@ getFsImpl cacheDir = case _ of
     let path = Path.concat [ cacheDir, safePath id ]
     Run.liftAff (Aff.attempt (FS.Aff.readTextFile UTF8 path)) >>= case _ of
       Left _ -> do
-        Log.debug $ "No cache file found for " <> id <> " at path " <> path
         pure $ reply Nothing
       Right content -> case Argonaut.Parser.jsonParser content of
         Left parseError -> do
@@ -307,7 +302,6 @@ putFsImpl cacheDir next = case _ of
         Log.warn $ "Failed to write cache entry for " <> id <> " at path " <> path <> " as a buffer: " <> Aff.message fsError
         pure next
       Right _ -> do
-        Log.debug $ "Wrote cache entry for " <> id <> " as a buffer at path " <> path
         pure next
 
   AsJson id codec (Const value) -> do
@@ -317,7 +311,6 @@ putFsImpl cacheDir next = case _ of
         Log.warn $ "Failed to write cache entry for " <> id <> " at path " <> path <> " as JSON: " <> Aff.message fsError
         pure next
       Right _ -> do
-        Log.debug $ "Wrote cache entry for " <> id <> " at path " <> path <> " as JSON."
         pure next
 
 deleteFsImpl :: forall a b r. FilePath -> FsEncoding Ignore a b -> Run (LOG + AFF + r) a

app/src/App/Effect/GitHub.purs

@@ -241,8 +241,8 @@ request octokit githubRequest@{ route: route@(GitHubRoute method _ _), codec } =
             -- auto-expire cache entries. We will be behind GitHub at most this amount per repo.
             --
             -- TODO: This 'diff' check should be removed once we have conditional requests.
-            Right _ | DateTime.diff now prevResponse.modified >= Duration.Hours 4.0 -> do
-              Log.debug $ "Found cache entry but it was modified more than 4 hours ago, refetching " <> printedRoute
+            Right _ | DateTime.diff now prevResponse.modified >= Duration.Hours 24.0 -> do
+              Log.debug $ "Found cache entry but it was modified more than 24 hours ago, refetching " <> printedRoute
               result <- requestWithBackoff octokit githubRequest
               Cache.put _githubCache (Request route) (result <#> \resp -> { response: CA.encode codec resp, modified: now, etag: Nothing })
               pure result

app/src/App/Effect/PackageSets.purs

@@ -428,7 +428,7 @@ validatePackageSet (PackageSet set) = do
     -- We can now attempt to produce a self-contained manifest index from the
     -- collected manifests. If this fails then the package set is not
     -- self-contained.
-    Tuple unsatisfied _ = ManifestIndex.maximalIndex (Set.fromFoldable success)
+    Tuple unsatisfied _ = ManifestIndex.maximalIndex ManifestIndex.IgnoreRanges (Set.fromFoldable success)
 
   -- Otherwise, we can check if we were able to produce an index from the
   -- package set alone, without errors.

app/src/App/Effect/Registry.purs

@@ -251,7 +251,7 @@ handle env = Cache.interpret _registryCache (Cache.handleMemory env.cacheRef) <<
     let formatted = formatPackageVersion name version
     Log.info $ "Writing manifest for " <> formatted <> ":\n" <> printJson Manifest.codec manifest
     index <- Except.rethrow =<< handle env (ReadAllManifests identity)
-    case ManifestIndex.insert manifest index of
+    case ManifestIndex.insert ManifestIndex.ConsiderRanges manifest index of
       Left error ->
         Except.throw $ Array.fold
           [ "Can't insert " <> formatted <> " into manifest index because it has unsatisfied dependencies:"
@@ -274,7 +274,7 @@ handle env = Cache.interpret _registryCache (Cache.handleMemory env.cacheRef) <<
     let formatted = formatPackageVersion name version
     Log.info $ "Deleting manifest for " <> formatted
     index <- Except.rethrow =<< handle env (ReadAllManifests identity)
-    case ManifestIndex.delete name version index of
+    case ManifestIndex.delete ManifestIndex.ConsiderRanges name version index of
       Left error ->
         Except.throw $ Array.fold
           [ "Can't delete " <> formatted <> " from manifest index because it would produce unsatisfied dependencies:"
@@ -358,7 +358,7 @@ handle env = Cache.interpret _registryCache (Cache.handleMemory env.cacheRef) <<
 
         Just metadata -> do
           Log.debug $ "Successfully read metadata for " <> printedName <> " from path " <> path
-          Log.debug $ "Setting metadata cache to singleton entry (as cache was previosuly empty)."
+          Log.debug $ "Setting metadata cache to singleton entry (as cache was previously empty)."
           Cache.put _registryCache AllMetadata (Map.singleton name metadata)
           pure $ Just metadata
 
@@ -835,8 +835,9 @@ readManifestIndexFromDisk root = do
 
   entries <- map partitionEithers $ for packages.success (ManifestIndex.readEntryFile root)
   case entries.fail of
-    [] -> case ManifestIndex.fromSet $ Set.fromFoldable $ Array.foldMap NonEmptyArray.toArray entries.success of
+    [] -> case ManifestIndex.fromSet ManifestIndex.ConsiderRanges $ Set.fromFoldable $ Array.foldMap NonEmptyArray.toArray entries.success of
       Left errors -> do
+        Log.debug $ "Could not read a valid manifest index from entry files: " <> Array.foldMap (Array.foldMap (\(Manifest { name, version }) -> "\n  - " <> formatPackageVersion name version) <<< NonEmptyArray.toArray) entries.success
         Except.throw $ append "Unable to read manifest index (some packages are not satisfiable): " $ Array.foldMap (append "\n  - ") do
           Tuple name versions <- Map.toUnfoldable errors
           Tuple version dependency <- Map.toUnfoldable versions

app/src/App/Effect/Source.purs

@@ -6,6 +6,7 @@ import Registry.App.Prelude
 import Data.Array as Array
 import Data.DateTime (DateTime)
 import Data.JSDate as JSDate
+import Data.String as String
 import Effect.Aff as Aff
 import Effect.Exception as Exception
 import Effect.Now as Now
@@ -20,6 +21,7 @@ import Registry.App.Effect.GitHub as GitHub
 import Registry.App.Effect.Log (LOG)
 import Registry.App.Effect.Log as Log
 import Registry.App.Legacy.Types (RawVersion(..))
+import Registry.Foreign.FSExtra as FS.Extra
 import Registry.Foreign.Octokit as Octokit
 import Registry.Foreign.Tar as Foreign.Tar
 import Registry.Location as Location
@@ -28,8 +30,15 @@ import Run as Run
 import Run.Except (EXCEPT)
 import Run.Except as Except
 
+-- | Packages can be published via the legacy importer or a user via the API. We
+-- | determine some information differently in these cases, such as the time the
+-- | package was published.
+data ImportType = Old | Recent
+
+derive instance Eq ImportType
+
 -- | An effect for fetching package sources
-data Source a = Fetch PackageSource FilePath Location String (Either String FetchedSource -> a)
+data Source a = Fetch FilePath Location String (Either String FetchedSource -> a)
 
 derive instance Functor Source
 
@@ -41,17 +50,17 @@ _source = Proxy
 type FetchedSource = { path :: FilePath, published :: DateTime }
 
 -- | Fetch the provided location to the provided destination path.
-fetch :: forall r. PackageSource -> FilePath -> Location -> String -> Run (SOURCE + EXCEPT String + r) FetchedSource
-fetch source destination location ref = Except.rethrow =<< Run.lift _source (Fetch source destination location ref identity)
+fetch :: forall r. FilePath -> Location -> String -> Run (SOURCE + EXCEPT String + r) FetchedSource
+fetch destination location ref = Except.rethrow =<< Run.lift _source (Fetch destination location ref identity)
 
 -- | Run the SOURCE effect given a handler.
 interpret :: forall r a. (Source ~> Run r) -> Run (SOURCE + r) a -> Run r a
 interpret handler = Run.interpret (Run.on _source handler Run.send)
 
 -- | Handle the SOURCE effect by downloading package source to the file system.
-handle :: forall r a. Source a -> Run (GITHUB + LOG + AFF + EFFECT + r) a
-handle = case _ of
-  Fetch source destination location ref reply -> map (map reply) Except.runExcept do
+handle :: forall r a. ImportType -> Source a -> Run (GITHUB + LOG + AFF + EFFECT + r) a
+handle importType = case _ of
+  Fetch destination location ref reply -> map (map reply) Except.runExcept do
     Log.info $ "Fetching " <> printJson Location.codec location
     case location of
       Git _ -> do
@@ -83,24 +92,35 @@ handle = case _ of
                   Failed err -> Aff.throwError $ Aff.error err
                   Succeeded _ -> pure unit
 
+              alreadyExists = String.contains (String.Pattern "already exists and is not an empty directory")
+
             Run.liftAff (Aff.attempt clonePackageAtTag) >>= case _ of
-              Left error -> do
-                Log.error $ "Failed to clone git tag: " <> Aff.message error
-                Except.throw $ "Failed to clone repository " <> owner <> "/" <> repo <> " at ref " <> ref
               Right _ -> Log.debug $ "Cloned package source to " <> repoDir
+              Left error -> do
+                Log.error $ "Failed to clone git tag: " <> Aff.message error <> ", retrying..."
+                when (alreadyExists (Aff.message error)) $ FS.Extra.remove repoDir
+                Run.liftAff (Aff.attempt clonePackageAtTag) >>= case _ of
+                  Right _ -> Log.debug $ "Cloned package source to " <> repoDir
+                  Left error2 -> do
+                    Log.error $ "Failed to clone git tag (attempt 2): " <> Aff.message error2 <> ", retrying..."
+                    Run.liftAff (Aff.attempt clonePackageAtTag) >>= case _ of
+                      Right _ -> Log.debug $ "Cloned package source to " <> repoDir
+                      Left error3 -> do
+                        Log.error $ "Failed to clone git tag (attempt 3): " <> Aff.message error3
+                        Except.throw $ "Failed to clone repository " <> owner <> "/" <> repo <> " at ref " <> ref
 
             Log.debug $ "Getting published time..."
 
             let
-              getRefTime = case source of
-                LegacyPackage -> do
+              getRefTime = case importType of
+                Old -> do
                   timestamp <- Except.rethrow =<< Run.liftAff (Git.gitCLI [ "log", "-1", "--date=iso8601-strict", "--format=%cd", ref ] (Just repoDir))
                   jsDate <- Run.liftEffect $ JSDate.parse timestamp
                   dateTime <- case JSDate.toDateTime jsDate of
                     Nothing -> Except.throw $ "Could not parse timestamp of git ref to a datetime given timestamp " <> timestamp <> " and parsed js date " <> JSDate.toUTCString jsDate
                     Just parsed -> pure parsed
                   pure dateTime
-                CurrentPackage ->
+                Recent ->
                   Run.liftEffect Now.nowDateTime
 
             -- Cloning will result in the `repo` name as the directory name

app/src/App/GitHubIssue.purs

@@ -57,7 +57,7 @@ main = launchAff_ $ do
 
         Right packageOperation -> case packageOperation of
           Publish payload ->
-            API.publish CurrentPackage payload
+            API.publish payload
           Authenticated payload -> do
             -- If we receive an authenticated operation via GitHub, then we
             -- re-sign it with pacchettibotti credentials if and only if the
@@ -97,10 +97,11 @@ main = launchAff_ $ do
       # Registry.interpret (Registry.handle registryEnv)
       # Storage.interpret (Storage.handleS3 { s3: env.spacesConfig, cache })
       # Pursuit.interpret (Pursuit.handleAff env.token)
-      # Source.interpret Source.handle
+      # Source.interpret (Source.handle Source.Recent)
       # GitHub.interpret (GitHub.handle { octokit: env.octokit, cache, ref: githubCacheRef })
       -- Caching & logging
       # Cache.interpret Legacy.Manifest._legacyCache (Cache.handleMemoryFs { cache, ref: legacyCacheRef })
+      # Cache.interpret API._compilerCache (Cache.handleFs cache)
       # Except.catch (\msg -> Log.error msg *> Comment.comment msg *> Run.liftEffect (Ref.write true thrownRef))
       # Comment.interpret (Comment.handleGitHub { octokit: env.octokit, issue: env.issue, registry: Registry.defaultRepos.registry })
       # Log.interpret (Log.handleTerminal Verbose)

app/src/App/Legacy/Manifest.purs

@@ -9,7 +9,6 @@ import Data.Codec.Argonaut.Record as CA.Record
 import Data.Codec.Argonaut.Variant as CA.Variant
 import Data.Either as Either
 import Data.Exists as Exists
-import Data.FunctorWithIndex (mapWithIndex)
 import Data.Map (SemigroupMap(..))
 import Data.Map as Map
 import Data.Ord.Max (Max(..))
@@ -35,7 +34,7 @@ import Registry.App.Legacy.LenientRange as LenientRange
 import Registry.App.Legacy.LenientVersion as LenientVersion
 import Registry.App.Legacy.PackageSet as Legacy.PackageSet
 import Registry.App.Legacy.Types (LegacyPackageSet(..), LegacyPackageSetEntry, LegacyPackageSetUnion, RawPackageName(..), RawVersion(..), RawVersionRange(..), legacyPackageSetCodec, legacyPackageSetUnionCodec, rawPackageNameMapCodec, rawVersionCodec, rawVersionRangeCodec)
-import Registry.Foreign.Octokit (Address, GitHubError)
+import Registry.Foreign.Octokit (Address, GitHubError(..))
 import Registry.Foreign.Octokit as Octokit
 import Registry.Foreign.Tmp as Tmp
 import Registry.License as License
@@ -137,21 +136,13 @@ fetchLegacyManifest name address ref = Run.Except.runExceptAt _legacyManifestErr
               Left bowerError, Left _ -> Left bowerError
               Right bowerDeps, Left _ -> Right bowerDeps
               Left _, Right spagoDeps -> Right spagoDeps
-              Right bowerDeps, Right spagoDeps -> Right do
-                bowerDeps # mapWithIndex \package range ->
-                  case Map.lookup package spagoDeps of
-                    Nothing -> range
-                    Just spagoRange -> Range.union range spagoRange
+              Right bowerDeps, Right spagoDeps -> Right $ Map.unionWith Range.union bowerDeps spagoDeps
 
       unionPackageSets = case maybePackageSetDeps, unionManifests of
         Nothing, Left manifestError -> Left manifestError
         Nothing, Right manifestDeps -> Right manifestDeps
         Just packageSetDeps, Left _ -> Right packageSetDeps
-        Just packageSetDeps, Right manifestDeps -> Right do
-          packageSetDeps # mapWithIndex \package range ->
-            case Map.lookup package manifestDeps of
-              Nothing -> range
-              Just manifestRange -> Range.union range manifestRange
+        Just packageSetDeps, Right manifestDeps -> Right $ Map.unionWith Range.union manifestDeps packageSetDeps
 
     Run.Except.rethrowAt _legacyManifestError unionPackageSets
 
@@ -221,16 +212,22 @@ fetchLegacyManifestFiles
   :: forall r
    . Address
   -> RawVersion
-  -> Run (GITHUB + LOG + AFF + EFFECT + r) (Either LegacyManifestValidationError (These Bowerfile SpagoDhallJson))
+  -> Run (GITHUB + LOG + AFF + EFFECT + EXCEPT String + r) (Either LegacyManifestValidationError (These Bowerfile SpagoDhallJson))
 fetchLegacyManifestFiles address ref = do
   eitherBower <- fetchBowerfile address ref
-  void $ flip ltraverse eitherBower \error ->
-    Log.debug $ "Failed to fetch bowerfile: " <> Octokit.printGitHubError error
+  void $ flip ltraverse eitherBower case _ of
+    APIError { statusCode } | statusCode == 401 ->
+      Except.throw "Permission error on token used to fetch manifests!"
+    error ->
+      Log.debug $ "Failed to fetch bowerfile: " <> Octokit.printGitHubError error
   eitherSpago <- fetchSpagoDhallJson address ref
-  void $ flip ltraverse eitherSpago \error ->
-    Log.debug $ "Failed to fetch spago.dhall: " <> Octokit.printGitHubError error
+  void $ flip ltraverse eitherSpago case _ of
+    APIError { statusCode } | statusCode == 401 ->
+      Except.throw "Permission error on token used to fetch manifests!"
+    error ->
+      Log.debug $ "Failed to fetch spago.dhall: " <> Octokit.printGitHubError error
   pure $ case eitherBower, eitherSpago of
-    Left _, Left _ -> Left { error: NoManifests, reason: "No bower.json or spago.dhall files available." }
+    Left errL, Left errR -> Left { error: NoManifests, reason: "No bower.json or spago.dhall files available: " <> Octokit.printGitHubError errL <> ", " <> Octokit.printGitHubError errR }
     Right bower, Left _ -> Right $ This bower
     Left _, Right spago -> Right $ That spago
     Right bower, Right spago -> Right $ Both bower spago