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 (web uri)
  #:use-module (web client)
  #:use-module (json)
  #:use-module (guix sets)
  #:use-module (guix build utils)
  #:use-module (guix-build-coordinator utils)
  #: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 (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 (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 (create-branch-for-issue issue-number patchwork-series)
  (define (apply-patches)
    (let ((series-data
           (call-with-values
               (lambda ()
                 (http-get (string->uri
                            (string-append
                             (%patchwork-instance) "/api/1.0"
                             "/series/" patchwork-series "/"))
                           #:streaming? #t))
             (lambda (response body)
               (json->scm body)))))

      (if (assoc-ref series-data "received_all")
          (let* ((patch-data
                  (vector->list
                   (assoc-ref series-data "patches")))
                 (branch-name
                  (simple-format #f "issue-~A" issue-number))
                 (base-tag
                  (string-append "base-for-" branch-name)))

            (simple-format #t "all patches have been received\n")

            (system* "git" "tag" "--delete" base-tag)
            (invoke "git" "tag" base-tag)

            (let ((patch-ids
                   (map
                    (lambda (patch)
                      (let ((name (assoc-ref patch "name"))
                            (id   (assoc-ref patch "id")))

                        (simple-format
                         #t "Running git am \"~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))))

                          (with-exception-handler
                              (lambda (exn)
                                (simple-format #t "exception when applying patch ~A: ~A\n"
                                               patch-file exn)
                                (raise-exception exn))
                            (lambda ()
                              (simple-format #t "applying ~A\n" patch-file)
                              (invoke "git" "am" "--empty=drop" "--3way" patch-file))
                            #:unwind? #t))
                        id))
                    patch-data)))

              (let ((base-commit-hash
                     (invoke-read-line "git" "show-ref" "--hash" base-tag))
                    (target-commit-hash
                     (invoke-read-line "git" "rev-parse" "HEAD")))

                (if (string=? base-commit-hash
                              target-commit-hash)
                    (simple-format
                     (current-error-port)
                     "Commit hashes match, so no patches have been applied\n")

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

          (begin
            (simple-format #t "all patches have not been received, skipping\n")))))

  (let ((latest-master-commit
         (get-latest-processed-branch-revision "master")))

    (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)
     latest-master-commit
     (lambda ()
       (with-exception-handler
           (lambda (exn)
             (simple-format
              (current-error-port)
              "exception when applying patch: ~A\n"
              exn))
         apply-patches
         #:unwind? #t))
     #:remove-after? #t)))

(define* (start-manage-patch-branches-thread database
                                             #:key (series-count 200))
  (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 (perform-pass)
    (let ((issue-numbers
           (map string->number
                (issue-numbers-for-branches))))
      (with-bare-git-repository
       (lambda ()
         (simple-format #t "checking for branches to delete\n")
         (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)
                      (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)
                                   (= (guix-data-service-error-response-code exn)
                                      404))
                                  (begin
                                    (simple-format
                                     (current-error-port)
                                     "Removing ~A, base revision (~A) gone\n"
                                     issue-number
                                     base-commit)
                                    #t)
                                  #f))
                          (lambda ()
                            (revision-details
                             (revision-details-url base-commit))
                            #f)
                          #:unwind? #t)))

              (run "git" "push" "patches" "--delete"
                   (simple-format #f "base-for-issue-~A" issue-number))
              (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* ((all-patchwork-series
            (latest-patchwork-series-by-issue))
           (issue-numbers
            (map string->number
                 (issue-numbers-for-branches)))
           (series-to-create-branches-for
            (let ((recent-series
                   (take all-patchwork-series
                         series-count)))
              (append
               recent-series
               (filter-map
                (lambda (issue-number)
                  (if (assq-ref recent-series issue-number)
                      #f
                      (cons issue-number
                            (assq-ref all-patchwork-series
                                      issue-number))))
                issue-numbers)))))
      (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
                (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)))
              (lambda ()
                (with-throw-handler #t
                  (lambda ()
                    (create-branch-for-issue issue-number
                                             (number->string
                                              (assoc-ref patchwork-series
                                                         "id")))
                    (clear-sqlite-cache-entry
                     database
                     'issue-branch-base-and-target-refs
                     #:args (list issue-number))

                    (clear-sqlite-cache-entry
                     database
                     'issue-patches-overall-status
                     #:args (list issue-number)))
                  (lambda args
                    (display (backtrace) (current-error-port))
                    (newline (current-error-port)))))))))
       series-to-create-branches-for)

      (simple-format (current-error-port)
                     "finished processing patch branches (last issue: ~A)\n"
                     (car (last series-to-create-branches-for)))))

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

  (call-with-new-thread
   (lambda ()
     (while #t
       (with-exception-handler
           (lambda (exn)
             (simple-format
              (current-error-port)
              "exception in manage patch branches thread: ~A\n"
              exn))
         (lambda ()
           (with-throw-handler #t
             perform-pass
             (lambda args
               (display (backtrace) (current-error-port))
               (newline (current-error-port)))))
         #:unwind? #t)
       (sleep 3600)))))