path: root/guix-qa-frontpage/manage-builds.scm

(define-module (guix-qa-frontpage manage-builds)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 streams)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 exceptions)
  #:use-module (fibers)
  #:use-module (prometheus)
  #:use-module (guix sets)
  #:use-module ((guix build syscalls)
                #:select (set-thread-name))
  #:use-module ((guix-build-coordinator utils fibers)
                #:select (retry-on-error))
  #:use-module (guix-build-coordinator client-communication)
  #:use-module (guix-qa-frontpage utils)
  #:use-module (guix-qa-frontpage database)
  #:use-module (guix-qa-frontpage branch)
  #:use-module (guix-qa-frontpage patchwork)
  #:use-module (guix-qa-frontpage git-repository)
  #:use-module (guix-qa-frontpage guix-data-service)
  #:use-module (guix-qa-frontpage manage-patch-branches)
  #:export (%systems-to-submit-builds-for
            %systems-with-expected-low-substitute-availability
            %patches-builds-limit

            builds-missing-for-derivation-changes?
            derivation-changes->builds-to-keep-and-submit

            submit-builds-for-issue

            default-branch-priority-for-change
            submit-builds-for-branch

            start-submit-patch-builds-fiber
            start-submit-branch-builds-thread
            start-submit-master-branch-system-tests-thread))

(define %systems-to-submit-builds-for
  '("x86_64-linux"
    "i686-linux"
    "aarch64-linux"
    "armhf-linux"
    "powerpc64le-linux"
    "i586-gnu"))

(define %systems-with-expected-low-substitute-availability
  '("i586-gnu"
    "riscv64-linux"
    "powerpc64le-linux"))

(define %patches-builds-limit
  (* (length %systems-to-submit-builds-for)
     600))

(define* (submit-builds-for-issue
          database
          build-coordinator
          guix-data-service
          issue-number
          #:key priority
          build-limit)
  (simple-format
   #t
   "considering submitting builds for issue ~A\n"
   issue-number)

  (let ((derivation-changes-url
         (and=>
          (get-issue-branch-base-and-target-refs
           (string->number issue-number))
          (lambda (base-and-target-refs)
            (compare-package-derivations-url
             base-and-target-refs
             #:systems %systems-to-submit-builds-for)))))

    (if derivation-changes-url
        (let ((derivation-changes-data
               (with-exception-handler
                   (lambda (exn)
                     (simple-format
                      (current-error-port)
                      "failed fetching derivation changes for issue ~A: ~A\n"
                      issue-number
                      exn)

                     #f)
                 (lambda ()
                   (with-sqlite-cache
                    database
                    'derivation-changes
                    compare-package-derivations
                    #:args
                    (list derivation-changes-url)
                    #:ttl (* 60 20)))
                 #:unwind? #t)))

          (when derivation-changes-data
            (let ((target-commit
                   (assoc-ref
                    (assoc-ref
                     (assoc-ref derivation-changes-data
                                "revisions")
                     "target")
                    "commit")))

              (insert-into-builds-to-cancel-later database
                                                  "issue"
                                                  issue-number)
              (let ((derivations-and-priorities
                     build-ids-to-keep-set
                     (derivation-changes->builds-to-keep-and-submit
                      derivation-changes-data
                      priority)))
                (submit-builds-for-category build-coordinator
                                            guix-data-service
                                            'issue
                                            issue-number
                                            derivations-and-priorities
                                            build-ids-to-keep-set
                                            target-commit
                                            #:build-limit build-limit
                                            #:build-count-priority-penalty
                                            (lambda (build-count)
                                              (cond
                                               ((< build-count 10)  0)
                                               ((< build-count 100) 50)
                                               ((< build-count 300) 100)
                                               ((< build-count 1000) 150)
                                               ((< build-count 2000) 200)
                                               (else                250)))))
              (simple-format
               #t
               "finished submitting builds for issue ~A\n"
               issue-number))))
        (simple-format #t "no derivation changes url for issue ~A\n"
                       issue-number))))

(define* (start-submit-patch-builds-fiber database
                                          build-coordinator
                                          guix-data-service
                                          metrics-registry
                                          #:key series-count)
  (define (priority-for-change change)
    (if (member (assoc-ref change "system")
                '("x86_64-linux" "aarch64-linux"))
        550
        350))

  (define (submit-builds)
    (let* ((all-series
            (with-sqlite-cache
             database
             'latest-patchwork-series-by-issue
             latest-patchwork-series-by-issue
             #:ttl 3000
             #:args `(#:count ,series-count)))
           (first-n-series
            (take all-series series-count))
           (first-n-series-issue-numbers
            (map
             number->string
             (map car first-n-series))))

      (let* ((issues-with-builds-previously-submitted
              (select-from-builds-to-cancel-later
               database
               "issue"))
             (issues-with-builds-to-cancel
              (lset-difference
               string=?
               issues-with-builds-previously-submitted
               first-n-series-issue-numbers)))
        (for-each
         (lambda (issue-number)
           (cancel-builds build-coordinator
                          "issue"
                          issue-number
                          #:relationship 'unset)
           (delete-from-builds-to-cancel-later
            database
            "issue"
            issue-number))
         issues-with-builds-to-cancel))

      (simple-format #t "submitting patch builds\n")
      (for-each
       (lambda (issue-number)
         (submit-builds-for-issue
          database
          build-coordinator
          guix-data-service
          issue-number
          #:priority priority-for-change
          #:build-limit %patches-builds-limit))
       first-n-series-issue-numbers)))

  (spawn-fiber
   (lambda ()
     (while #t
       (with-exception-handler
           (lambda (exn)
             (simple-format
              (current-error-port)
              "exception in submit patch builds thread: ~A\n"
              exn))
         (lambda ()
           (with-throw-handler #t
             (lambda ()
               (let* ((substitute-availability
                       systems-with-low-substitute-availability
                       package-reproducibility
                       (with-sqlite-cache
                        database
                        'master-branch-data
                        master-branch-data
                        #:ttl 6000
                        #:version 2)))

                 (if (null? systems-with-low-substitute-availability)
                     (call-with-duration-metric
                      metrics-registry
                      "submit_patch_builds_duration_seconds"
                      submit-builds
                      #:buckets (list 30 60 120 240 480 960 1920 3840 (inf)))
                     (sleep 900))))
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port)))))
         #:unwind? #t)
       (simple-format #t "finished submitting patch builds\n")

       (sleep 300)))))

(define* (submit-builds-for-branch database
                                   build-coordinator
                                   guix-data-service
                                   branch
                                   #:key build-limit
                                   (priority (const 0))
                                   (systems %systems-to-submit-builds-for))
  (simple-format #t
                 "considering submitting builds for branch ~A\n"
                 branch)

  (let* ((branch-commit
          (get-commit
           (string-append "origin/" branch)))
         (merge-base
          (get-git-merge-base
           (get-commit "origin/master")
           branch-commit))

         (revisions
          `((base   . ,merge-base)
            (target . ,branch-commit)))

         (derivation-changes-url
          (compare-package-derivations-url
           revisions
           #:systems %systems-to-submit-builds-for)))

    (if derivation-changes-url
        (let ((derivation-changes-data
               (with-exception-handler
                   (lambda (exn)
                     (simple-format
                      (current-error-port)
                      "failed fetching derivation changes for branch ~A: ~A\n"
                      branch
                      exn)

                     #f)
                 (lambda ()
                   (with-sqlite-cache
                    database
                    'branch-derivation-changes
                    compare-package-derivations
                    #:args
                    (list derivation-changes-url)
                    #:ttl 0))
                 #:unwind? #t)))

          (if derivation-changes-data
              (let ((target-commit
                     (assoc-ref
                      (assoc-ref
                       (assoc-ref derivation-changes-data
                                  "revisions")
                       "target")
                      "commit")))

                (insert-into-builds-to-cancel-later database
                                                    "branch"
                                                    branch)
                (let ((derivations-and-priorities
                       build-ids-to-keep-set
                       (derivation-changes->builds-to-keep-and-submit
                        derivation-changes-data
                        priority)))
                  (submit-builds-for-category build-coordinator
                                              guix-data-service
                                              'branch
                                              branch
                                              derivations-and-priorities
                                              build-ids-to-keep-set
                                              target-commit
                                              #:threads 4)))
              (begin
                (simple-format
                 (current-error-port)
                 "attempting to submit builds for all derivations for branch ~A\n"
                 branch)

                (let ((derivations-and-priorities
                       (fold
                        (lambda (system result)
                          (vector-fold-right
                           (lambda (_ result derivation)
                             (cons
                              (list
                               (assoc-ref derivation "derivation")
                               (if (number? priority)
                                   priority
                                   (priority derivation)))
                              result))
                           result
                           (assoc-ref
                            (guix-data-service-request
                             (package-derivations-url
                              branch-commit
                              #:system system
                              #:target ""
                              #:no-build-from-build-server "2"))
                            "derivations")))
                        '()
                        %systems-to-submit-builds-for)))
                  (submit-builds-for-category build-coordinator
                                              guix-data-service
                                              'branch
                                              branch
                                              derivations-and-priorities
                                              (set)
                                              branch-commit
                                              #:threads 4)))))
        (simple-format #t "no derivation changes url for branch ~A\n"
                       branch))))

(define (take* lst n)
  (if (< (length lst) n)
      lst
      (take lst n)))

(define (start-submit-branch-builds-thread database
                                           build-coordinator
                                           guix-data-service
                                           metrics-registry)
  (define (cancel-branch-builds branches)
    (for-each
     (lambda (branch)
       (cancel-builds build-coordinator
                      "branch"
                      branch
                      #:relationship 'unset)
       (delete-from-builds-to-cancel-later
        database
        "branch"
        branch))
     branches))

  (define (submit-builds branches)
    (simple-format #t "submitting branch builds\n")

    (for-each
     (lambda (index branch)
       (submit-builds-for-branch
        database
        build-coordinator
        guix-data-service
        branch
        #:priority
        (lambda (change)
          (- (if (member (assoc-ref change "system")
                         '("x86_64-linux" "aarch64-linux"))
                 400
                 350)
             (* index 100)))))
     (iota (length branches))
     branches))

  (define (submit-branch-builds)
    (let ((all-branches
           (with-sqlite-cache
            database
            'list-non-master-branches
            list-non-master-branches
            #:ttl 0)))
      (if (assq-ref all-branches 'exception)
          (simple-format
           (current-error-port)
           "unable to submit branch builds, exception in list-non-master-branches: ~A\n"
           (assq-ref all-branches 'exception))

          (let* ((branches
                  (take*
                   (filter
                    (match-lambda
                      ((name . details)
                       (->bool (assoc-ref details "issue_number"))))
                    all-branches)
                   2))
                 (branch-names
                  (map car branches)))

            (let* ((branches-with-builds-previously-submitted
                    (select-from-builds-to-cancel-later
                     database
                     "branch"))
                   (branches-with-builds-to-cancel
                    (lset-difference
                     string=?
                     branches-with-builds-previously-submitted
                     branch-names)))
              (unless (null? branches-with-builds-to-cancel)
                (cancel-branch-builds branches-with-builds-to-cancel)))

            (let* ((substitute-availability
                    systems-with-low-substitute-availability
                    package-reproducibility
                    (with-sqlite-cache
                     database
                     'master-branch-data
                     master-branch-data
                     #:ttl 6000
                     #:version 2)))
              (if (null? systems-with-low-substitute-availability)
                  (submit-builds branch-names)
                  (simple-format
                   (current-error-port)
                   "waiting for master branch substitutes before submitting branch builds\n")))))))

  (call-with-new-thread
   (lambda ()
     (catch 'system-error
       (lambda ()
         (set-thread-name "branch builds"))
       (const #t))

     (while #t
       (with-exception-handler
           (lambda (exn)
             (simple-format
              (current-error-port)
              "exception in submit branch builds thread: ~A\n"
              exn))
         (lambda ()
           (with-throw-handler #t
             (lambda ()
               (call-with-duration-metric
                metrics-registry
                "submit_branch_builds_duration_seconds"
                submit-branch-builds
                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port)))))
         #:unwind? #t)

       (sleep 3600)))))

(define* (submit-build build-coordinator guix-data-service derivation
                       #:key (priority 0) (tags '()))
  (retry-on-error
   (lambda ()
     (let ((response
            (with-fibers-port-timeouts
             (lambda ()
               (send-submit-build-request
                build-coordinator
                derivation
                (list guix-data-service)
                #f
                priority
                #t
                #t
                #t
                tags))
             #:timeout 60)))
       (let ((no-build-submitted-response
              (assoc-ref response "no-build-submitted")))
         (if no-build-submitted-response
             (simple-format #t "skipped: ~A\n"
                            no-build-submitted-response)
             (simple-format #t "build submitted as ~A\n"
                            (assoc-ref response "build-submitted"))))))
   ;; The TTL Guix uses for transient failures fetching substitutes is 10
   ;; minutes, so we need to retry for longer than that
   #:times 30
   #:delay 30))

(define* (cancel-builds build-coordinator
                        category-name
                        category-value
                        #:key (relationship 'no-dependent-builds))
  (define (fetch-build-uuids)
    (fold-builds
     build-coordinator
     (lambda (build-details result)
       (cons (assoc-ref build-details "uuid") result))
     '()
     #:tags
     `(((key . category)
        (value . package))
       ((key . ,category-name)
        (value . ,category-value)))
     #:canceled #f
     #:processed #f
     #:relationship relationship))

  (simple-format (current-error-port)
                 "canceling builds for ~A ~A\n"
                 category-name
                 category-value)
  (with-fibers-port-timeouts
   (lambda ()
     (let loop ((uuids-batch (fetch-build-uuids)))
       (for-each
        (lambda (uuid)
          (retry-on-error
           (lambda ()
             (send-cancel-build-request build-coordinator
                                        uuid
                                        #:skip-updating-derived-priorities? #t
                                        #:ignore-if-build-required-by-another?
                                        (if (eq? relationship 'unset)
                                            #f
                                            #t)))
           #:times 6
           #:delay 15
           #:ignore (lambda (exn)
                      ;; TODO Improve the coordinator exceptions
                      (and (exception-with-message? exn)
                           (string=?
                            (assoc-ref (exception-message exn) "error")
                            "build-already-processed"))))
          (simple-format (current-error-port)
                         "canceled ~A\n" uuid))
        uuids-batch)

       (unless (null? uuids-batch)
         (loop (fetch-build-uuids)))))
   #:timeout 60)
  (simple-format (current-error-port)
                 "finshed canceling builds for ~A ~A\n"
                 category-name
                 category-value))

(define (cancel-builds-not-for-revision build-coordinator
                                        category-name
                                        category-value
                                        revision
                                        build-ids-to-keep-set)
  (define (fetch-build-uuids)
    (fold-builds
     build-coordinator
     (lambda (build-details result)
       (cons (assoc-ref build-details "uuid") result))
     '()
     #:tags
     `(((key . category)
        (value . package))
       ((key . ,category-name)
        (value . ,category-value)))
     #:not-tags
     `(((key . revision)
        (value . ,revision)))
     #:canceled #f
     #:processed #f
     #:relationship 'no-dependent-builds))

  (simple-format (current-error-port)
                 "canceling builds for ~A ~A and not revision ~A\n"
                 category-name
                 category-value
                 revision)
  (with-fibers-port-timeouts
   (lambda ()
     (let loop ((uuids-batch (fetch-build-uuids)))
       (let ((builds-to-cancel
              (remove!
               (lambda (uuid)
                 (set-contains? build-ids-to-keep-set uuid))
               uuids-batch)))

         (for-each
          (lambda (uuid)
            (retry-on-error
             (lambda ()
               (send-cancel-build-request build-coordinator
                                          uuid
                                          #:skip-updating-derived-priorities? #t))
             #:times 6
             #:delay 15
             #:ignore (lambda (exn)
                        ;; TODO Improve the coordinator exceptions
                        (and (exception-with-message? exn)
                             (string=?
                              (assoc-ref (exception-message exn) "error")
                              "build-already-processed"))))
            (simple-format (current-error-port)
                           "canceled ~A\n" uuid))
          builds-to-cancel)

         (unless (null? builds-to-cancel)
           (loop (fetch-build-uuids))))))
   #:timeout 60)
  (simple-format (current-error-port)
                 "finished canceling builds for ~A ~A and not revision ~A\n"
                 category-name
                 category-value
                 revision))

(define (builds-missing-for-derivation-changes? derivation-changes)
  (any
   (lambda (change)
     (if (and (string=? (assoc-ref change "target")
                        "")
              (member (assoc-ref change "system")
                      %systems-to-submit-builds-for))
         (not
          (vector-any
           (lambda (build)
             (member (assoc-ref build "status")
                     '("scheduled" "started" "succeeded" "failed")))
           (assoc-ref change "builds")))
         #f))
   (vector-fold
    (lambda (_ result package)
      (append! result
               (vector->list
                (assoc-ref package "target"))))
    '()
    derivation-changes)))

(define (derivation-changes->builds-to-keep-and-submit derivation-changes
                                                       priority)
  (let loop ((changes
              (vector-fold
               (lambda (_ result package)
                 (append! result
                          (vector->list
                           (assoc-ref package "target"))))
               '()
               (assoc-ref derivation-changes "derivation_changes")))
             (builds-to-submit-details '())
             (build-ids-to-keep-set (set)))

    (if (null? changes)
        (values builds-to-submit-details
                build-ids-to-keep-set)
        (let ((change (first changes)))
          (if (and (string=? (assoc-ref change "target")
                             "")
                   (member (assoc-ref change "system")
                           %systems-to-submit-builds-for))
              (loop (cdr changes)
                    (if (vector-any
                         (lambda (build)
                           (let ((build-status
                                  (assoc-ref build "status")))
                             (if (string=? build-status "scheduled")
                                 (not (assoc-ref
                                       build
                                       "build_for_equivalent_derivation"))
                                 (member build-status
                                         '("started" "succeeded" "failed")))))
                         (assoc-ref change "builds"))
                        builds-to-submit-details ; build exists
                        (cons
                         (list (assoc-ref change "derivation-file-name")
                               (if (number? priority)
                                   priority
                                   (priority change)))
                         builds-to-submit-details))
                    (fold (lambda (build result)
                            (let ((build-status
                                   (assoc-ref build "status")))
                              (if (or (string=? build-status "started")
                                      (and (string=? build-status "scheduled")
                                           ;; Cancel and replace builds for
                                           ;; equivalent derivations, since
                                           ;; the derivation might be removed
                                           ;; from the data service preventing
                                           ;; the build from starting.
                                           (not
                                            (assoc-ref
                                             build
                                             "build_for_equivalent_derivation"))))
                                  (set-insert
                                   (assoc-ref build "build_server_build_id")
                                   result)
                                  result)))
                          build-ids-to-keep-set
                          (vector->list
                           (assoc-ref change "builds"))))

              (loop (cdr changes)
                    builds-to-submit-details
                    build-ids-to-keep-set))))))

(define* (submit-builds-for-category build-coordinator
                                     guix-data-service
                                     category-name
                                     category-value
                                     derivations-and-priorities
                                     build-ids-to-keep-set
                                     target-commit
                                     #:key build-limit
                                     (build-count-priority-penalty (const 0))
                                     (threads 1))
  (define (submit-builds build-details
                         build-ids-to-keep-set)
    (define submit-single
      (match-lambda
        ((derivation priority)
         (submit-build build-coordinator
                       guix-data-service
                       derivation
                       #:priority priority
                       #:tags
                       `(((key . category)
                          (value . package))
                         ((key . ,category-name)
                          (value . ,category-value))
                         ((key . revision)
                          (value . ,target-commit)))))))

    (if (= threads 1)
        (for-each
         submit-single
         build-details)
        (n-par-for-each
         threads
         submit-single
         build-details)))

  (let ((builds-to-submit-count
         (length derivations-and-priorities)))
    (simple-format #t "~A target derivations for ~A ~A\n"
                   builds-to-submit-count
                   category-name
                   category-value)

    ;; Cancel builds first, as some of the builds we want to submit might be
    ;; for the same outputs as ones we're going to cancel.
    (cancel-builds-not-for-revision
     build-coordinator
     category-name
     category-value
     target-commit
     build-ids-to-keep-set)

    (if (or (not build-limit)
            (< builds-to-submit-count
               build-limit))
        (submit-builds (let ((priority-penalty
                              (build-count-priority-penalty
                               builds-to-submit-count)))
                         (if (= 0 priority-penalty)
                             derivations-and-priorities
                             (map
                              (match-lambda
                                ((derivation priority)
                                 (list derivation
                                       (- priority priority-penalty))))
                              derivations-and-priorities)))
                       build-ids-to-keep-set)
        (simple-format #t "skipping ~A ~A as too many target derivations (~A)\n"
                       category-name
                       category-value
                       builds-to-submit-count))))

(define %system-tests-that-change-every-revision
  '("btrfs-raid10-root-os"
    "btrfs-raid10-root-os-degraded"
    "btrfs-raid-root-os"
    "btrfs-root-on-subvolume-os"
    "btrfs-root-os"
    "docker-system"
    "encrypted-home-os"
    "encrypted-root-not-boot-os"
    "encrypted-root-os"
    "f2fs-root-os"
    "gui-installed-desktop-os-encrypted"
    "gui-installed-os"
    "gui-installed-os-encrypted"
    "gui-uefi-installed-os"
    "installed-extlinux-os"
    "installed-os"
    "iso-image-installer"
    "jfs-root-os"
    "lvm-separate-home-os"
    "raid-root-os"
    "separate-home-os"
    "separate-store-os"
    "xfs-root-os"))

(define (start-submit-master-branch-system-tests-thread database
                                                        build-coordinator
                                                        guix-data-service
                                                        metrics-registry)
  (define %systems
    '())

  (define (submit-builds)
    (simple-format #t "submitting system test builds\n")
    (let* ((processed-revision-commits
            (filter-map
             (lambda (revision-details)
               (if (assoc-ref revision-details "data_available")
                   (assoc-ref revision-details "commit-hash")
                   #f))
             (branch-revisions
              (branch-revisions-url 2 "master"))))
           (recent-processed-revision-commits
            (if (> (length processed-revision-commits)
                   5)
                (take processed-revision-commits 5)
                5)))

      (for-each
       (lambda (commit)
         (for-each
          (lambda (system)
            (let* ((system-tests
                    (revision-system-tests
                     (revision-system-tests-url
                      commit #:system system))))
              (for-each
               (lambda (system-test-details)
                 (let ((name
                        (assoc-ref system-test-details "name"))
                       (builds
                        (assoc-ref system-test-details "builds")))

                   (when (and (not
                               (member name
                                       %system-tests-that-change-every-revision))
                              (vector-any
                               (lambda (build)
                                 (member (assoc-ref build "status")
                                         '("scheduled" "started" "succeeded" "failed")))
                               builds))
                     (submit-build build-coordinator
                                   guix-data-service
                                   (assoc-ref system-test-details "derivation")
                                   #:tags
                                   `(((key . category)
                                      (value . system-test))
                                     ((key . branch)
                                      (value . master))
                                     ((key . revision)
                                      (value . ,commit)))))))
               system-tests)))
          %systems))
       recent-processed-revision-commits)))

  (call-with-new-thread
   (lambda ()
     (catch 'system-error
       (lambda ()
         (set-thread-name "system test builds"))
       (const #t))

     (while #t
       (with-exception-handler
           (lambda (exn)
             (simple-format
              (current-error-port)
              "exception in submit system test builds thread: ~A\n"
              exn))
         (lambda ()
           (with-throw-handler #t
             (lambda ()
               (call-with-duration-metric
                metrics-registry
                "submit_master_branch_system_tests_duration_seconds"
                submit-builds
                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port)))))
         #:unwind? #t)

       (sleep 3600)))))