;;; 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 (fibers)
  #:use-module (guix-qa-frontpage utils)
  #: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-fiber))

(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"
                    . ,(map (lambda (issue)
                              (assoc-ref issue "number"))
                            (or (and=> (assoc-ref issue "blocked_by")
                                       vector->list)
                                '()))))))))
     (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"))))

  (with-exception-handler
      (lambda (exn)
        (simple-format #t "exception listing non master branches: ~A\n" exn)
        `((exception . ,(simple-format #f "~A" exn))))
    (lambda ()
      (with-throw-handler #t
        (lambda ()
          (let* ((merge-issues
                  (merge-issues-by-branch))
                 (branches
                  (map
                   (lambda (branch)
                     (let ((name (assoc-ref branch "name")))
                       (cons name
                             (append
                              (or (assoc-ref merge-issues 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
                        (or (assoc-ref (cdr a) "blocked_by") '()))
                       (b-blocked-by
                        (or (assoc-ref (cdr b) "blocked_by") '())))
                   (<
                    (if (null? a-blocked-by)
                        a-initial-ordering-index
                        (let ((ordering-indexes
                               (filter-map
                                (lambda (blocking-issue)
                                  (and=>
                                   (assq-ref
                                    initial-ordering-index-by-issue-number
                                    blocking-issue)
                                   1+))
                                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)
                                  (and=>
                                   (assq-ref
                                    initial-ordering-index-by-issue-number
                                    blocking-issue)
                                   1+))
                                b-blocked-by)))
                          (if (null? ordering-indexes)
                              b-initial-ordering-index
                              (apply max ordering-indexes)))))))))))
        (lambda args
          (display (backtrace) (current-error-port))
          (newline (current-error-port)))))
    #:unwind? #t))

(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-fiber 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")
    (non-blocking
     (lambda ()
       (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)))

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

  (spawn-fiber
   (lambda ()
     (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)))))))))