Update Lisp repos

clim-repos.lisp

;; A GUI for fetching all third party git Lisp repos.
;;
;; Kinda silly and limited, but what the hell.

(defpackage #:snippets/clim-repos
  (:use #:clim-lisp #:clim)
  (:shadow
   #:merge)
  (:import-from
   #:uiop)
  (:import-from
   #:alexandria)
  (:import-from
   #:legit)
  (:import-from
   #:bordeaux-threads)
  (:import-from
   #:lparallel)
  (:export
   #:run))

(in-package #:snippets/clim-repos)

;;;; Repo

(defclass repo ()
  ((directory :initarg :directory :reader repo-directory)
   (status :initform :idle :accessor repo-status)))

(defmethod repo-name ((repo repo))
  (alexandria:last-elt (pathname-directory (repo-directory repo))))

(defmethod print-object ((repo repo) stream)
  (print-unreadable-object (repo stream :type t)
    (format stream "~S" (repo-name repo)))
  repo)

(defmacro repo-command (repo interest form)
  (multiple-value-bind (speakup shutup)
      (ecase interest
        (:errors (values 'legit:*git-errors* 'legit:*git-output*))
        (:output (values 'legit:*git-output* 'legit:*git-errors*)))
    `(let ((,speakup (make-string-output-stream))
           (,shutup (make-broadcast-stream)))
       (legit:with-chdir ((repo-directory ,repo))
         ,form
         (get-output-stream-string ,speakup)))))

(defmethod fetch ((repo repo))
  (not
   (alexandria:emptyp
    (repo-command repo :errors (legit:git-fetch)))))

(defmethod merge ((repo repo))
  ;; FIXME: This is actually pulling, not merging.
  (repo-command repo :errors (legit:git-pull)))

(defmethod update-status ((repo repo))
  (let* ((display-text (repo-command repo :output (legit:git-status ".")))
         (new-status (cond ((search "fast-forwarded" display-text)
                            :changes-available)
                           (t
                            :idle))))
    (setf (repo-status repo) new-status)))

;;;; Repo Collection

(defclass repo-collection ()
  ((list :initarg :list :accessor repo-collection-list)))

(defun list-files (base-directory)
  (directory
   (merge-pathnames
    (make-pathname :name :wild :type :wild)
    base-directory)))

(defun list-directories (base-directory)
  (remove-if-not #'uiop:directory-pathname-p
                 (list-files base-directory)))

(defun git-repo-directory-p (directory)
  (probe-file
   (merge-pathnames
    (make-pathname :directory '(:relative ".git"))
    directory)))

(defun list-repo-directories (base-directory)
  (remove-if-not #'git-repo-directory-p
                 (list-directories base-directory)))

(defun create-repo (directory)
  (make-instance 'repo :directory directory))

(defun create-repo-collection (base-directory)
  (let ((list (mapcar #'create-repo (list-repo-directories base-directory))))
    (make-instance 'repo-collection :list list)))

;;;; Worker

(defclass worker ()
  ())

(defgeneric start (worker))

(defgeneric alivep (worker))

(defgeneric join (worker))

(defmethod start ((worker null)))

(defmethod alivep ((worker null))
  nil)

(defmethod join ((worker null)))

;;;; Fetcher

(defclass fetcher (worker)
  ((frame :initarg :frame :reader fetcher-frame)
   (repos :initarg :repos :reader fetcher-repos)
   (thread :initform nil :accessor fetcher-thread)))

(defun fetcher-thread-function (fetcher)
  (let ((frame (fetcher-frame fetcher))
        (repos (fetcher-repos fetcher)))
    (lp:pmapc (lambda (repo)
                (fetch-and-update frame repo))
              :parts 4
              repos)))

(defmethod start ((fetcher fetcher))
  (unless (alivep fetcher)
    (setf (fetcher-thread fetcher)
          (bt:make-thread (lambda ()
                            (fetcher-thread-function fetcher))
                          :name "Fetch All Worker"))))

(defmethod alivep ((fetcher fetcher))
  (let ((thread (fetcher-thread fetcher)))
    (and (bt:threadp thread)
         (bt:thread-alive-p thread))))

(defmethod join ((fetcher fetcher))
  (when (alivep fetcher)
    (bt:join-thread (fetcher-thread fetcher))))

;;;; UI

(defclass main-view (view)
  ())

(defvar +main-view+
  (make-instance 'main-view))

(defclass main-pane (application-pane)
  ()
  (:default-initargs
   :display-function 'display-main
   :incremental-redisplay t
   :text-style (make-text-style :fix :roman :normal)))

(define-application-frame repos ()
  ((repo-collection :initarg :repo-collection
                    :reader repo-collection)
   (fetcher :initform nil :accessor fetcher)
   (runningp :initform t :accessor runningp))
  (:default-initargs
   :repo-collection (create-repo-collection "/home/death/quicklisp/third-party/"))
  (:panes
   (main (make-pane 'main-pane))
   (interactor :interactor))
  (:layouts
   (default
    (vertically ()
      (9/10 (scrolling () main))
      (+fill+ interactor)))))

(defun list-repos (frame)
  (repo-collection-list (repo-collection frame)))

(defun display-main (frame pane)
  ;; FIXME: MAX-WIDTH is hardcoded because mcclim doesn't redisplay
  ;; after window-configuration-event, and this sucks on a tiling
  ;; window manager.
  (formatting-item-list (pane :max-width 1920)
    (dolist (repo (list-repos frame))
      (formatting-cell (pane)
        (updating-output (pane :unique-id repo
                               :cache-value (repo-status repo))
          (present repo 'repo :stream pane :view +main-view+))))))

(define-presentation-method present (repo (type repo) stream (view main-view) &key)
  (let* ((name (repo-name repo))
         (status (repo-status repo)))
    (multiple-value-bind (foreground-ink background-ink)
        (ecase status
          (:pending (values +foreground-ink+ +light-yellow+))
          (:changes-available (values +foreground-ink+ +light-blue+))
          (:idle (values +foreground-ink+ +background-ink+)))
      (surrounding-output-with-border (stream :ink background-ink
                                              :background background-ink
                                              :padding 3)
        (with-drawing-options (stream :ink foreground-ink)
          (write-string name stream))))))

(define-presentation-method present (repo (type repo) stream (view textual-view) &key)
  (let ((name (repo-name repo)))
    (write-string name stream)))

(defmethod run-frame-top-level :before ((frame repos) &key)
  (setf (runningp frame) t))

(defmethod run-frame-top-level :after ((frame repos) &key)
  (setf (runningp frame) nil)
  (join (fetcher frame)))

(defun run ()
  (run-frame-top-level
   (make-application-frame 'repos)))

(define-repos-command (com-fetch :name t)
    ((repo 'repo))
  (fetch repo)
  (update-status repo))

(define-presentation-to-command-translator fetch
    (repo com-fetch repos :gesture nil)
    (repo)
  (list repo))

(define-repos-command (com-merge :name t)
    ((repo 'repo))
  (merge repo)
  (update-status repo))

(define-presentation-to-command-translator merge
    (repo com-merge repos :gesture nil)
    (repo)
  (list repo))

(define-repos-command (com-fetch-all :name t :menu t)
    ()
  (let ((frame *application-frame*))
    (unless (alivep (fetcher frame))
      (let ((repos (list-repos frame)))
        (dolist (repo repos)
          (setf (repo-status repo) :pending))
        (setf (fetcher frame) (make-instance 'fetcher :frame frame :repos repos))
        (start (fetcher frame))))))

(defclass repo-update (climi::standard-event)
  ((repo :initarg :repo :reader event-repo)))

(defun queue-repo-update-event (frame repo)
  (queue-event (frame-top-level-sheet frame)
               (make-instance 'repo-update
                              :repo repo
                              :sheet (get-frame-pane frame 'main))))

(defmethod handle-event ((pane main-pane) (event repo-update))
  ;; FIXME: Redisplaying the whole pane is kinda slow; we could
  ;; recreate the presentation.
  (redisplay-frame-pane (pane-frame pane) pane))

(defmacro with-errors-as-warnings (&body body)
  `(handler-case (progn ,@body)
     (error (e)
       (warn "Error: ~A" e))))

(defun fetch-and-update (frame repo)
  (flet ((check-running ()
           (unless (runningp frame)
             (return-from fetch-and-update))))
    (check-running)
    (with-errors-as-warnings
      (fetch repo)
      (check-running)
      (update-status repo))
    (check-running)
    (queue-repo-update-event frame repo)))