add readonly mode, more efficient package sets (#760)

Author: thomashoneyman

.env.example

@@ -35,6 +35,15 @@ SPACES_KEY="digitalocean_spaces_key"
 SPACES_SECRET="digitalocean_spaces_secret"
 
 
+# -----------------------------------------------------------------------------
+# Debug / Development Options
+# -----------------------------------------------------------------------------
+
+# When "true", the server skips all writes: git push, S3 upload, Pursuit publish.
+# Reads and compilations still run normally. Useful for reproducing slow jobs
+# locally without affecting the real registry.
+# READONLY=true
+
 # -----------------------------------------------------------------------------
 # Script-only Secrets (not used by server, used by scripts like legacy-importer)
 # -----------------------------------------------------------------------------

app/src/App/Effect/Env.purs

@@ -281,6 +281,20 @@ pacchettibottiED25519Pub = EnvKey
         pure keyFields.key
   }
 
+-- | When set to "true", the server will skip all writes (git push, S3 upload,
+-- | Pursuit publish). Reads and compilations still run normally, which is
+-- | useful for debugging locally without affecting the real registry.
+readOnly :: EnvKey Boolean
+readOnly = EnvKey
+  { key: "READONLY"
+  , decode: case _ of
+      "true" -> Right true
+      "false" -> Right false
+      "1" -> Right true
+      "0" -> Right false
+      other -> Left $ "Expected 'true' or 'false', got: " <> other
+  }
+
 -- | A file path to the JSON payload describing the triggered GitHub event.
 githubEventPath :: EnvKey FilePath
 githubEventPath = EnvKey { key: "GITHUB_EVENT_PATH", decode: pure }

app/src/App/Effect/PackageSets.purs

@@ -91,13 +91,26 @@ handle env = case _ of
   UpgradeAtomic oldSet@(PackageSet { packages }) compiler changes reply -> reply <$> Except.runExcept do
     Log.info $ "Performing atomic upgrade of package set " <> Version.print (un PackageSet oldSet).version
 
-    -- It is possible to reuse a workdir when processing package set batches, so
-    -- we need to clean up before doing work.
-    for_ [ packagesWorkDir, outputWorkDir, backupWorkDir ] \dir -> do
-      exists <- Run.liftEffect $ FS.Sync.exists dir
+    -- Always clean up the backup directory, which is transient and may be
+    -- left over from a previous crashed job.
+    do
+      exists <- Run.liftEffect $ FS.Sync.exists backupWorkDir
       when exists do
-        Log.debug $ "Removing existing working directory " <> dir
-        FS.Extra.remove dir
+        Log.debug $ "Removing leftover backup directory " <> backupWorkDir
+        FS.Extra.remove backupWorkDir
+
+    -- Wipe the compiler output if the compiler version has changed, because
+    -- output from a different compiler version is not safe to reuse.
+    when (compiler /= (un PackageSet oldSet).compiler) do
+      outputExists <- Run.liftEffect $ FS.Sync.exists outputWorkDir
+      when outputExists do
+        Log.info $ "Compiler version changed, wiping output directory"
+        FS.Extra.remove outputWorkDir
+
+    -- Sync the packages directory: remove any extraneous packages left from
+    -- a previous job, then install missing ones. This lets the compiler do
+    -- incremental compilation when resubmitting the same or similar jobs.
+    syncPackages packages
 
     installPackages packages
     compileInstalledPackages compiler >>= case _ of
@@ -183,6 +196,19 @@ handle env = case _ of
   backupWorkDir :: FilePath
   backupWorkDir = Path.concat [ env.workdir, "output-backup" ]
 
+  -- | Remove directories in packages/ that don't correspond to a package
+  -- | in the target set. This prevents stale packages from being compiled.
+  syncPackages :: Map PackageName Version -> Run _ Unit
+  syncPackages targetPackages = do
+    packagesExist <- Run.liftEffect $ FS.Sync.exists packagesWorkDir
+    when packagesExist do
+      existingDirs <- Run.liftAff $ FS.Aff.readdir packagesWorkDir
+      let extraneous = extraneousPackageDirs targetPackages existingDirs
+      unless (Array.null extraneous) do
+        Log.info $ "Removing " <> show (Array.length extraneous) <> " extraneous packages from previous job: " <> String.joinWith ", " extraneous
+        for_ extraneous \dir ->
+          FS.Extra.remove (Path.concat [ packagesWorkDir, dir ])
+
   printMissingCompiler version = "Compilation failed because compiler " <> Version.print version <> " is missing."
   printUnknownError error = "Compilation failed because of an unknown error: " <> error
   printCompilationError errors = "Compilation failed with errors:\n" <> Purs.printCompilerErrors errors
@@ -345,6 +371,13 @@ commitMessage (PackageSet set) accepted newVersion = String.joinWith "\n" $ fold
     Tuple packageName version <- removed
     pure $ Array.fold [ "  - ", formatPackageVersion packageName version ]
 
+-- | Compute directory names in packages/ that don't correspond to any package
+-- | in the target set and should be removed before compilation.
+extraneousPackageDirs :: Map PackageName Version -> Array String -> Array String
+extraneousPackageDirs targetPackages existingDirs = do
+  let expectedDirs = Set.fromFoldable $ map (\(Tuple name version) -> formatPackageVersion name version) (Map.toUnfoldable targetPackages :: Array _)
+  Array.filter (\dir -> not (Set.member dir expectedDirs)) existingDirs
+
 -- | Computes new package set version from old package set and version information of successfully added/updated packages.
 -- | Note: this must be called with the old `PackageSet` that has not had updates applied.
 computeNewVersion :: Version -> PackageSet -> ChangeSet -> Version

app/src/App/Main.purs

@@ -18,6 +18,8 @@ main = createServerEnv # Aff.runAff_ case _ of
     Console.log $ "Failed to start server: " <> Aff.message error
     Process.exit' 1
   Right env -> do
+    when env.vars.readOnly do
+      Console.log "READONLY mode enabled: git push, S3 upload, and Pursuit publish are disabled."
     case env.vars.resourceEnv.healthchecksUrl of
       Nothing -> Console.log "HEALTHCHECKS_URL not set, healthcheck pinging disabled"
       Just healthchecksUrl -> Aff.launchAff_ $ healthcheck healthchecksUrl

app/src/App/Server/Env.purs

@@ -50,6 +50,7 @@ type ServerEnvVars =
   , spacesKey :: String
   , spacesSecret :: String
   , resourceEnv :: ResourceEnv
+  , readOnly :: Boolean
   }
 
 readServerEnvVars :: Aff ServerEnvVars
@@ -62,7 +63,8 @@ readServerEnvVars = do
   spacesKey <- Env.lookupRequired Env.spacesKey
   spacesSecret <- Env.lookupRequired Env.spacesSecret
   resourceEnv <- Env.lookupResourceEnv
-  pure { token, publicKey, privateKey, spacesKey, spacesSecret, resourceEnv }
+  isReadOnly <- Env.lookupWithDefault Env.readOnly false
+  pure { token, publicKey, privateKey, spacesKey, spacesSecret, resourceEnv, readOnly: isReadOnly }
 
 type ServerEnv =
   { cacheDir :: FilePath
@@ -137,20 +139,24 @@ runEffects env operation = Aff.attempt do
   today <- nowUTC
   let logFile = String.take 10 (Formatter.DateTime.format Internal.Format.iso8601Date today) <> ".log"
   let logPath = Path.concat [ env.logsDir, logFile ]
+  let
+    writeMode
+      | env.vars.readOnly = Registry.ReadOnly
+      | otherwise = Registry.CommitAs (Git.pacchettibottiCommitter env.vars.token)
   operation
     # PackageSets.interpret (PackageSets.handle { workdir: scratchDir })
     # Registry.interpret
         ( Registry.handle
             { repos: Registry.defaultRepos
             , pull: Git.ForceClean
-            , write: Registry.CommitAs (Git.pacchettibottiCommitter env.vars.token)
+            , write: writeMode
             , workdir: scratchDir
             , debouncer: env.debouncer
             , cacheRef: env.registryCacheRef
             }
         )
-    # Pursuit.interpret (Pursuit.handleAff env.vars.token)
-    # Storage.interpret (Storage.handleS3 { s3: { key: env.vars.spacesKey, secret: env.vars.spacesSecret }, cache: env.cacheDir })
+    # Pursuit.interpret (if env.vars.readOnly then Pursuit.handlePure else Pursuit.handleAff env.vars.token)
+    # Storage.interpret (if env.vars.readOnly then Storage.handleReadOnly env.cacheDir else Storage.handleS3 { s3: { key: env.vars.spacesKey, secret: env.vars.spacesSecret }, cache: env.cacheDir })
     # Source.interpret Source.handle
     # GitHub.interpret (GitHub.handle { octokit: env.octokit, cache: env.cacheDir, ref: env.githubCacheRef })
     # Cache.interpret _compilerCache (Cache.handleFs env.cacheDir)

app/test/App/Effect/PackageSets.purs

@@ -95,6 +95,45 @@ spec = do
       -- bar (dependency) must come before foo (dependent)
       names `Assert.shouldEqual` [ bar, foo ]
 
+  Spec.describe "extraneousPackageDirs" do
+    Spec.it "Returns empty when packages/ matches the target set" do
+      let
+        target = Map.fromFoldable
+          [ Tuple (Utils.unsafePackageName "aff") (Utils.unsafeVersion "7.0.0")
+          , Tuple (Utils.unsafePackageName "prelude") (Utils.unsafeVersion "6.0.0")
+          ]
+        existing = [ "aff@7.0.0", "prelude@6.0.0" ]
+      PackageSets.extraneousPackageDirs target existing `Assert.shouldEqual` []
+
+    Spec.it "Identifies stale packages not in the target set" do
+      let
+        target = Map.fromFoldable
+          [ Tuple (Utils.unsafePackageName "aff") (Utils.unsafeVersion "7.0.0")
+          ]
+        existing = [ "aff@7.0.0", "stale@1.0.0", "old-pkg@2.0.0" ]
+      PackageSets.extraneousPackageDirs target existing `Assert.shouldEqual` [ "stale@1.0.0", "old-pkg@2.0.0" ]
+
+    Spec.it "Identifies old versions of updated packages as extraneous" do
+      let
+        target = Map.fromFoldable
+          [ Tuple (Utils.unsafePackageName "aff") (Utils.unsafeVersion "8.0.0")
+          ]
+        existing = [ "aff@7.0.0" ]
+      PackageSets.extraneousPackageDirs target existing `Assert.shouldEqual` [ "aff@7.0.0" ]
+
+    Spec.it "Returns all dirs when target set is empty" do
+      let
+        target = Map.empty :: Map PackageName Version
+        existing = [ "aff@7.0.0", "prelude@6.0.0" ]
+      PackageSets.extraneousPackageDirs target existing `Assert.shouldEqual` [ "aff@7.0.0", "prelude@6.0.0" ]
+
+    Spec.it "Returns empty when packages/ is empty" do
+      let
+        target = Map.fromFoldable
+          [ Tuple (Utils.unsafePackageName "aff") (Utils.unsafeVersion "7.0.0")
+          ]
+      PackageSets.extraneousPackageDirs target [] `Assert.shouldEqual` []
+
     Spec.it "Processes updates before removals" do
       let
         foo = Utils.unsafePackageName "foo"