From 56837859083089777f9b7d477c441fbf0c068d14 Mon Sep 17 00:00:00 2001 From: Thomas Honeyman Date: Mon, 16 Mar 2026 10:11:34 -0400 Subject: [PATCH] add readonly mode, more efficient package sets --- .env.example | 9 ++++++ app/src/App/Effect/Env.purs | 14 +++++++++ app/src/App/Effect/PackageSets.purs | 45 ++++++++++++++++++++++++---- app/src/App/Main.purs | 2 ++ app/src/App/Server/Env.purs | 14 ++++++--- app/test/App/Effect/PackageSets.purs | 39 ++++++++++++++++++++++++ 6 files changed, 113 insertions(+), 10 deletions(-) diff --git a/.env.example b/.env.example index 78a8fbebb..ea0488ffe 100644 --- a/.env.example +++ b/.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) # ----------------------------------------------------------------------------- diff --git a/app/src/App/Effect/Env.purs b/app/src/App/Effect/Env.purs index 873162264..268ac4f38 100644 --- a/app/src/App/Effect/Env.purs +++ b/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 } diff --git a/app/src/App/Effect/PackageSets.purs b/app/src/App/Effect/PackageSets.purs index 836fcf738..f50f73445 100644 --- a/app/src/App/Effect/PackageSets.purs +++ b/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 diff --git a/app/src/App/Main.purs b/app/src/App/Main.purs index 8ad4fd7a0..7db4b4c6a 100644 --- a/app/src/App/Main.purs +++ b/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 diff --git a/app/src/App/Server/Env.purs b/app/src/App/Server/Env.purs index 58beff40d..e3a27600d 100644 --- a/app/src/App/Server/Env.purs +++ b/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) diff --git a/app/test/App/Effect/PackageSets.purs b/app/test/App/Effect/PackageSets.purs index 399862e0e..f56562ab8 100644 --- a/app/test/App/Effect/PackageSets.purs +++ b/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"