path: root/guix-data-service/model/blocked-builds.scm

;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2022 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-data-service model blocked-builds)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (squee)
  #:use-module (json)
  #:use-module (guix-data-service database)
  #:use-module (guix-data-service utils)
  #:use-module (guix-data-service model utils)
  #:use-module (guix-data-service model system)
  #:use-module (guix-data-service model guix-revision)
  #:use-module (guix-data-service model guix-revision-package-derivation)
  #:use-module (guix-data-service model build)
  #:export (handle-blocked-builds-entries-for-scheduled-builds
            handle-populating-blocked-builds-for-build-failures
            handle-removing-blocking-build-entries-for-successful-builds

            backfill-blocked-builds

            select-blocking-builds))

(define (select-blocked-derivation-output-details-set-ids-for-blocking-build
         conn
         build-server-id
         blocking-derivation-output-details-set-id)
  (define query
    "
WITH RECURSIVE all_derivations(id, file_name) AS (
  (
    SELECT derivations.id, derivations.file_name
    FROM derivations
    INNER JOIN derivations_by_output_details_set
      ON derivations.id = derivations_by_output_details_set.derivation_id
    WHERE derivation_output_details_set_id = $2
    LIMIT 1
  )
  UNION
    SELECT derivations.id, derivations.file_name
    FROM all_derivations
    INNER JOIN derivation_outputs
      ON all_derivations.id = derivation_outputs.derivation_id
    INNER JOIN derivation_inputs
      ON derivation_outputs.id = derivation_inputs.derivation_output_id
    INNER JOIN derivations
      ON derivation_inputs.derivation_id = derivations.id
)
SELECT DISTINCT builds.derivation_output_details_set_id
FROM all_derivations
INNER JOIN derivations_by_output_details_set
  ON all_derivations.id = derivations_by_output_details_set.derivation_id
INNER JOIN builds
  ON builds.build_server_id = $1
 AND builds.derivation_output_details_set_id
      = derivations_by_output_details_set.derivation_output_details_set_id
INNER JOIN latest_build_status
  ON builds.id = latest_build_status.build_id
 AND status = 'scheduled'")

  (exec-query conn
              query
              (list build-server-id
                    blocking-derivation-output-details-set-id)))

(define (select-blocking-builds-for-build-id conn build-id build-server-id)
  (define query
    "
WITH RECURSIVE all_derivations(id, file_name) AS (
    SELECT derivations.id, derivations.file_name
    FROM derivations
    WHERE id IN (
      -- Look up by the builds.derivation_output_details_set_id, since that'll
      -- work even if the derivation for the build isn't known.
      SELECT derivation_id
      FROM derivations_by_output_details_set
      INNER JOIN builds
        ON builds.derivation_output_details_set_id
           = derivations_by_output_details_set.derivation_output_details_set_id
      WHERE builds.id = $1
    )
  UNION
    SELECT derivations.id, derivations.file_name
    FROM all_derivations
    INNER JOIN derivation_inputs
      ON all_derivations.id = derivation_inputs.derivation_id
    INNER JOIN derivation_outputs
      ON derivation_inputs.derivation_output_id = derivation_outputs.id
    INNER JOIN derivations
      ON derivation_outputs.derivation_id = derivations.id
)
SELECT derivations_by_output_details_set.derivation_output_details_set_id
FROM all_derivations
INNER JOIN derivations_by_output_details_set
  ON all_derivations.id = derivations_by_output_details_set.derivation_id
INNER JOIN builds
  ON derivations_by_output_details_set.derivation_output_details_set_id =
     builds.derivation_output_details_set_id
 AND builds.build_server_id = $2
INNER JOIN latest_build_status
  ON builds.id = latest_build_status.build_id
 AND latest_build_status.status IN (
       'failed', 'canceled', 'failed-dependency',
       'failed-other'
     )
WHERE NOT EXISTS (
    SELECT 1
    FROM builds AS successful_builds
    INNER JOIN latest_build_status AS successful_builds_latest_build_status
      ON successful_builds.id = successful_builds_latest_build_status.build_id
    WHERE successful_builds.derivation_output_details_set_id =
          builds.derivation_output_details_set_id
      AND successful_builds.build_server_id = $2
      AND successful_builds_latest_build_status.status IN ('succeeded', 'scheduled')
)")

  (exec-query conn
              query
              (list (number->string build-id)
                    build-server-id)))

(define %created-partitions
  '())

(define (insert-blocked-builds conn build-server-id data)
  (unless (null? data)
    (unless (member build-server-id %created-partitions)
      (exec-query
       conn
       (string-append
        "
CREATE TABLE IF NOT EXISTS blocked_builds_build_server_"
        build-server-id "
PARTITION OF blocked_builds FOR VALUES IN ("
        build-server-id
        ")"))

      (set! %created-partitions
            (cons build-server-id
                  %created-partitions)))

    (exec-query
     conn
     (string-append
      "
INSERT INTO blocked_builds (
  build_server_id,
  blocked_derivation_output_details_set_id,
  blocking_derivation_output_details_set_id
)
VALUES "
      (string-join
       (map (match-lambda
              ((b c)
               (simple-format #f "(~A, ~A, ~A)"
                              build-server-id
                              b
                              c)))
            data)
       ", ")
      "
ON CONFLICT DO NOTHING")
     '()))

  #t)

(define (handle-blocked-builds-entries-for-scheduled-builds conn build-ids)
  (define (get-build-details build-id)
    (define query
      "
SELECT build_server_id, derivation_output_details_set_id
FROM builds
WHERE id = $1")

    (exec-query conn query (list (number->string build-id))))

  (define delete-query
    (string-append
     "
DELETE FROM blocked_builds
WHERE EXISTS (
  SELECT 1
  FROM builds
  WHERE builds.id IN (" (string-join
                         (map number->string build-ids)
                         ", ")
  ")
    AND EXISTS (
          SELECT 1
          FROM latest_build_status
          WHERE latest_build_status.build_id = builds.id
            AND latest_build_status.status = 'scheduled'
        )
    AND blocked_builds.build_server_id = builds.build_server_id
    AND blocked_builds.blocking_derivation_output_details_set_id
         = builds.derivation_output_details_set_id
)"))

  ;; Insert entries for each build if it's blocked
  (for-each
   (lambda (build-id)
     (match (get-build-details build-id)
       (((build-server-id blocked-derivation-output-details-set-id))
        (let ((blocking-derivation-output-details-set-ids
               (select-blocking-builds-for-build-id conn build-id build-server-id)))

          (unless (null? blocking-derivation-output-details-set-ids)
            (insert-blocked-builds
             conn
             build-server-id
             (map
              (lambda (blocking-derivation-output-details-set-id)
                (list blocked-derivation-output-details-set-id
                      blocking-derivation-output-details-set-id))
              blocking-derivation-output-details-set-ids)))))))
   build-ids)

  ;; This build being scheduled might unblock other builds, so delete the
  ;; associated entries
  (exec-query conn delete-query '())

  #t)

(define (handle-populating-blocked-builds-for-build-failures conn build-ids)
  (define build-build-server-id-and-derivation-output-details-set-ids-query
    (string-append
     "
SELECT builds.build_server_id, builds.derivation_output_details_set_id
FROM builds
INNER JOIN latest_build_status
  ON latest_build_status.build_id = builds.id
  -- This should only be run on builds that have failed, but double check here
 AND status IN ('failed', 'failed-dependency', 'failed-other', 'canceled')
WHERE builds.id IN ("
     (string-join (map number->string build-ids) ", ")
     ")
  AND builds.derivation_output_details_set_id IS NOT NULL
  AND NOT EXISTS (
    SELECT 1
    FROM builds AS builds_for_same_output
    INNER JOIN latest_build_status AS builds_for_same_output_latest_build_status
      ON builds_for_same_output.id
           = builds_for_same_output_latest_build_status.build_id
     AND builds_for_same_output_latest_build_status.status IN ('succeeded', 'scheduled')
    WHERE builds_for_same_output.derivation_output_details_set_id
            = builds.derivation_output_details_set_id
)"))

  (for-each
   (match-lambda
     ((build-server-id blocking-derivation-output-details-set-id)
      (let ((blocked-derivation-output-details-set-ids
             (select-blocked-derivation-output-details-set-ids-for-blocking-build
              conn
              build-server-id
              blocking-derivation-output-details-set-id)))
        (insert-blocked-builds
         conn
         build-server-id
         (map
          (lambda (blocked-derivation-output-details-set-id)
            (list blocked-derivation-output-details-set-id
                  blocking-derivation-output-details-set-id))
          blocked-derivation-output-details-set-ids)))))
   (exec-query
    conn
    build-build-server-id-and-derivation-output-details-set-ids-query
    '())))

(define (handle-removing-blocking-build-entries-for-successful-builds conn build-ids)
  (define query
    (string-append
     "
DELETE FROM blocked_builds
WHERE EXISTS (
  SELECT 1
  FROM builds
  WHERE builds.id IN (" (string-join
                         (map number->string build-ids)
                         ", ")
  ")
    AND EXISTS (
          SELECT 1
          FROM latest_build_status
          WHERE latest_build_status.build_id = builds.id
            AND latest_build_status.status = 'succeeded'
        )
    AND blocked_builds.build_server_id = builds.build_server_id
    AND blocked_builds.blocking_derivation_output_details_set_id
         = builds.derivation_output_details_set_id
)"))

  (exec-query conn query '()))

(define (backfill-blocked-builds conn)
  (define query
    "
SELECT build_id
FROM latest_build_status
INNER JOIN builds
  ON latest_build_status.build_id = builds.id
WHERE status IN ('failed', 'failed-dependency', 'failed-other', 'canceled')
  AND NOT EXISTS (
    SELECT 1
    FROM builds AS other_builds
    INNER JOIN latest_build_status AS other_latest_build_status
      ON other_builds.id = other_latest_build_status.build_id
    WHERE other_builds.derivation_output_details_set_id =
          builds.derivation_output_details_set_id
      AND other_latest_build_status.status IN ('succeeded', 'scheduled')
  )")

  (let ((build-ids
         (map car (exec-query conn query '()))))
    (chunk-for-each!
     (lambda (ids)
       (with-time-logging "processing chunk"
         (with-postgresql-transaction
          conn
          (lambda (conn)
            (exec-query
             conn
             "LOCK TABLE blocked_builds IN SHARE MODE")

            (handle-populating-blocked-builds-for-build-failures
             conn
             (map string->number ids))))))
     200
     build-ids)))

(define* (select-blocking-builds conn revision-commit
                                 #:key build-server-ids
                                 system target
                                 limit)
  (define query
    (string-append
     (or
      (get-sql-to-select-package-and-related-derivations-for-revision
       conn
       (commit->revision-id conn revision-commit)
       #:system-id (lookup-system-id conn system)
       #:target target)
      (string-append
       "
WITH RECURSIVE all_derivations AS (
  (
    SELECT derivation_id
    FROM package_derivations
    INNER JOIN guix_revision_package_derivations
      ON package_derivations.id
          = guix_revision_package_derivations.package_derivation_id
    WHERE revision_id = " (commit->revision-id conn revision-commit)
     (if system
         (simple-format
          #f "
      AND system_id = ~A\n"
          (lookup-system-id conn system))
         "")
     (if target
         (simple-format
          #f "
      AND target = ~A\n"
          (quote-string target))
         "")
     "
  )
  UNION
    SELECT derivation_outputs.derivation_id
    FROM all_derivations
    INNER JOIN derivation_inputs
      ON all_derivations.derivation_id = derivation_inputs.derivation_id
    INNER JOIN derivation_outputs
      ON derivation_inputs.derivation_output_id = derivation_outputs.id
)"))
     ", all_derivation_output_details_set_ids AS (
  SELECT derivations_by_output_details_set.*
  FROM derivations_by_output_details_set
  WHERE derivation_id IN (
    SELECT derivation_id FROM all_derivations
  )
), blocked_build_counts AS (
  SELECT blocking_derivation_output_details_set_id, COUNT(*)
  FROM blocked_builds
  WHERE blocked_derivation_output_details_set_id IN
    (
      SELECT derivation_output_details_set_id
      FROM all_derivation_output_details_set_ids
    )
  GROUP BY 1
)
SELECT derivations.file_name,
       blocked_build_counts.count,
       (
         SELECT JSON_AGG(
                  json_build_object(
                    'build_server_id', builds.build_server_id,
                    'build_server_build_id', builds.build_server_build_id,
                    'status',  latest_build_status.status,
                    'timestamp',  latest_build_status.timestamp,
                    'build_for_equivalent_derivation',
                    builds.derivation_file_name != derivations.file_name
                  )
                  ORDER BY latest_build_status.timestamp
                )
         FROM builds
         INNER JOIN latest_build_status
           ON builds.id = latest_build_status.build_id
         WHERE builds.derivation_output_details_set_id =
               blocked_build_counts.blocking_derivation_output_details_set_id"
     (if (and build-server-ids
              (not (null? build-server-ids)))
         (string-append
          "
           AND builds.build_server_id IN ("
          (string-join build-server-ids ", ")
          ")")
         "")
     "
       ) AS builds
FROM blocked_build_counts
INNER JOIN all_derivation_output_details_set_ids
  ON blocked_build_counts.blocking_derivation_output_details_set_id
     = all_derivation_output_details_set_ids.derivation_output_details_set_id
INNER JOIN derivations
  ON all_derivation_output_details_set_ids.derivation_id
     = derivations.id
ORDER BY 2 DESC"
     (if limit
         (string-append
          "
LIMIT " (number->string limit))
         "")))

  (map
   (match-lambda
     ((derivation_file_name blocked_build_count builds)
      `((derivation_file_name . ,derivation_file_name)
        (blocked_build_count  . ,blocked_build_count)
        (builds
         . ,(if (or (and (string? builds) (string-null? builds))
                    (eq? #f builds))
                #()
                (json-string->scm builds))))))
   (exec-query conn query)))