path: root/guix-qa-frontpage/branch.scm

;;; Guix QA Frontpage
;;;
;;; Copyright © 2022, 2023 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-qa-frontpage branch)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 threads)
  #:use-module (prometheus)
  #:use-module ((guix-build-coordinator utils)
                #:select (with-time-logging))
  #:use-module ((guix build syscalls)
                #:select (set-thread-name))
  #:use-module (guix-qa-frontpage mumi)
  #:use-module (guix-qa-frontpage git-repository)
  #:use-module (guix-qa-frontpage guix-data-service)
  #:use-module (guix-qa-frontpage derivation-changes)
  #:use-module (guix-qa-frontpage database)
  #:use-module (guix-qa-frontpage manage-builds)
  #:export (list-non-master-branches

            branch-data
            master-branch-data

            get-systems-with-low-substitute-availability

            start-refresh-non-patch-branches-data-thread))

(define (list-non-master-branches)
  (define (issue-title->branch title)
    (and=> (string-match ".* \"([^\"]*)\".*" title)
           (lambda (m)
             (match:substring m 1))))

  (define merge-issues-by-branch
    (filter-map
     (lambda (issue)
       (let ((branch (issue-title->branch
                      (assoc-ref issue "title")))
             (issue-number
              (assoc-ref issue "number")))
         (when (and branch (assoc-ref issue "open"))
           (cons branch
                 `(("issue_number" . ,issue-number)
                   ("issue_date" . ,(assoc-ref issue "date"))
                   ("blocked_by" . ,(assoc-ref issue "blocked_by")))))))
     (vector->list
      (mumi-search-issues
       ;; TODO: subject: doesn't seem to work for issues where the
       ;; subject/title has changed
       "\"Request for merging\" is:open"))))

  (let ((branches
         (map
          (lambda (branch)
            (let ((name (assoc-ref branch "name")))
              (cons name
                    (append
                     (or (assoc-ref merge-issues-by-branch name)
                         '())
                     (alist-delete "name" branch)))))
          (remove
           (lambda (branch)
             (or (string=? (assoc-ref branch "name")
                           "master")
                 (string-prefix? "version-"
                                 (assoc-ref branch "name"))
                 (string=? (assoc-ref branch "commit")
                           "")))
           (list-branches
            (list-branches-url 2))))))
    (let* ((initial-ordered-branches
            (stable-sort
             branches
             (lambda (a b)
               (let ((a-has-issue
                      (->bool (assoc-ref (cdr a) "issue_number")))
                     (b-has-issue
                      (->bool (assoc-ref (cdr b) "issue_number"))))
                 (if (and a-has-issue b-has-issue)
                     (let ((a-date
                            (assoc-ref (cdr a) "issue_date"))
                           (b-date
                            (assoc-ref (cdr b) "issue_date")))
                       (string<? a-date b-date))
                     a-has-issue)))))
           (initial-ordering-index-by-branch
            (map (lambda (index branch)
                   (cons (car branch) index))
                 (iota (length initial-ordered-branches))
                 initial-ordered-branches))
           (initial-ordering-index-by-issue-number
            (filter-map
             (lambda (index branch)
               (and=> (assoc-ref (cdr branch) "issue_number")
                      (lambda (issue-number)
                        (cons issue-number index))))
             (iota (length initial-ordered-branches))
             initial-ordered-branches)))

      ;; The idea with issues blocking others is to create a linked list,
      ;; however I think it's possible to have a loop in the blocking directed
      ;; graph, so try to not completely fail if this is the case.
      (stable-sort
       initial-ordered-branches
       (lambda (a b)
         (let ((a-initial-ordering-index
                (assq-ref initial-ordering-index-by-branch
                          (car a)))
               (b-initial-ordering-index
                (assq-ref initial-ordering-index-by-branch
                          (car b)))

               (a-blocked-by
                (map (lambda (issue)
                       (assoc-ref issue "number"))
                     (or (and=> (assoc-ref (cdr a) "blocked_by")
                                vector->list)
                         '())))
               (b-blocked-by
                (map (lambda (issue)
                       (assoc-ref issue "number"))
                     (or (and=> (assoc-ref (cdr b) "blocked_by")
                                vector->list)
                         '()))))
           (<
            (if (null? a-blocked-by)
                a-initial-ordering-index
                (let ((ordering-indexes
                       (filter-map
                        (lambda (blocking-issue)
                          (assq-ref initial-ordering-index-by-issue-number
                                    blocking-issue))
                        a-blocked-by)))
                  (if (null? ordering-indexes)
                      a-initial-ordering-index
                      (apply max ordering-indexes))))
            (if (null? b-blocked-by)
                b-initial-ordering-index
                (let ((ordering-indexes
                       (filter-map
                        (lambda (blocking-issue)
                          (assq-ref initial-ordering-index-by-issue-number
                                    blocking-issue))
                        b-blocked-by)))
                  (if (null? ordering-indexes)
                      b-initial-ordering-index
                      (apply max ordering-indexes)))))))))))

(define* (branch-data branch-name)
  (define branch-commit
    (get-commit
     (string-append "origin/" branch-name)))

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

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

          (up-to-date-with-master?
           (with-exception-handler guix-data-service-error->sexp
             (lambda ()
               (let* ((master-revision
                       (get-latest-processed-branch-revision "master"))
                      (changes
                       (length
                        (compare-package-derivations
                         (compare-package-derivations-url
                          `((base   . ,merge-base)
                            (target . ,master-revision))
                          ;; TODO: Maybe do something smarter here?
                          #:systems '("x86_64-linux"))))))
                 `((up-to-date? . ,(< changes 400))
                   (changes     . ,changes)
                   (master      . ,master-revision))))
             #:unwind? #t
             #:unwind-for-type &guix-data-service-error))

          (derivation-changes-data
           (with-exception-handler guix-data-service-error->sexp
             (lambda ()
               (let ((data
                      (compare-package-derivations
                       (compare-package-derivations-url
                        revisions
                        #:systems %systems-to-submit-builds-for))))

                 (with-throw-handler #t
                   (lambda ()
                     (derivation-changes
                      data
                      %systems-to-submit-builds-for))
                   (lambda _
                     (backtrace)))))
             #:unwind? #t
             #:unwind-for-type &guix-data-service-error))

          (substitute-availability
           (with-exception-handler guix-data-service-error->sexp
             (lambda ()
               (package-substitute-availability
                (package-substitute-availability-url
                 branch-commit)))
             #:unwind? #t
             #:unwind-for-type &guix-data-service-error))

          (package-reproducibility
           (guix-data-service-request
            (package-reproducibility-url branch-commit))))
     (values
      revisions
      derivation-changes-data
      substitute-availability
      package-reproducibility
      up-to-date-with-master?))

   (values #f #f #f #f #f #f)))

(define* (master-branch-data)
  (let* ((substitute-availability
          (package-substitute-availability
           "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-substitute-availability.json"))

         (package-reproducibility
          (guix-data-service-request
           "https://data.qa.guix.gnu.org/repository/2/branch/master/latest-processed-revision/package-reproducibility.json"))

         (systems-with-low-substitute-availability
          (get-systems-with-low-substitute-availability
           substitute-availability
           (lset-difference
            string=?
            %systems-to-submit-builds-for
            %systems-with-expected-low-substitute-availability))))

    (values
     substitute-availability
     systems-with-low-substitute-availability
     package-reproducibility)))

(define* (get-systems-with-low-substitute-availability substitute-availability
                                                       systems
                                                       #:key (threshold 0.8))
  (filter-map
   (lambda (system-and-target-details)
     (let ((system (assoc-ref system-and-target-details "system")))
       (if (and (member system systems)
                (string-null? (assoc-ref system-and-target-details "target")))
           (let* ((known
                   (assoc-ref system-and-target-details "known"))
                  (unknown
                   (assoc-ref system-and-target-details "unknown"))
                  (availability
                   (/ known
                      (+ known unknown))))
             (if (< availability threshold)
                 system
                 #f))
           #f)))
   (vector->list
    (assoc-ref (find
                (lambda (details)
                  ;; TODO: Don't hardcode this
                  (string=?
                   "https://bordeaux.guix.gnu.org"
                   (assoc-ref
                    (assoc-ref details "server")
                    "url")))
                (vector->list substitute-availability))
               "availability"))))

(define (start-refresh-non-patch-branches-data-thread database
                                                      metrics-registry)
  (define frequency
    (* 30 60))

  (define branch-substitutes-known
    (make-gauge-metric metrics-registry
                       "branch_substitutes_known"
                       #:labels '(server branch system target)))

  (define branch-substitutes-unknown
    (make-gauge-metric metrics-registry
                       "branch_substitutes_unknown"
                       #:labels '(server branch system target)))

  (define (update-branch-substitute-availability-metrics
           branch-name
           substitute-availability)
    (for-each
     (lambda (server-details)
       (let ((server-url
              (assoc-ref
               (assoc-ref server-details "server")
               "url")))

         (for-each
          (lambda (system-and-target-details)
            (let ((label-values
                   `((server . ,server-url)
                     (branch . ,branch-name)
                     (system
                      . ,(assoc-ref system-and-target-details
                                    "system"))
                     (target
                      . ,(assoc-ref system-and-target-details
                                    "target")))))

              (metric-set branch-substitutes-known
                          (assoc-ref system-and-target-details
                                     "known")
                          #:label-values label-values)
              (metric-set branch-substitutes-unknown
                          (assoc-ref system-and-target-details
                                     "unknown")
                          #:label-values label-values)))
          (vector->list
           (assoc-ref server-details "availability")))))
     (vector->list
      substitute-availability)))

  (define (refresh-data)
    (simple-format (current-error-port)
                   "refreshing non-patch branches data...\n")
    (update-repository!)

    (let ((branches
           (with-sqlite-cache
            database
            'branches
            (lambda ()
              (remove
               (lambda (branch)
                 (or (string=? (assoc-ref branch "name")
                               "master")
                     (string-prefix? "version-"
                                     (assoc-ref branch "name"))))
               (list-branches
                (list-branches-url 2))))
            #:ttl 0)))

      (n-par-for-each
       1
       (lambda (branch)
         (let ((branch-name
                (assoc-ref branch "name")))
           (simple-format (current-error-port)
                          "refreshing data for ~A branch\n"
                          branch-name)

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

                 #f)
             (lambda ()
               (with-throw-handler #t
                 (lambda ()
                   (let ((revisions
                          derivation-change-counts
                          substitute-availability
                          package-reproducibility
                          up-to-date-with-master?
                          (with-sqlite-cache
                           database
                           'branch-data
                           branch-data
                           #:args
                           (list branch-name)
                           #:version 3
                           #:ttl (/ frequency 2))))

                     (unless (or (not substitute-availability)
                                 (assq-ref substitute-availability 'exception))
                       (update-branch-substitute-availability-metrics
                        branch-name
                        substitute-availability))))
                 (lambda _
                   (backtrace))))
             #:unwind? #t))
         #t)
       branches))

    (let ((master-branch-substitute-availability
           master-branch-systems-with-low-substitute-availability
           master-branch-package-reproducibility
           (with-sqlite-cache
            database
            'master-branch-data
            master-branch-data
            #:ttl 0
            #:version 2)))
      (update-branch-substitute-availability-metrics
       "master"
       master-branch-substitute-availability)))

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

     (while #t
       (let ((start-time (current-time)))
         (with-exception-handler
             (lambda (exn)
               (simple-format
                (current-error-port)
                "exception in branch data refresh thread: ~A\n"
                exn))
           (lambda ()
             (with-time-logging "refreshing branch data"
               (with-throw-handler #t
                 refresh-data
                 (lambda args
                   (display (backtrace) (current-error-port))
                   (newline (current-error-port))))))
           #:unwind? #t)

         (let ((time-taken
                (- (current-time) start-time)))
           (if (>= time-taken frequency)
               (simple-format (current-error-port)
                              "warning: refreshing branch data is behind\n")
               (sleep
                (- frequency time-taken)))))))))