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

SPEC.md

@@ -207,7 +207,7 @@ Note:
 
 - Globs you provide at the `includeFiles` and `excludeFiles` keys must contain only `*`, `**`, `/`, `.`, `..`, and characters for Linux file paths. It is not possible to negate a glob (ie. the `!` character), and globs cannot represent a path out of the package source directory.
 - When packaging your project source, the registry will first "include" your `src` directory and always-included files such as your `purs.json` file. Then it will include files which match globs indicated by the `includeFiles` key ([always-ignored files](#always-ignored-files) cannot be included). Finally, it will apply the excluding globs indicated by the `excludeFiles` key to the included files ([always-included files](#always-included-files) cannot be excluded).
-- Dependencies you provide at the `dependencies` key must exist in the registry, and the dependency ranges must be solvable (ie. it must be possible to produce a single version of each dependency that satisfies the provided version bounds, including any transitive dependencies).
+- Dependencies you provide at the `dependencies` key must exist in the registry, the dependency ranges must be solvable (ie. it must be possible to produce a single version of each dependency that satisfies the provided version bounds, including any transitive dependencies), and transitive dependencies are not allowed (ie. any modules you import in your code must come from packages listed in your dependencies).
 
 For example:
 
@@ -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/github-packages/transitive-1.0.0/bower.json

@@ -0,0 +1,12 @@
+{
+  "name": "purescript-transitive",
+  "homepage": "https://github.com/purescript/purescript-transitive",
+  "license": "BSD-3-Clause",
+  "repository": {
+    "type": "git",
+    "url": "https://github.com/purescript/purescript-transitive.git"
+  },
+  "dependencies": {
+    "purescript-effect": "^4.0.0"
+  }
+}

app/fixtures/github-packages/transitive-1.0.0/src/Transitive.purs

@@ -0,0 +1,6 @@
+module Transitive where
+
+import Prelude
+
+uno :: Int
+uno = one

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/Git.purs

@@ -111,11 +111,12 @@ gitPull { address: { owner, repo }, pullMode } cwd = Except.runExcept do
         , " has no untracked or dirty files, it is safe to pull the latest."
         ]
       pure true
-    Just files -> do
-      Log.debug $ Array.fold
-        [ "Some files are untracked or dirty in local checkout of " <> cwd <> ": "
-        , NonEmptyArray.foldMap1 (append "\n  - ") files
-        ]
+    Just _files -> do
+      -- This is a bit noisy, so commenting it out for now.
+      -- Log.debug $ Array.fold
+      --   [ "Some files are untracked or dirty in local checkout of " <> cwd <> ": "
+      --   , NonEmptyArray.foldMap1 (append "\n  - ") files
+      --   ]
       Log.warn $ Array.fold
         [ "Local checkout of " <> formatted
         , " has untracked or dirty files, it may not be safe to pull the latest."

app/src/App/CLI/Purs.purs

@@ -12,6 +12,16 @@ import Node.ChildProcess.Types (Exit(..))
 import Node.Library.Execa as Execa
 import Registry.Version as Version
 
+-- | The minimum compiler version that supports 'purs graph'
+minPursGraph :: Version
+minPursGraph = unsafeFromRight (Version.parse "0.14.0")
+
+minPursuitPublish :: Version
+minPursuitPublish = unsafeFromRight (Version.parse "0.14.7")
+
+minLanguageCSTParser :: Version
+minLanguageCSTParser = unsafeFromRight (Version.parse "0.15.0")
+
 -- | Call a specific version of the PureScript compiler
 callCompiler_ :: { version :: Maybe Version, command :: PursCommand, cwd :: Maybe FilePath } -> Aff Unit
 callCompiler_ = void <<< callCompiler
@@ -22,6 +32,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 23.0 -> do
+              Log.debug $ "Found cache entry but it was modified more than 23 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
@@ -877,10 +878,10 @@ readAllMetadataFromDisk metadataDir = do
 
   entries <- Run.liftAff $ map partitionEithers $ for packages.success \name -> do
     result <- readJsonFile Metadata.codec (Path.concat [ metadataDir, PackageName.print name <> ".json" ])
-    pure $ map (Tuple name) result
+    pure $ bimap (Tuple name) (Tuple name) result
 
   unless (Array.null entries.fail) do
-    Except.throw $ append "Could not read metadata for all packages because the metadata directory is invalid (some package metadata cannot be decoded):" $ Array.foldMap (append "\n  - ") entries.fail
+    Except.throw $ append "Could not read metadata for all packages because the metadata directory is invalid (some package metadata cannot be decoded):" $ Array.foldMap (\(Tuple name err) -> "\n  - " <> PackageName.print name <> ": " <> err) entries.fail
 
   Log.debug "Successfully read metadata entries."
   pure $ Map.fromFoldable entries.success

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
@@ -73,7 +82,7 @@ handle = case _ of
             Log.debug $ "Using legacy Git clone to fetch package source at tag: " <> show { owner, repo, ref }
 
             let
-              repoDir = Path.concat [ destination, repo ]
+              repoDir = Path.concat [ destination, repo <> "-" <> ref ]
 
               clonePackageAtTag = do
                 let url = Array.fold [ "https://github.com/", owner, "/", repo ]
@@ -83,24 +92,38 @@ 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.delay (Aff.Milliseconds 1000.0))
+                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..."
+                    when (alreadyExists (Aff.message error)) $ FS.Extra.remove repoDir
+                    Run.liftAff (Aff.delay (Aff.Milliseconds 1000.0))
+                    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