;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.


(define-module (guix scripts review)
  #:use-module (guix scripts)
  #:use-module (guix ui)
  #:use-module (guix i18n)
  #:use-module (guix colors)
  #:use-module (guix http-client)
  #:use-module (guix utils)
  #:use-module ((guix build utils) #:select (find-files invoke))
  #:autoload   (guix inferior) (open-inferior close-inferior
                                               inferior-available-packages)
  #:autoload   (gnu packages) (fold-available-packages)
  #:autoload   (email email) (parse-email email-headers email-body)
  #:use-module (ice-9 binary-ports)
  #:use-module (srfi srfi-1)
  #:use-module (web uri)
  #:use-module (web http)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 format)
  #:export (guix-review))

(define (patch-set-url number)
  (string-append "https://issues.guix.gnu.org/issue/"
                 (number->string number) "/patch-set"))

(define (monkey-patch!)
  ;; XXX: Currently mumi returns "Content-Type: text;...", which is considered
  ;; invalid.  Work around it.
  (declare-header! "Content-Type"
                   (lambda (str)
                     (let ((parts (string-split str #\;)))
                       (cons 'text/plain          ;<- this is the "fix"
                             (map (lambda (x)
                                    (let ((eq (string-index x #\=)))
                                      (cons
                                       (string->symbol
                                        (string-trim x char-set:whitespace 0 eq))
                                       (string-trim-right x char-set:whitespace (1+ eq)))))
                                  (cdr parts)))))
                   (header-validator 'content-type)
                   (header-writer 'content-type))
  (set! monkey-patch! (const #t)))

(define (download-patch-set directory number)
  "Download to DIRECTORY the patches of issue NUMBER."
  (define (patch-file n)
    (format #f "~a/~3,'0d.patch" directory n))

  (define (from-line? str)
    (string-prefix? "From " str))

  (monkey-patch!)
  (let ((port (http-fetch (string->uri (patch-set-url number)))))
    (let loop ((n 0)
               (output (%make-void-port "w0")))
      (match (read-line port 'concat)
        ((? eof-object?)
         (close-port output)
         n)
        ((? from-line? line)
         (close-port output)
         (let* ((n   (+ n 1))
                (new (open-output-file (patch-file n))))
           (display line new)
           (loop n new)))
        (line
         (display line output)
         (loop n output))))))

(define colorize-patch-line
  (color-rules
   ("^(---.*)$" BOLD)
   ("^(\\+\\+\\+.*)$" BOLD)
   ("^(-.*)$" RED)
   ("^(\\+.*)$" GREEN)
   ("^(@@ .* @@)" CYAN)))

(define (display-patch file)
  "Read the patch in FILE and display it to standard output."
  (define email
    (parse-email
     (call-with-input-file file
       (lambda (port)
         (read-line port)                         ;discard the "From " line
         (get-bytevector-all port)))))

  (with-paginated-output-port port
    (match (assoc-ref (email-headers email) 'from)
      ((from)
       (format port "From: ~a <~a>~%"
               (or (assoc-ref from 'name) "")
               (assoc-ref from 'address))
       (format port "Subject: ~a~%"
               (assoc-ref (email-headers email) 'subject))
       (newline port)))

    (call-with-input-string (email-body email)
      (lambda (input)
        (let loop ()
          (match (read-line input 'concat)
            ((? eof-object?)
             #t)
            (line
             (display (colorize-patch-line line) port)
             (loop))
            (_
             (loop))))))))

(define (apply-patch patch)
  (invoke "git" "am" "-s" patch))


;;;
;;; Package differences.
;;;

(define (available-packages)
  (fold-available-packages
   (lambda* (name version result
                  #:key supported? deprecated?
                  #:allow-other-keys)
     (if (and supported? (not deprecated?))
         (alist-cons name version result)
         result))
   '()))

(define (new-available-packages)
  (define %top-builddir
    (dirname (search-path %load-compiled-path "guix.go")))

  (let* ((inferior (open-inferior %top-builddir #:command "scripts/guix"))
         (packages (inferior-available-packages inferior)))
    (close-inferior inferior)
    packages))

;; (define display-new/upgraded-packages
;;   (@@ (guix scripts pull) display-new/upgraded-packages))


;;;
;;; Command-line options.
;;;

(define %default-options
  '((action . apply)))

(define %options
  '())


;;;
;;; Entry point.
;;;

(define-command (guix-review . args)
  (category packaging)
  (synopsis "review patches")

  (with-error-handling
    (let* ((options (parse-command-line args %options
                                        (list %default-options)))
           (issue (match (assoc-ref options 'argument)
                    ((= string->number number)
                     number)
                    (_
                     (leave (G_ "missing issue number~%"))))))
      (call-with-temporary-directory
       (lambda (directory)
         (let ((patches (download-patch-set directory issue)))
           (info (N_ "downloaded ~a patch for issue #~a~%"
                     "downloaded ~a patches for issue #~a~%"
                     patches)
                 patches issue)
           (if (= 1 patches)
               (match (find-files directory)
                 ((patch)
                  (display-patch patch)
                  (info (G_ "hit enter to apply~%"))))
               (info (G_ "screen the patches under ~a and hit enter to apply~%")
                     directory))
           (read-char)

           (let ((old (available-packages)))
             (for-each apply-patch (find-files directory))
             (invoke "make")
             (let ((new (new-available-packages)))
               (pk 'diff (lset-difference equal? new old))
               (display-new/upgraded-packages old new
                                              #:concise? #f)))))))))

;; Local Variables:
;; eval: (put 'with-binding 'scheme-indent-function 2)
;; End: