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

(define-module (guix-qa-frontpage manage-builds)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (guix sets)
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator client-communication)
  #:use-module (guix-qa-frontpage database)
  #:use-module (guix-qa-frontpage patchwork)
  #:use-module (guix-qa-frontpage guix-data-service)
  #:use-module (guix-qa-frontpage manage-patch-branches)
  #:export (%systems-to-submit-builds-for

            builds-missing-for-derivation-changes?

            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* (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"))
        600
        400))

  (define (submit-builds)
    (simple-format #t "submitting patch builds\n")
    (let ((series (with-sqlite-cache
                   database
                   'latest-patchwork-series-by-issue
                   latest-patchwork-series-by-issue
                   #:ttl 3000)))

      (for-each
       (match-lambda
         ((issue-number . series)
          (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)
                    (patch-series-derivation-changes-url
                     base-and-target-refs
                     #:systems %systems-to-submit-builds-for)))))

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

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

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

                      (submit-builds-for-category build-coordinator
                                                  guix-data-service
                                                  'issue
                                                  issue-number
                                                  derivation-changes
                                                  target-commit
                                                  #:build-limit
                                                  (* (length %systems-to-submit-builds-for)
                                                     200)
                                                  #:priority priority-for-change))))
                (simple-format #t "no derivation changes url for issue ~A\n"
                               issue-number)))))
       (take series series-count))))

  (call-with-new-thread
   (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
             submit-builds
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port)))))
         #:unwind? #t)

       (sleep 300)))))

(define (start-submit-branch-builds-thread database
                                           build-coordinator
                                           guix-data-service)
  (define (submit-builds)
    (define (priority-for-change change)
      (if (member (assoc-ref change "system")
                  '("x86_64-linux" "aarch64-linux"))
          100
          0))

    (simple-format #t "submitting branch builds\n")
    (let ((branches '("core-updates")))
      (for-each
       (lambda (branch)
         (simple-format #t
                        "considering submitting builds for branch ~A\n"
                        branch)

         (let ((derivation-changes-url
                (branch-derivation-changes-url
                 branch
                 #:systems %systems-to-submit-builds-for)))

           (if derivation-changes-url
               (let ((derivation-changes
                      change-details
                      (with-sqlite-cache
                       database
                       'branch-derivation-changes
                       branch-derivation-changes
                       #:args
                       (list derivation-changes-url)
                       #:ttl 0)))

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

                     (submit-builds-for-category build-coordinator
                                                 guix-data-service
                                                 'branch
                                                 branch
                                                 derivation-changes
                                                 target-commit
                                                 #:priority priority-for-change))))
               (simple-format #t "no derivation changes url for branch ~A\n"
                              branch))))
       branches)))

  (call-with-new-thread
   (lambda ()
     (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
             submit-builds
             (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 (builds-after id)
    (vector->list
     (assoc-ref
      (apply request-builds-list
             build-coordinator
             (append criteria
                     `(#:limit 1000
                       #:after-id ,id)))
      "builds")))

  (let loop ((builds (builds-after #f)))
    (for-each proc builds)
    (unless (null? builds)
      (let ((next-builds
             (builds-after
              (assoc-ref (last builds) "uuid"))))
        (loop
         (if (null? next-builds)
             (builds-after #f)
             next-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))
   (append-map! (lambda (package)
                  (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)
  (define (submit-builds build-details
                         build-ids-to-keep-set)
    (for-each
     (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))))))
     build-details)

    ;; TODO Don't currently cancel builds
    ;; I think this approach has some problems and needs more thinking about.
    ;;
    ;; (cancel-builds-not-for-revision
    ;;  build-coordinator
    ;;  category-name
    ;;  category-value
    ;;  target-commit
    ;;  build-ids-to-keep-set)

    )

  (let loop ((changes
              (append-map! (lambda (package)
                             (vector->list
                              (assoc-ref package "target")))
                           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 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)))

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