Only pick up last 24hrs in daily publish job

app/src/App/Effect/GitHub.purs

@@ -12,6 +12,7 @@ module Registry.App.Effect.GitHub
   , getRefCommit
   , handle
   , interpret
+  , listCommitsSince
   , listTags
   , listTeamMembers
   ) where
@@ -73,6 +74,7 @@ instance FsEncodable GitHubCache where
 
 data GitHub a
   = ListTags Address (Either GitHubError (Array Tag) -> a)
+  | ListCommitsSince Address DateTime (Either GitHubError (Array String) -> a)
   | ListTeamMembers Team (Either GitHubError (Array String) -> a)
   | GetContent Address String FilePath (Either GitHubError String -> a)
   | GetRefCommit Address String (Either GitHubError String -> a)
@@ -90,6 +92,10 @@ _github = Proxy
 listTags :: forall r. Address -> Run (GITHUB + r) (Either GitHubError (Array Tag))
 listTags address = Run.lift _github (ListTags address identity)
 
+-- | List commits since a given date. Returns an array of commit SHAs.
+listCommitsSince :: forall r. Address -> DateTime -> Run (GITHUB + r) (Either GitHubError (Array String))
+listCommitsSince address since = Run.lift _github (ListCommitsSince address since identity)
+
 -- | List the members of the provided team. Requires that the authorization on
 -- | the request has read rights for the given organization and team.
 listTeamMembers :: forall r. Team -> Run (GITHUB + r) (Either GitHubError (Array String))
@@ -139,6 +145,11 @@ handle env = Cache.interpret _githubCache (Cache.handleMemoryFs { cache: env.cac
     result <- request env.octokit (Octokit.listTagsRequest address)
     pure $ reply result
 
+  ListCommitsSince address since reply -> do
+    Log.debug $ "Listing commits since " <> Internal.Codec.formatIso8601 since <> " for " <> address.owner <> "/" <> address.repo
+    result <- request env.octokit (Octokit.listCommitsSinceRequest { address, since })
+    pure $ reply $ map (map _.sha) result
+
   ListTeamMembers team reply -> do
     Log.debug $ "Listing members of team " <> team.org <> "/" <> team.team
     result <- request env.octokit (Octokit.listTeamMembersRequest team)

app/test/Test/Assert/Run.purs

@@ -403,6 +403,9 @@ handleGitHubMock env = case _ of
 
     pure $ reply $ Right tags
 
+  ListCommitsSince _address _since reply ->
+    pure $ reply $ Left $ UnexpectedError "Unimplemented"
+
   ListTeamMembers team reply -> pure $ reply $ case team of
     { org: "purescript", team: "packaging" } -> Right [ "pacchettibotti", "f-f", "thomashoneyman" ]
     _ -> Left $ APIError { statusCode: 404, message: "No fixture provided for team " <> team.org <> "/" <> team.team }

foreign/src/Foreign/Octokit.purs

@@ -29,8 +29,10 @@ module Registry.Foreign.Octokit
   , githubApiErrorCodec
   , githubErrorCodec
   , isPermanentGitHubError
+  , listCommitsSinceRequest
   , listTagsRequest
   , listTeamMembersRequest
+  , CommitSha
   , newOctokit
   , noArgs
   , printGitHubError
@@ -158,6 +160,19 @@ listTagsRequest address =
   toJsonRep { name, sha, url } = { name, commit: { sha, url } }
   fromJsonRep { name, commit } = { name, sha: commit.sha, url: commit.url }
 
+type CommitSha = { sha :: String }
+
+-- | List repository commits since a given date
+-- | https://docs.github.com/en/rest/commits/commits#list-commits
+listCommitsSinceRequest :: { address :: Address, since :: DateTime } -> Request (Array CommitSha)
+listCommitsSinceRequest { address, since } =
+  { route: GitHubRoute GET [ "repos", address.owner, address.repo, "commits" ] (Map.singleton "since" (Internal.Codec.formatIso8601 since))
+  , headers: Object.empty
+  , args: noArgs
+  , paginate: true
+  , codec: CJ.array $ CJ.named "CommitSha" $ CJ.Record.object { sha: CJ.string }
+  }
+
 -- | Fetch a specific file  from the provided repository at the given ref and
 -- | filepath. Filepaths should lead to a single file from the root of the repo.
 -- | https://github.com/octokit/plugin-rest-endpoint-methods.js/blob/v5.16.0/docs/repos/getContent.md

lib/src/Internal/Codec.purs

@@ -1,5 +1,6 @@
 module Registry.Internal.Codec
-  ( iso8601Date
+  ( formatIso8601
+  , iso8601Date
   , iso8601DateTime
   , limitedString
   , packageMap
@@ -40,6 +41,12 @@ import Registry.PackageName as PackageName
 import Registry.Version (Version)
 import Registry.Version as Version
 
+-- | INTERNAL
+-- |
+-- | Format a DateTime as an ISO8601 string.
+formatIso8601 :: DateTime -> String
+formatIso8601 = Formatter.DateTime.format Internal.Format.iso8601DateTime
+
 -- | INTERNAL
 -- |
 -- | A codec for date times that encode as JSON strings in the ISO8601 date-time

nix/test/config.nix

@@ -309,6 +309,33 @@ let
         ];
       };
     }
+    # Commits endpoint for prelude - return empty (no recent commits)
+    {
+      request = {
+        method = "GET";
+        urlPattern = "/repos/purescript/purescript-prelude/commits\\?since=.*";
+      };
+      response = {
+        status = 200;
+        headers."Content-Type" = "application/json";
+        jsonBody = [ ];
+      };
+    }
+    # Commits endpoint for type-equality - return the v4.0.2 commit sha
+    # This makes the DailyImporter detect that v4.0.2 is a recent commit
+    {
+      request = {
+        method = "GET";
+        urlPattern = "/repos/purescript/purescript-type-equality/commits\\?since=.*";
+      };
+      response = {
+        status = 200;
+        headers."Content-Type" = "application/json";
+        jsonBody = [
+          { sha = "type-eq-sha-402"; }
+        ];
+      };
+    }
     # Tags for type-equality package (used by two scheduler tests):
     # 1. Transfer detection: metadata says purescript, commit URLs point to new-owner
     # 2. Legacy imports: v4.0.2 is a new version not yet published

scripts/src/DailyImporter.purs

@@ -1,13 +1,14 @@
--- | This script checks for new package versions by fetching GitHub tags for all
--- | packages in the registry. When a new version is discovered (a tag that hasn't
--- | been published or unpublished), it submits a publish job to the registry API.
+-- | This script checks for new package versions by fetching commits from the last
+-- | 24 hours for all packages in the registry. When a recent commit is found that
+-- | corresponds to an unpublished version tag, it submits a publish job to the
+-- | registry API.
 -- |
 -- | Run via Nix:
 -- |   nix run .#daily-importer -- --dry-run     # Log what would be submitted
 -- |   nix run .#daily-importer -- --submit      # Actually submit to the API
 -- |
 -- | Required environment variables:
--- |   GITHUB_TOKEN - GitHub API token for fetching tags
+-- |   GITHUB_TOKEN - GitHub API token for fetching commits and tags
 -- |   REGISTRY_API_URL - Registry API URL (default: https://registry.purescript.org)
 module Registry.Scripts.DailyImporter where
 
@@ -18,10 +19,13 @@ import ArgParse.Basic as Arg
 import Codec.JSON.DecodeError as CJ.DecodeError
 import Data.Array as Array
 import Data.Codec.JSON as CJ
+import Data.DateTime as DateTime
 import Data.Map as Map
 import Data.Set as Set
+import Data.Time.Duration (Hours(..))
 import Effect.Aff as Aff
 import Effect.Class.Console as Console
+import Effect.Now as Now
 import Fetch (Method(..))
 import Fetch as Fetch
 import JSON as JSON
@@ -112,46 +116,63 @@ runDailyImport :: Mode -> URL -> Run DailyImportEffects Unit
 runDailyImport mode registryApiUrl = do
   Log.info "Daily Importer: checking for new package versions..."
 
+  now <- Run.liftEffect Now.nowDateTime
+  let since = fromMaybe now $ DateTime.adjust (Hours (-24.0)) now
+
   allMetadata <- Registry.readAllMetadata
   let packages = Map.toUnfoldable allMetadata :: Array (Tuple PackageName Metadata)
 
-  Log.info $ "Checking " <> show (Array.length packages) <> " packages for new versions..."
+  Log.info $ "Checking " <> show (Array.length packages) <> " packages for commits in the last 24 hours..."
 
   submitted <- for packages \(Tuple name (Metadata metadata)) -> do
     case metadata.location of
       Git _ -> pure 0 -- Skip non-GitHub packages for now
       GitHub { owner, repo } -> do
-        GitHub.listTags { owner, repo } >>= case _ of
+        let address = { owner, repo }
+        -- First, check if there are any recent commits
+        GitHub.listCommitsSince address since >>= case _ of
           Left err -> do
-            Log.debug $ "Failed to fetch tags for " <> PackageName.print name <> ": " <> Octokit.printGitHubError err
+            Log.debug $ "Failed to fetch commits for " <> PackageName.print name <> ": " <> Octokit.printGitHubError err
+            pure 0
+          Right [] -> do
+            -- No recent commits, skip fetching tags
             pure 0
-          Right tags -> do
-            let
-              -- Combine published and unpublished versions into a set
-              publishedVersions = Set.fromFoldable
-                $ Map.keys metadata.published
-                <> Map.keys metadata.unpublished
-
-              -- Parse tags as versions and filter out already published ones
-              newVersions = Array.catMaybes $ tags <#> \tag ->
-                case LenientVersion.parse tag.name of
-                  Left _ -> Nothing -- Not a valid version tag
-                  Right result ->
-                    let
-                      version = LenientVersion.version result
-                    in
-                      if Set.member version publishedVersions then Nothing
-                      else Just { version, ref: tag.name }
-
-            -- Submit publish jobs for new versions
-            count <- for newVersions \{ version, ref } -> do
-              submitPublishJob mode registryApiUrl name version ref
-
-            pure $ Array.length $ Array.filter identity count
+          Right recentCommitShas -> do
+            let recentShas = Set.fromFoldable recentCommitShas
+            -- There are recent commits, now fetch tags to see if any point to them
+            GitHub.listTags address >>= case _ of
+              Left err -> do
+                Log.debug $ "Failed to fetch tags for " <> PackageName.print name <> ": " <> Octokit.printGitHubError err
+                pure 0
+              Right tags -> do
+                let
+                  publishedVersions = combinedPublishedVersions { published: metadata.published, unpublished: metadata.unpublished }
+                  newVersions = findNewVersions tags recentShas publishedVersions
+
+                -- Submit publish jobs for new versions
+                count <- for newVersions \{ version, ref } -> do
+                  submitPublishJob mode registryApiUrl name version ref
+
+                pure $ Array.length $ Array.filter identity count
 
   let totalSubmitted = Array.foldl (+) 0 submitted
   Log.info $ "Daily Importer complete. Submitted " <> show totalSubmitted <> " publish jobs."
 
+-- | Combine published and unpublished versions into a set
+combinedPublishedVersions :: forall a b. { published :: Map Version a, unpublished :: Map Version b } -> Set Version
+combinedPublishedVersions metadata = Set.fromFoldable $ Map.keys metadata.published <> Map.keys metadata.unpublished
+
+-- | Find new version tags that point to recent commits and haven't been published
+findNewVersions :: Array Octokit.Tag -> Set String -> Set Version -> Array { version :: Version, ref :: String }
+findNewVersions tags recentShas publishedVersions = Array.catMaybes $ tags <#> \tag ->
+  case LenientVersion.parse tag.name of
+    Left _ -> Nothing -- Not a valid version tag
+    Right result -> do
+      let version = LenientVersion.version result
+      if not (Set.member tag.sha recentShas) then Nothing -- Tag doesn't point to a recent commit
+      else if Set.member version publishedVersions then Nothing -- Already published
+      else Just { version, ref: tag.name }
+
 -- | Submit a publish job for a new package version. The compiler is not specified; the registry
 -- | API will discover the latest compatible compiler based on the package's dependencies.
 submitPublishJob :: Mode -> URL -> PackageName -> Version -> String -> Run DailyImportEffects Boolean

scripts/src/VerifyIntegrity.purs

@@ -12,9 +12,9 @@ import Data.Either (isLeft)
 import Data.Foldable (class Foldable, foldM, intercalate)
 import Data.Formatter.DateTime as Formatter.DateTime
 import Data.Map as Map
-import Effect.Aff as Aff
 import Data.Set as Set
 import Data.String as String
+import Effect.Aff as Aff
 import Effect.Class.Console (log)
 import Effect.Class.Console as Console
 import Node.FS.Aff as FS.Aff