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
    dir-treeview-themes display-theme smart-mode-line-powerline-theme
    smart-mode-line-atom-one-dark-theme rand-theme per-buffer-theme
    svg-mode-line-themes remember-last-theme xresources-theme))

(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 package-name<= (pkg1 pkg2)
  (string<=
   (symbol-name (theme-pkg-name pkg1))
   (symbol-name (theme-pkg-name pkg2))))

(defun package-version<= (pkg1 pkg2)
  (<= (first (theme-pkg-version pkg1))
      (first (theme-pkg-version pkg2))))

(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 (&optional sort-by)
  (let ((packages
          (db:store-objects-with-class 'theme-pkg)))
    (if sort-by
        (sort (copy-seq packages)  sort-by)
        packages)))

(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 (&key sort-by)
  (a:mappend #'themes-in-package (all-theme-packages sort-by)))

(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 (terms &key sort-by)
  (remove-if-not
   (apply #'a:conjoin (mapcar #'theme-mentions-anywhere terms))
   (all-themes :sort-by sort-by)))

(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")
   (fetch-time :std (list 0 0)
               :documentation "(Hour Minute) at which fussy updates its themes.")))

(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  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 the-update-time ()
  (multiple-value-bind (sec min hour date month year) (get-decoded-time)
    (declare (ignore min hour))
    (destructuring-bind (hh mm) (fetch-time *config*)
      (encode-universal-time sec mm hh date month year))))

(defun time-to-update-p ()
  (<= (abs (- (get-universal-time) (the-update-time))) 60))

(defvar *fetcher-thread* nil)

(defun start-fetch-thread ()
  (setf *fetcher-thread*
        (bt:make-thread
         (lambda ()
           (loop :while t
                 :when (time-to-update-p)
                   :do (handler-case (update-theme-packages)
                         (error (e) (format *error-output* "~a while updating." e)))
                 :do (sleep 59))))))

(defun start (&key config-file)
  (unless config-file
    (setf config-file
          (or (uiop:getenv "FUSSY_CONFIG")
              (asdf:system-relative-pathname :fussy "config.sexp"))))
  (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)
  (reindex-themes-by-package)
  (lzb:install-app *server* (lzb:app 'fussy::fussy))
  (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
               (search-themes terms :sort-by (complement #'package-version<=))
               (all-themes :sort-by (complement #'package-version<=))))
         (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)
                      "Showing " (write-to-string (length all-themes)) " themes." (:br)
                      "Newer themes, or newly updated themes, are shown first"))
              (: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))))))))