path: root/guix-qa-frontpage/manage-patch-branches.scm

(define-module (guix-qa-frontpage manage-patch-branches)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 textual-ports)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (json)
  #:use-module (prometheus)
  #:use-module (git)
  #:use-module (guix git)
  #:use-module (guix sets)
  #:use-module (guix memoization)
  #:use-module (guix build utils)
  #:use-module ((guix build syscalls)
                #:select (set-thread-name))
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator utils fibers)
  #:use-module ((guix build download) #:select (http-fetch))
  #:use-module ((guix build utils) #:select (with-directory-excursion))
  #:use-module (guix-qa-frontpage mumi)
  #:use-module (guix-qa-frontpage database)
  #:use-module (guix-qa-frontpage git-repository)
  #:use-module (guix-qa-frontpage patchwork)
  #:use-module (guix-qa-frontpage guix-data-service)
  #:export (create-branch-for-issue

            patchwork-series->branch

            start-manage-patch-branches-thread

            get-issue-branch-base-and-target-refs))

(define (run . args)
  (simple-format (current-error-port)
                 "running: ~A\n"
                 (string-join args " "))
  (apply invoke args))

(define (invoke/capture-output . args)
  (match (pipe)
    ((input . output)
     (let ((pid
            (spawn
             (car args)
             args
             #:output output
             #:error output)))

       (close-port output)
       (let ((output-string (get-string-all input)))
         (close-port input)

         (values
          (waitpid pid)
          output-string))))))

(define (issue-numbers-for-branches)
  (define rexp
    (make-regexp "\\/issue-([0-9]*)$"))

  (with-bare-git-repository
   (lambda ()
     (run "git" "fetch" "--prune" "patches")

     (let ((pipe (open-pipe* OPEN_READ
                             "git" "ls-remote" "--heads" "patches")))
       (let loop ((line (read-line pipe))
                  (branches '()))
         (if (eof-object? line)
             (begin
               (close-pipe pipe)
               (reverse branches))
             (loop (read-line pipe)
                   (match (regexp-exec rexp line)
                     (#f branches)
                     (issue-number-match
                      (cons (match:substring issue-number-match 1)
                            branches))))))))))

(define (get-issue-branch-base-and-target-refs issue)
  (define base-tag
    (string-append "base-for-issue-" (number->string issue)))

  (define target-branch
    (string-append "patches/issue-" (number->string issue)))

  (let ((base (get-commit base-tag))
        (target (get-commit target-branch)))

    (and base
         target
         `((base   . ,base)
           (target . ,target)))))

(define* (pwclient-check-create
          patch-id
          #:key
          (project "guix-patches")
          status
          context
          target-url
          description)

  (apply invoke
         `("pwclient"
           "check-create"
           "-p" ,project
           "-c" ,context
           "-s" ,status
           ,(simple-format #f "~A" patch-id)
           ,@(if description
                 `("-d" ,description)
                 '())
           ,@(if target-url
                 `("-u" ,target-url)
                 '()))))

(define (invoke-read-line prog . args)
  (let* ((pipe (apply open-pipe* OPEN_READ prog
                      args))
         (result
          (read-line pipe)))
    (close-pipe pipe)
    result))

(define (parse-patch-name name)
  (let ((args
         (and
          (string-prefix? "[" name)
          (let ((stop (string-index name #\])))
            (substring name 1 stop))))
        (as-bug-number
         (lambda (arg)
           (and (string-prefix? "bug#" arg)
                (string->number (substring arg (string-length "bug#"))))))
        (as-v2
         (lambda (arg)
           (and (string-prefix? "v" arg)
                (string->number (substring arg 1)))))
        (as-patch-number
         (lambda (arg)
           (match (string-split arg #\/)
             (((= string->number index) (= string->number total))
              (and index total (<= index total)
                   (cons index total)))
             (else #f)))))
    (let analyze ((bug-number #f)
                  (branch "master")
                  (version 1)
                  (index 1)
                  (total 1)
                  (arguments
                   (if args
                       (string-split args #\,)
                       '())))
      (match arguments
        ((or ("") ())
         `((bug-number . ,bug-number)
           (branch . ,branch)
           (version . ,version)
           (index . ,index)
           (total . ,total)))
        (((= as-bug-number (? number? new-bug-number))
          arguments ...)
         (analyze new-bug-number branch version index total arguments))
        (((= as-v2 (? number? new-version))
          arguments ...)
         (analyze bug-number branch new-version index total arguments))
        (((= as-patch-number ((? number? new-index) . (? number? new-total)))
          arguments ...)
         (analyze bug-number branch version new-index new-total arguments))
        ((feature-branch arguments ...)
         (analyze bug-number feature-branch version index total arguments))))))

(define (patchwork-series->branch series)
  (match (assoc-ref series "patches")
    (#() "master")
    (#(first-patch rest ...)
     (let ((details
            (parse-patch-name
             (assoc-ref first-patch "name"))))
       (assq-ref details 'branch)))))

(define (create-branch-for-issue database issue-number patchwork-series)
  (define branch-name
    (simple-format #f "issue-~A" issue-number))

  (define base-tag
    (string-append "base-for-" branch-name))

  (define (get-base-commit)
    (let ((branch
           (patchwork-series->branch patchwork-series)))
      (if (string=? branch "master")
          (get-latest-processed-branch-revision "master")

          (with-bare-git-repository
           (lambda ()
             (invoke "git" "fetch" "--prune" "origin")
             (invoke-read-line "git" "show-ref" "--hash"
                               (string-append "origin/" branch)))))))

  (define (apply-patches)
    (define (push)
      (system* "git" "push" "--delete" "patches" base-tag)
      (invoke "git" "push" "--verbose" "patches" base-tag)

      ;; Delete the branch, to provide a clearer history
      (system* "git" "push" "--progress" "patches" "--delete" branch-name)

      (invoke "git" "push" "--progress" "-u" "patches" branch-name))

    (define (clear-cache)
      (clear-sqlite-cache-entry database
                                'issue-data
                                #:args (list issue-number)
                                #:version 3)

      (clear-sqlite-cache-entry database
                                'issue-patches-overall-status
                                #:args (list issue-number)))

    (define (insert-log results)
      (define log
        (string-join
         (map
          (lambda (patch)
            (assq-ref patch 'output))
          results)
         "\n\n"))

      (insert-create-branch-for-issue-log database issue-number log))

    (system* "git" "tag" "--delete" base-tag)
    (invoke "git" "tag" base-tag)
    (let ((base-commit-hash
           (invoke-read-line "git" "show-ref" "--hash" base-tag)))

      (let loop ((patch-data
                  (vector->list
                   (assoc-ref patchwork-series "patches")))
                 (results '()))
        (if (null? patch-data)
            (begin
              (insert-log results)

              (if (string=? base-commit-hash
                            (with-repository (getcwd) repository
                              (oid->string
                               (reference-name->oid repository "HEAD"))))
                  (simple-format
                   (current-error-port)
                   "Commit hashes match, so no patches have been applied\n")
                  (begin
                    (push)
                    (clear-cache))))
            (let* ((patch (car patch-data))
                   (name (assoc-ref patch "name"))
                   (id   (assoc-ref patch "id")))

              (simple-format #t "Running git am --ignore-whitespace --empty=drop --3way \"~A.patch\" (~A)\n" id name)
              (let ((patch-file
                     (simple-format #f "~A.patch" id)))
                (call-with-output-file patch-file
                  (lambda (output)
                    (let ((port
                           size
                           (http-fetch
                            (string->uri (assoc-ref patch "mbox")))))
                      (dump-port port output))))

                (simple-format #t "applying ~A\n" patch-file)
                (let* ((code
                        output
                        (invoke/capture-output
                         "git" "am"
                         "--empty=drop"
                         ;; As seen in #66110, there's potentially
                         ;; something going wrong in Patchwork when
                         ;; handling carriage return characters that need
                         ;; to be included in the diff, but this option
                         ;; seems to work around that
                         "--ignore-whitespace"
                         "--3way" patch-file))
                       (new-results
                        `(((id . ,id)
                           (name . ,name)
                           (output . ,output))
                          ,@results)))
                  (if (zero? (status:exit-val (cdr code)))
                      (loop (cdr patch-data)
                            new-results)
                      (begin
                        (simple-format
                         #t "Failed to apply \"~A.patch\" (~A)\n" id name)
                        (insert-log new-results)
                        #f)))))))))

  (delete-create-branch-for-issue-log database issue-number)

  (if (not (assoc-ref patchwork-series "received_all"))
      (simple-format
       #t
       "issue ~A (series: ~A): all patches have not been received, skipping\n"
       issue-number
       (assoc-ref patchwork-series "id"))

      (begin
        (with-bare-git-repository
         (lambda ()
           (invoke "git" "fetch" "--prune" "origin")
           (system* "git" "worktree" "remove" "--force"
                    (simple-format #f "../issue-~A" issue-number))
           (system* "git" "branch" "-D"
                    (simple-format #f "issue-~A" issue-number))))

        (with-git-worktree
         (simple-format #f "issue-~A" issue-number)
         (get-base-commit)
         (lambda ()
           (with-exception-handler
               (lambda (exn)
                 (simple-format
                  (current-error-port)
                  "exception when creating branch for ~A: ~A\n"
                  issue-number
                  exn)

                 (simple-format
                  (current-error-port)
                  "deleting tag and branch for issue\n")
                 (system* "git" "push" "--delete" "patches"
                          (simple-format #f "base-for-issue-~A" issue-number))
                 (system* "git" "push" "--progress" "patches" "--delete"
                          (simple-format #f "issue-~A" issue-number))

                 (raise-exception exn))
             (lambda ()
               (with-throw-handler #t
                 apply-patches
                 (lambda args
                   (display (backtrace) (current-error-port))
                   (newline (current-error-port)))))
             #:unwind? #t))
         #:remove-after? #t))))

(define* (start-manage-patch-branches-thread database
                                             metrics-registry
                                             #:key series-count)
  (define (dig alist . parts)
    (if (pair? alist)
        (match parts
          ((part)
           (assoc-ref alist part))
          ((part . rest)
           (if (list? alist)
               (apply dig
                      (assoc-ref alist part)
                      (cdr parts))
               #f)))
        #f))

  (define series-count-buffer 40)

  (define (perform-pass)
    (let ((issue-numbers
           (map string->number
                (issue-numbers-for-branches)))
          (all-patchwork-series
           (with-sqlite-cache
            database
            'latest-patchwork-series-by-issue
            latest-patchwork-series-by-issue
            #:args `(#:count ,(+ series-count series-count-buffer))
            #:ttl 120))
          (latest-master-revision
           (get-latest-processed-branch-revision "master")))

      ;; Several series can use the same base revision, so memoize looking up
      ;; the changes compared to master
      (define get-changes-compared-to-master
        (memoize
         (lambda (base-commit)
           (vector-length
            (assoc-ref
             (compare-package-derivations
              (compare-package-derivations-url
               `((base   . ,base-commit)
                 (target . ,latest-master-revision))
               ;; TODO: Maybe do something smarter here?
               #:systems '("i686-linux")))
             "derivation_changes")))))

      (simple-format #t "checking for branches to delete (looking at ~A branches)\n"
                     (length issue-numbers))
      (for-each
       (lambda (issue-number)
         (when (or (if (not (mumi-issue-open? issue-number))
                       (begin (simple-format (current-error-port)
                                             "Removing ~A, issue closed\n"
                                             issue-number)
                              #t)
                       #f)
                   (if (not (assq-ref all-patchwork-series issue-number))
                       (begin
                         (simple-format
                          (current-error-port)
                          "Removing ~A, issue no longer in latest-patchwork-series-by-issue\n"
                          issue-number)
                         #t)
                       #f)
                   (if (string=? "master"
                                 (patchwork-series->branch
                                  (assq-ref all-patchwork-series issue-number)))
                       (let ((base-commit
                              (assq-ref
                               (get-issue-branch-base-and-target-refs issue-number)
                               'base)))
                         (with-exception-handler
                             (lambda (exn)
                               (if (and (guix-data-service-error? exn)
                                        (and=>
                                         (dig
                                          (guix-data-service-error-response-body exn)
                                          "query_parameters" "base_commit"
                                          "invalid")
                                         (lambda (invalid)
                                           (string=? invalid "unknown commit"))))
                                   (begin
                                     (simple-format
                                      (current-error-port)
                                      "Removing ~A, base revision (~A) gone\n"
                                      issue-number
                                      base-commit)
                                     #t)
                                   (begin
                                     (simple-format
                                      (current-error-port)
                                      "warning: exception when fetching revision details: ~A\n"
                                      exn)
                                     #f)))
                           (lambda ()
                             (let ((derivation-change-count
                                    (get-changes-compared-to-master base-commit)))
                               (if (> derivation-change-count 10000)
                                   (begin
                                     (simple-format
                                      (current-error-port)
                                      "Removing ~A, ~A derivation changes between base (~A) and latest master revision (~A)\n"
                                      issue-number
                                      derivation-change-count
                                      base-commit
                                      latest-master-revision)
                                     #t)
                                   #f)))
                           #:unwind? #t))
                       ;; Don't do the following checks on changes for
                       ;; non-master branches.
                       #f))

           (with-bare-git-repository
            (lambda ()
              (let ((tag (simple-format #f "base-for-issue-~A" issue-number)))
                (with-exception-handler
                    (lambda (exn)
                      (simple-format
                       (current-error-port)
                       "ignoring exception when deleting tag ~A\n" tag))
                  (lambda ()
                    (run "git" "push" "patches" "--delete" tag))
                  #:unwind? #t))
              (run "git" "push" "patches" "--delete"
                   (simple-format #f "issue-~A" issue-number))))))
       issue-numbers))
    (simple-format #t "finished checking for branches to delete\n")

    (let* ((issue-numbers
           (map string->number
                (issue-numbers-for-branches)))
           (all-patchwork-series
            (with-sqlite-cache
             database
             'latest-patchwork-series-by-issue
             latest-patchwork-series-by-issue
             #:args `(#:count ,series-count)
             #:ttl 120)))
      (for-each
       (match-lambda
         ((issue-number . patchwork-series)
          (when (or (not
                     (member issue-number
                             issue-numbers
                             =))

                    ;; Does the branch need re-creating with a new series?
                    (let ((branch-committer-date
                           (get-git-branch-head-committer-date
                            (simple-format #f "patches/issue-~A" issue-number)))
                          (patchwork-series-date
                           (assoc-ref patchwork-series "date")))
                      (if (and branch-committer-date
                               patchwork-series-date)
                          (let* ((branch-committer-time
                                  (date->time-utc branch-committer-date))
                                 (patchwork-series-time
                                  (date->time-utc
                                   (string->date
                                    patchwork-series-date
                                    "~Y-~m-~dT~H:~M:~S")))
                                 (recreate-branch?
                                  (time<? branch-committer-time
                                          patchwork-series-time)))
                            (simple-format
                             #t
                             "considering recreating branch for issue ~A (~A, ~A, ~A)\n"
                             issue-number
                             branch-committer-time
                             patchwork-series-time
                             recreate-branch?)
                            (time<? branch-committer-time
                                    patchwork-series-time))
                          #f)))
            (simple-format #t "creating branch for issue ~A\n" issue-number)

            (with-exception-handler
                (const #t)
              (lambda ()
                (create-branch-for-issue database
                                         issue-number
                                         patchwork-series))
              #:unwind? #t))))
       all-patchwork-series)

      (simple-format (current-error-port)
                     "finished processing patch branches (first: ~A, last: ~A)\n"
                     (car (first all-patchwork-series))
                     (car (last all-patchwork-series)))))

  (setenv "GIT_SSH_COMMAND"
          "ssh -o StrictHostKeyChecking=no")

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

     (while #t
       (with-exception-handler
           (lambda (exn)
             (simple-format
              (current-error-port)
              "exception in manage patch branches thread: ~A\n"
              exn)
             (unless (worker-thread-timeout-error? exn)
               (sleep 240)))
         (lambda ()
           (with-throw-handler #t
             (lambda ()
               (call-with-duration-metric
                metrics-registry
                "manage_patch_branches_duration_seconds"
                perform-pass
                #:buckets (list 30 60 120 240 480 960 1920 3840 (inf))))
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port))))
           (sleep 3600))
         #:unwind? #t)))))