path: root/fussy.lisp

;;;; 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)))))

(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)
    (if (stringp theme)
        (search term theme)
        (with-slots (name keywords description authors maintainer) 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-theme-packages)))

(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*))