;;;; fussy.lisp (in-package #:fussy) (defvar +default-emacs-package-archive+ "https://melpa.org/packages/archive-contents") (defun emacs-reader-readtable () "Return a readtable that will read the emacs package archive contents." (let ((*readtable* (copy-readtable nil))) (labels ((bracket-reader (stream char) (declare (ignorable char)) (read-delimited-list #\] stream))) (set-macro-character #\[ #'bracket-reader) (set-macro-character #\] (get-macro-character #\) nil)) *readtable*))) (defun fetch-emacs-archive (&optional (archive +default-emacs-package-archive+)) "Fetch the package archive from ARCHIVE, a url, and read it in using the emacs' reader readtable." ;; TODO: HANDLE HTTP ERRORS, HANDLE TIMEOUT, HANDLE READ ERRORS (multiple-value-bind (stream status) (dexador:get archive :want-stream t) (when (= 200 status) (let* ((*package* (find-package :fussy)) (*readtable* (emacs-reader-readtable))) (read stream))))) (defclass/std theme-pkg (db:store-object) ((name :with :index-type bknr.indices:unique-index :index-reader theme-pkg-with-name) (commit version authors maintainer keywords url description contained-themes :with)) (:metaclass db:persistent-class) (:documentation "Represents an Emacs theme package.")) (defmethod print-object ((theme theme-pkg) stream) (format stream "#" (theme-pkg-name theme) (theme-pkg-version theme))) (defparameter +excludes+ '(tramp-theme color-theme airline-themes unobtrusive-magit-theme cycle-themes )) (defun theme-package-p (archive-object) (when (consp archive-object) (unless (member (first archive-object) +excludes+) (let ((name (symbol-name (first archive-object)))) (or (a:ends-with-subseq "-theme" name :test #'char-equal) (a:ends-with-subseq "-themes" name :test #'char-equal)))))) (defun archive-theme-name (archive-pkg) (first archive-pkg)) (defun archive-theme-version (archive-pkg) (second archive-pkg)) (defun make-theme-pkg-from-archive-theme (archive-theme) (destructuring-bind (name version _dontcare desc _dontcare2 meta-alist) archive-theme (declare (ignore _dontcare _dontcare2)) (db:with-transaction () (make-instance 'theme-pkg :name name :version version :description desc :commit (cdr (assoc :commit meta-alist)) :maintainer (cdr (assoc :maintainer meta-alist)) :url (cdr (assoc :url meta-alist)) :authors (cdr (assoc :authors meta-alist)) :keywords (cdr (assoc :keywords meta-alist)))))) (defun update-theme-pkg-from-archive-theme (pkg arch) (destructuring-bind (name version _dontcare desc _dontcare2 meta-alist) arch (declare (ignore _dontcare _dontcare2)) (db:with-transaction () (setf (theme-pkg-name pkg) name (theme-pkg-version pkg) version (theme-pkg-description pkg) desc (theme-pkg-commit pkg) (cdr (assoc :commit meta-alist)) (theme-pkg-maintainer pkg) (cdr (assoc :maintainer meta-alist)) (theme-pkg-url pkg) (cdr (assoc :url meta-alist)) (theme-pkg-authors pkg) (cdr (assoc :authors meta-alist)) (theme-pkg-keywords pkg) (cdr (assoc :keywords meta-alist)))))) (defun process-archive-theme (archive-theme) ;; ugg this is ugly. I hate it when code is all dense like this. (a:if-let (pkg (theme-pkg-with-name (archive-theme-name archive-theme))) (when (not (equalp (archive-theme-version archive-theme) (theme-pkg-version pkg))) (update-theme-pkg-from-archive-theme pkg archive-theme)) (make-theme-pkg-from-archive-theme archive-theme))) (defun theme-needs-update-p (archive-theme) "A theme should be updated if eithe it is new or if its version differs from the theme-pkg instance already in the data store." (let ((pkg (theme-pkg-with-name (archive-theme-name archive-theme)))) (not (and pkg (equalp (archive-theme-version archive-theme) (theme-pkg-version pkg)))))) (defun update-theme-packages () (let ((themes-to-update (remove-if-not (a:conjoin #'theme-package-p #'theme-needs-update-p) (fetch-emacs-archive)))) ;; just going to let this throw an error. will either introduce a ;; restart-case with some restarts or something later, or will ;; just catch the error in the caller of update-theme-packages (when themes-to-update ;; delete the temporary .emacs.d (uiop:delete-directory-tree (uiop:merge-pathnames* ".emacs.d/" (full-theme-image-directory)) :validate t :if-does-not-exist :ignore) (generate-images-for-packages (mapcar #'archive-theme-name themes-to-update)) ;; if we didn't error: update the db (dolist (archive-theme themes-to-update) (process-archive-theme archive-theme)) (reindex-themes-by-package)))) (defun all-theme-keywords () (delete-duplicates (copy-seq (mapcan (a:compose #'copy-seq #'theme-pkg-keywords) (db:store-objects-with-class 'theme-pkg))) :test #'equal)) (defun themes-with-keywords (&rest keywords) (loop :for theme :in (db:store-objects-with-class 'theme-pkg) :when (subsetp keywords (theme-pkg-keywords theme) :test #'string-equal) :collect theme)) (defun all-theme-packages () (db:store-objects-with-class 'theme-pkg)) (defun just-the-directory-namestring (path) "returns a string, the name of the directory that the path represents." ;; directory-namestring is taken, seems to peel off any file at the end (first (last (pathname-directory path)))) (defun themes-in-package (pkg &optional (config *config*)) "Themes that belong to a particular package are stored as the names of directories that contain the theme's images. These directories are stored beneath the directory that names the package. This function returns a list of those names." (mapcar #'just-the-directory-namestring (uiop:subdirectories (uiop:merge-pathnames* (string-downcase (format nil "~a/" (theme-pkg-name pkg))) (full-theme-image-directory config))))) (defun all-themes () (a:mappend #'themes-in-package (all-theme-packages))) (defun theme-mentions-anywhere (term) (lambda (theme) (or (search term theme) (with-slots (name keywords description authors maintainer) (theme-package theme) (or (search term (symbol-name name) :test #'char-equal) (some (lambda (keyword) (search term keyword :test #'char-equal)) keywords) (search term description :test #'char-equal)))))) (defun search-themes (&rest terms) (remove-if-not (apply #'a:conjoin (mapcar #'theme-mentions-anywhere terms)) (all-themes))) (defvar *theme->packages* nil "A hash table indexing packages by the themes they contain.") (defun theme-package (theme) (gethash theme *theme->packages*)) (defun reindex-themes-by-package () (let ((table (make-hash-table :test #'equal))) (dolist (pkg (all-theme-packages)) (dolist (theme (themes-in-package pkg)) (setf (gethash theme table) pkg))) (setf *theme->packages* table))) (defclass/std config () ((theme-image-directory store-directory fussy-el :std "" :documentation "These paths are by default equal to the config directory.") (port :std 8888) (domain :std "localhost") (address :std "0.0.0.0"))) (defvar *config* nil) (defvar *config-directory* nil "The config dir is the directory where the config file is. This directory is used as a default directory for all relative paths mentioned in the config file. Any Absolute paths in the config file are treated as such.") (defun load-config-from-file (file) (apply #'make-instance 'config (read-from-string (a:read-file-into-string file)))) (defun full-store-directory (&optional (config *config*)) (uiop:merge-pathnames* (store-directory config) *config-directory*)) (defun full-theme-image-directory (&optional (config *config*)) (uiop:merge-pathnames* (theme-image-directory config) *config-directory*)) (defun emacs-dot-d-directory (&optional (config *config*)) (uiop:merge-pathnames* ".emacs.d/" (full-theme-image-directory config))) (defun create-db () (unless (boundp 'db:*store* ) (ensure-directories-exist (full-store-directory)) (make-instance 'db:mp-store :directory (full-store-directory) :subsystems (list (make-instance 'db:store-object-subsystem))))) (defparameter +standard-themes+ '(adwaita deeper-blue dichromacy light-blue modus-operandi modus-vivendi tango-dark wheatgrass manoj-dark tsdh-dark tsdh-light whiteboard leuven misterioso tango wombat) "these are built in themes - this list can be passed to the image generation script when you want to generate themes for just a single package - ordinarily the script generates images for all themes, but passing this list as the value of FUSSY-EXCLUDED-THEMES will ensure that they are not loaded during image gen.") (defun generate-elisp-to-fetch-and-exclude (package-names) (let ((downcaser (a:compose #'string-downcase #'symbol-name))) (format nil "(setq fussy-themes-packages '(~{~a~^ ~}) fussy-excluded-themes '(~{~a~^ ~}))" (mapcar downcaser package-names) (mapcar downcaser +standard-themes+)))) (defun fussy-elisp-script-location (&optional (config *config*)) (uiop:merge-pathnames* *config-directory* (fussy-el config))) (defun format-emacs-evocation-script (package-names) (format nil "env HOME=~a emacs -q --eval ~s --load ~a" (full-theme-image-directory) (generate-elisp-to-fetch-and-exclude package-names) (fussy-elisp-script-location))) (defun generate-images-for-packages (package-names) (when package-names (uiop:run-program (format-emacs-evocation-script package-names)))) (defvar *server* (lzb:create-server)) (lzb:defendpoint* :get "/hello" () () "what in the fuck? is fucking hjappening?") (lzb:provision-app () :title "Emacs Themes Library" :content-type "text/html") (defun start (&key config-file) (unless config-file (setf config-file (or (uiop:getenv "FUSSY_CONFIG") (asdf:system-relative-pathname :fussy "config.sexp")))) (setf *config* (load-config-from-file config-file) *config-directory* (uiop:pathname-directory-pathname config-file)) (setf *server* (lzb:create-server :port (port *config*) :address (address *config*) :domain (domain *config*))) (create-db) (update-theme-packages) (lzb:install-app *server* (lzb:app)) (lzb:start-server *server*))