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 (guix sets)
  #:use-module ((guix build syscalls)
                #:select (set-thread-name))
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator client-communication)
  #: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

            builds-missing-for-derivation-changes?

            submit-builds-for-issue

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

            start-submit-patch-builds-thread
            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* (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 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)
              (submit-builds-for-category build-coordinator
                                          guix-data-service
                                          'issue
                                          issue-number
                                          derivation-changes-data
                                          target-commit
                                          #:build-limit build-limit
                                          #:priority priority
                                          #:build-count-priority-penalty
                                          (lambda (build-count)
                                            (cond
                                             ((< build-count 10)  0)
                                             ((< build-count 100) 50)
                                             ((< build-count 300) 100)
                                             (else                150)))))))
        (simple-format #t "no derivation changes url for issue ~A\n"
                       issue-number))))

(define* (start-submit-patch-builds-thread database
                                           build-coordinator
                                           guix-data-service
                                           #:key (series-count 200))
  (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))
           (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)
           (delete-from-builds-to-cancel-later
            database
            "issue"
            issue-number))
         issues-with-builds-to-cancel))

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

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

     (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* ((master-branch-substitute-availability
                       (with-sqlite-cache
                        database
                        'master-branch-data
                        master-branch-data
                        #:ttl 6000))
                      (systems-with-low-substitute-availability
                       (get-systems-with-low-substitute-availability
                        master-branch-substitute-availability
                        (lset-difference
                         string=?
                         %systems-to-submit-builds-for
                         %systems-with-expected-low-substitute-availability))))

                 (if (null? systems-with-low-substitute-availability)
                     (submit-builds)
                     (sleep 900))))
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port)))))
         #:unwind? #t)

       (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)))

          (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
                                                  "branch"
                                                  branch)
              (submit-builds-for-category build-coordinator
                                          guix-data-service
                                          'branch
                                          branch
                                          derivation-changes-data
                                          target-commit
                                          #:priority priority
                                          #:threads 4))))
        (simple-format #t "no derivation changes url for branch ~A\n"
                       branch))))

(define (start-submit-branch-builds-thread database
                                           build-coordinator
                                           guix-data-service)
  (define (submit-builds)
    (simple-format #t "submitting branch builds\n")
    (let* ((branches
            (take (with-sqlite-cache
                   database
                   'list-non-master-branches
                   list-non-master-branches
                   #:ttl 0)
                  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)))
        (for-each
         (lambda (branch)
           (cancel-builds build-coordinator
                          "branch"
                          branch)
           (delete-from-builds-to-cancel-later
            database
            "branch"
            branch))
         branches-with-builds-to-cancel))

      (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))
       branch-names)))

  (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 ()
               (let* ((master-branch-substitute-availability
                       (with-sqlite-cache
                        database
                        'master-branch-data
                        master-branch-data
                        #:ttl 6000))
                      (systems-with-low-substitute-availability
                       (get-systems-with-low-substitute-availability
                        master-branch-substitute-availability
                        (lset-difference
                         string=?
                         %systems-to-submit-builds-for
                         %systems-with-expected-low-substitute-availability))))

                 (if (null? systems-with-low-substitute-availability)
                     (submit-builds)
                     (simple-format
                      (current-error-port)
                      "waiting for master branch substitutes before submitting branch builds\n"))))
             (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
            (send-submit-build-request
             build-coordinator
             derivation
             (list guix-data-service)
             #f
             priority
             #t
             #t
             #t
             tags)))
       (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 (for-each-build build-coordinator proc . criteria)
  (define (process-batch)
    (stream-fold
     (lambda (build result)
       (proc build)
       (1+ result))
     0
     (apply request-builds-list
            build-coordinator
            criteria)))

  (let loop ((batch-size (process-batch)))
    (unless (= 0 batch-size)
      (loop (process-batch)))))

(define (cancel-builds build-coordinator
                       category-name
                       category-value)
  (simple-format (current-error-port)
                 "canceling builds for ~A ~A\n"
                 category-name
                 category-value)
  (for-each-build
   build-coordinator
   (lambda (build-details)
     (retry-on-error
      (lambda ()
        (send-cancel-build-request build-coordinator
                                   (assoc-ref build-details "uuid")))
      #:times 6
      #:delay 15)
     (simple-format (current-error-port)
                    "canceled ~A\n"
                    (assoc-ref build-details "uuid")))
   #:tags
   `(((key . category)
      (value . package))
     ((key . ,category-name)
      (value . ,category-value)))
   #:canceled #f
   #:processed #f
   #:relationship 'no-dependent-builds))

(define (cancel-builds-not-for-revision build-coordinator
                                        category-name
                                        category-value
                                        revision
                                        build-ids-to-keep-set)
  (simple-format (current-error-port)
                 "canceling builds for ~A ~A and not revision ~A\n"
                 category-name
                 category-value
                 revision)
  (for-each-build
   build-coordinator
   (lambda (build-details)
     (unless (set-contains?
              build-ids-to-keep-set
              (assoc-ref build-details "uuid"))
       (retry-on-error
        (lambda ()
          (send-cancel-build-request build-coordinator
                                     (assoc-ref build-details "uuid")))
        #:times 6
        #:delay 15)
       (simple-format (current-error-port)
                      "canceled ~A\n"
                      (assoc-ref build-details "uuid"))))
   #: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))

(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))
         (if (= (vector-length
                 (assoc-ref change "builds"))
                0)
             #t
             #f)
         #f))
   (vector-fold
    (lambda (_ result package)
      (append! result
               (vector->list
                (assoc-ref package "target"))))
    '()
    derivation-changes)))


(define* (submit-builds-for-category build-coordinator
                                     guix-data-service
                                     category-name
                                     category-value
                                     derivation-changes
                                     target-commit
                                     #:key build-limit
                                     priority
                                     (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 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)
        (let ((builds-to-submit-count
               (length builds-to-submit-details)))
          (simple-format #t "~A target derivations for ~A ~A\n"
                         builds-to-submit-count
                         category-name
                         category-value)

          (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)
                                   builds-to-submit-details
                                   (map
                                    (match-lambda
                                      ((derivation priority)
                                       (list derivation
                                             (- priority priority-penalty))))
                                    builds-to-submit-details)))
                             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))

          (cancel-builds-not-for-revision
           build-coordinator
           category-name
           category-value
           target-commit
           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-length
                            (assoc-ref change "builds"))
                           0)
                        (cons
                         (list (assoc-ref change "derivation-file-name")
                               (if (number? priority)
                                   priority
                                   (priority change)))
                         builds-to-submit-details)
                        builds-to-submit-details) ; build exists
                    (fold (lambda (build result)
                            (if (member (assoc-ref build "status")
                                        '("scheduled" "started"))
                                (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 %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)
  (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-length builds) 0))
                     (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
             submit-builds
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port)))))
         #:unwind? #t)

       (sleep 3600)))))