path: root/ger2err

#!/usr/bin/env txrlisp
;; vim:filetype=tl:lisp:

;; Gerrit to Error ("ger2err")
;; Copyright 2022 Kaz Kylheku <kaz@kylheku.com>
;;
;; BSD-2 License
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;;    this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;    this list of conditions and the following disclaimer in the documentation
;;    and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.

(defvarl %prog% *load-path*)

(defvar *gerrit-curl*)

(defstruct patch-set ()
  num
  (files (hash)))

(defstruct file ()
  path
  (comments (vec)))

(defstruct comment ()
  line
  chr
  unresolved
  user
  name
  lines)

(defun fatal (. args)
  [apply format t `@{%prog%}: @(car args)\n` (cdr args)]
  (exit nil))

(defun gerrit-config (user-id password server)
  (if (contains ":" user-id)
    (error "user-id ~a may not have a \":\" (colon) in it." user-id))
  (set *gerrit-curl* `curl -H Accept-Encoding:gzip \ \
                      -s -k -u @{user-id}:@{password} @{server}`))

(defun gerrit (api)
  (unless *gerrit-curl*
    (error "~s: configure with gerrit-config function" 'gerrit))
  (with-stream (s (open-command `@{*gerrit-curl*}@api` "rz"))
    (let ((tag (get-line s)))
      (if (nequal tag ")]}'")
        (fatal "error response from server: ~a" tag)))
    (get-json s)))

(defun get-gerrit-comments (change-id : resolved-too)
  (let ((ps-hash (hash)))
    (dohash (path comments
                  (catch
                    (gerrit `/a/changes/@{change-id}/comments/`)
                    (syntax-error (. rest)
                      (fatal `error retrieving Change-Id: @{change-id}`)))
                  ps-hash)
      (each ((cmt comments))
        (let ((unresolved [cmt "unresolved"]))
          (when (or unresolved resolved-too)
            (let* ((ps-num (int-flo [cmt "patch_set"]))
                   (patch-set (or [ps-hash ps-num]
                                  (set [ps-hash ps-num]
                                       (new patch-set num ps-num))))
                   (file (or [patch-set.files path]
                             (set [patch-set.files path]
                                  (new file path path))))
                   (auth [cmt "author"]))
              (vec-push file.comments
                        (new comment
                             line (int-flo (or [cmt "line"] 0.0))
                             chr [[cmt "range"] "end_character"]
                             unresolved unresolved
                             user [auth "username"]
                             name [auth "name"]
                             lines (spl "\n" [cmt "message"]))))))))))

(defun print-as-errors (patchset)
  (put-line `comments from patch set @{patchset.num}`)
  (each ((file (sort (hash-values patchset.files) : .path)))
    (each ((cmt file.comments))
      (put-line `@{file.path}:@{cmt.line}:\
                 @(if cmt.chr `@{cmt.chr}:`) \ \
                 @(if cmt.unresolved "un")resolved comment by\ \
                 @{cmt.name} (@{cmt.user})`)
      (each ((ln cmt.lines))
        (put-line `\t@ln`)))))

(define-option-struct opts ()
  (nil help       :bool    "List this help text.")
  (p   patchset   :str     "Patchset selection. Valid choices are all,\ \
                            highest or a positive decimal integer\ \
                            with no leading zeros. Default is all.")
  (r   resolved   :bool    "Resolved comments too.")
  (s   server     :str     "URL of gerrit server, with no trailing slash:\ \
                            for example, https://example.com/gerrit .\ \
                            May be given via GER2ERR_SERVER\ \
                            environment variable.")
  (u   userid     :str     "HTTP user ID for Gerrit\ \
                            (Different from regular Gerrit user ID).\ \
                            May be given via GER2ERR_USERID\ \
                            environment variable.")
  (w   password   :str     "HTTP password for Gerrit\ \
                            (Different from regular Gerrit password;\ \
                            generated in Gerrit config GUI).\ \
                            May be given via GER2ERR_PASSWORD\ \
                            environment variable."))

(compile-only
  (catch
    (let ((o (new opts))
          (ps-sel :all))
      o.(getopts *args*)
      (when o.help
        (put-line `\nUsage:\n\n  @{%prog%} [options] change-id`)
        o.(opthelp)
        (exit nil))

      (match-case o.patchset
        (nil)
        ("all" (set ps-sel :all))
        ("highest" (set ps-sel :highest))
        (`@{num #/[1-9][0-9]*/}` (set ps-sel (int-str num)))
        (@else (fatal "bad argument to --patchset")))

      (gerrit-config (or o.userid
                         (getenv "GER2ERR_USERID")
                         (fatal "userid required"))
                     (or o.password
                         (getenv "GER2ERR_PASSWORD")
                         (fatal "password required"))
                     (or o.server
                         (getenv "GER2ERR_SERVER")
                         (fatal "server URL required")))

      (match-case o.out-args
        ((@change-id) (let ((ps-hash (get-gerrit-comments change-id o.resolved)))
                        (match-case ps-sel
                          (@(or @(integerp @psnum)
                                @(and :highest
                                      @(with psnum [find-max-key ps-hash : car])))
                            (print-as-errors [ps-hash psnum]))
                          (@else
                            (each ((psnum (sort (hash-keys ps-hash))))
                              (print-as-errors [ps-hash psnum]))))))
        (@else (fatal "change-id argument required: use --help for usage."))))
    (opt-error (msg)
      (fatal msg))))