diff options
Diffstat (limited to 'files/fussy.lisp')
| -rw-r--r-- | files/fussy.lisp | 608 |
1 files changed, 608 insertions, 0 deletions
diff --git a/files/fussy.lisp b/files/fussy.lisp new file mode 100644 index 0000000..c7c8f84 --- /dev/null +++ b/files/fussy.lisp @@ -0,0 +1,608 @@ +;;;; 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 ~a ~a>" + (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) + (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))) + +(defgeneric url-path (theme)) +(defmethod url-path ((theme theme-pkg)) + (format nil "/package/~a" (string-downcase (theme-pkg-name theme)))) +(defmethod url-path ((theme string)) + (assert (theme-p theme)) + (format nil "/theme/~a/~a" + (string-downcase (theme-pkg-name (theme-package theme))) + theme)) + +(defun theme-p (string) (not (null (theme-package string))) ) + +(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* nil) + +(defun image-files-for-theme (theme) + (uiop:directory-files + (format nil "~a/~a/~a/" + (full-theme-image-directory) + (string-downcase (theme-pkg-name (theme-package theme))) + theme))) + +(defun theme-preview-image-path (theme &optional variant) + (assert (theme-p theme)) + (format nil "/images/~a/~a/~a.svg" + (string-downcase (theme-pkg-name (theme-package theme))) + theme + (or variant (pathname-name (first (image-files-for-theme theme)))))) + + +(defun start (&key config-file) + (unless config-file + (setf config-file + (or (uiop:getenv "FUSSY_CONFIG") + (asdf:system-relative-pathname :fussy "config.sexp")))) + (print config-file) + (unless *config* + (setf *config* + (load-config-from-file config-file) + *config-directory* + (uiop:pathname-directory-pathname config-file))) + (unless *server* + (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*)) + +(lzb:provision-app () + :title "Emacs Themes Library" + :content-type "text/html") + +;;; pages + +(defun an-integer (string) + (parse-integer string)) + + +(defparameter +themes-per-page+ 20) + +(defun nav () + (html:with-html + (:nav + (:a :href "/" (:h1 "FUSSY"))))) + +(defun page-nav (page page-count &optional terms) + "relative pagination nav to current page." + (flet ((format-string (pg) + (if terms + (format nil "?page=~a&terms=~{~a~^+~}" pg terms) + (format nil "?page=~a" pg)))) + (html:with-html + (:div :class "bigger center" + (:span (when (plusp page) + (:a :href (format-string (1- page)) " <<--- ")) + " | " + (when (< page (1- page-count)) + (:a :href (format-string (1+ page)) " --->> ")))) + (:div + :class "page-nav" + (dotimes (pg page-count) + (if (= pg page) + (:span (format nil " ~a " (1+ pg))) + (:span " " + (:a :href (format-string pg) (format nil "~a" (1+ pg))) + " "))))))) + +(defun theme-preview-image (theme &optional variant) + (html:with-html + (:img + :src (theme-preview-image-path theme variant)))) + +(defun theme-preview-card (theme) + (html:with-html + (:div :class "card" + (:a :href (url-path theme) (:h4 theme) + (theme-preview-image theme))))) + +(defun style () + (html:with-html + (:link :rel "stylesheet" :type "text/css" :href "/css/style.css"))) + +(defparameter +css-reset+ + " +html { + box-sizing: border-box; + font-size: 16px; +} + +*, *:before, *:after { + box-sizing: inherit; +} + +body, h1, h2, h3, h4, h5, h6, p, ol, ul { + margin: 0; + padding: 0; + font-weight: normal; +} + +ol, ul { + list-style: none; +} + +img { + max-width: 100%; + height: auto; +} + +") + + +(defparameter +style-css+ + " +html, body { + height: 100%; +} + +.main { + height: 100%; + width: 100%; + background-color: #eeeeff; +} + +.container { + width: 100%; + display: flex; + flex-wrap: wrap; + justify-content: space-evenly; +} + +.card { + min-width: 500px; + max-width: 50%; +} + +.card > a > h4 { + color: green; + text-align: center; +} + +.bigger { + font-size: 1.25em; +} + +.center { + text-align: center; +} + +.search { + margin-left: auto; + margin-right: auto; + width: 300px; +} + +h1 { + text-align: center; +} + +.header { + padding-top: 20px; + padding-bottom: 20px; + margin-top: 20px; + margin-bottom: 40px; +} + +.page-nav { + text-align: center; + font-size: 1.3em; + margin-top: 10px; + margin-bottom: 20px; +} + + +") + +(lzb:defendpoint* :get "/css/style.css" () () + "Endpoint generating and serving main css" + (setf (lzb:response-header :content-type) "text/css") + (concatenate 'string + +css-reset+ + '(#\newline) + +style-css+)) + +(lzb:defendpoint* :get "/images/:pkg:/:theme:/:image:" () () + "Endpoint for serving theme preview images" + (let ((file-path + (pathname + (format nil "~a/~a/~a/~a" + (full-theme-image-directory) + pkg + theme + image)))) + (unless (uiop:file-exists-p file-path) + (lzb:http-err 404 "no such file")) + file-path)) + +(defun a-string (s) s) + +(lzb:defendpoint* :get "/" ((page an-integer) (terms a-string)) () + "The landing page" + (let* ((page + (or page 0)) + (terms + (when terms (str:split-omit-nulls #\space terms))) + (all-themes + (if terms + (apply #'search-themes terms) + (all-themes))) + (page-count + (ceiling (/ (length all-themes) +themes-per-page+))) + (themes + (a:subseq* all-themes + (* page +themes-per-page+) + (* (1+ page) +themes-per-page+)))) + (html:with-html-string + (:doctype) + (:html + (:head + (:title "Fussy - Emacs Themes Gallery") + (style)) + (:body + (:div :class "main" + (nav) + (:div :class "center header" + (:p + "Emacs Themes Gallery for your Daily Procrastination Needs." (:br) + (write-to-string (length all-themes)) " themes and counting...")) + (:div :class "search" + (:form :method "GET" :action "/" + (:label :for "terms") + (:input :name "terms" :value (format nil "~{~a ~}" terms)) + (:button :type "submit" "search"))) + (when (< 1 page-count) + (page-nav page page-count terms)) + (:div :class "container" + (dolist (theme themes) + (theme-preview-card theme))) + (:div :class "foooter" + (when (< 1 page-count) + (page-nav page page-count terms))))))))) + +(defun a-package (string) + (a:if-let (pkg + (theme-pkg-with-name + (intern (string-upcase string) :fussy))) + pkg + (lzb:http-err 404 (format nil "No such theme package: ~a" string)))) + +(defun a-theme (string) + (if (theme-p string) string + (lzb:http-err 404 (format nil "No such theme: ~a" string)))) + +(defun package-namestring (pkg) + (hq:>> () pkg theme-pkg-name symbol-name string-downcase)) + +(lzb:defendpoint* :get "/package/:pkg a-package:" ((page an-integer)) () + "The page endpoint for a theme package" + (let ((themes + (themes-in-package pkg)) + (page + (or page 0))) + (html:with-html-string + (:doctype) + (:html + (:head + (:title ) + (style)) + (:body + (:div :class "main" + (nav) + (:div :class "center header" + (:h2 (package-namestring pkg) ) + (:p (theme-pkg-description pkg)) + (:p "This package contains" + (length themes) + (if (= 1 (length themes)) " theme" " themes")) + (:p (:a :href (theme-pkg-url pkg) + (theme-pkg-url pkg)))) + (when (< +themes-per-page+ (length themes)) + (page-nav page (floor (/ (length themes) +themes-per-page+)))) + (:div :class "container" + (dolist (theme (a:subseq* themes + (* page +themes-per-page+) + (* (1+ page) +themes-per-page+))) + (theme-preview-card theme))) + (when (< +themes-per-page+ (length themes)) + (page-nav page (floor (/ (length themes) +themes-per-page+)))))))))) + +(lzb:defendpoint* :get "/theme/:pkg a-package:/:theme a-theme:" () () + "The page for a particular theme showing its previews for different prog langs" + (unless (member theme (themes-in-package pkg) :test #'string-equal) + (lzb:http-err 403 (format nil "The theme ~a is not in the package ~a" + theme (package-namestring pkg)))) + (html:with-html-string + (:doctype) + (:html + (:head + (:title theme) + (style)) + (:body + (:div :class "main" + (nav) + (:div :class "center header" + (:h2 theme) + (:p "A theme in the package " + (:a :href (url-path pkg) (package-namestring pkg)))) + (:div :class "container" + (dolist (variant (mapcar #'pathname-name (image-files-for-theme theme))) + (theme-preview-image theme variant)))))))) |