From 6183e4448eda7416e63436e0614c781260c68654 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 8 Apr 2023 12:13:32 -0700
Subject: altered .gitignore; added preview files

---
 files/fussy.lisp | 608 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 608 insertions(+)
 create mode 100644 files/fussy.lisp

(limited to 'files/fussy.lisp')

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))))))))
-- 
cgit v1.2.3