diff options
Diffstat (limited to 'users/sterni')
| -rw-r--r-- | users/sterni/mblog/cli.lisp | 81 | ||||
| -rw-r--r-- | users/sterni/mblog/default.nix | 19 | ||||
| -rw-r--r-- | users/sterni/mblog/mblog.lisp | 140 | ||||
| -rw-r--r-- | users/sterni/mblog/packages.lisp | 16 |
4 files changed, 237 insertions, 19 deletions
diff --git a/users/sterni/mblog/cli.lisp b/users/sterni/mblog/cli.lisp index 14c7adda28ed..9bc0681df0f5 100644 --- a/users/sterni/mblog/cli.lisp +++ b/users/sterni/mblog/cli.lisp @@ -1,18 +1,71 @@ -(in-package :mblog) +(in-package :cli) (declaim (optimize (safety 3))) -(defparameter +synopsis+ "mnote-html FILE [FILE [ ... ]]") +;; TODO(sterni): nicer messages for various errors signaled? + +(defun partition-by (f seq) + "Split SEQ into two lists, returned as multiple values. The first list + contains all elements for which F returns T, the second one the remaining + elements." + (loop for x in seq + if (funcall f x) + collecting x into yes + else + collecting x into no + finally (return (values yes no)))) + +(defparameter +help+ '(("mnote-html" . "FILE [FILE [ ... ]]") + ("mblog" . "MAILDIR OUT"))) + +(defun mnote-html (name flags &rest args) + "Convert all note mime messages given as ARGS to HTML fragments." + (declare (ignore name flags)) + (loop for arg in args + do (note:apple-note-html-fragment + (note:make-apple-note (mime:mime-message (pathname arg))) + *standard-output*))) + +(defun mblog (name flags maildir outdir) + "Read a MAILDIR and build an mblog in OUTDIR " + (declare (ignore name flags)) + (build-mblog (pathname maildir) (pathname outdir))) + +(defun display-help (name flags &rest args) + "Print help message for current executable." + (declare (ignore args flags)) + (format *error-output* "Usage: ~A ~A~%" + name + (or (cdr (assoc name +help+ :test #'string=)) + (concatenate 'string "Unknown executable: " name)))) + +(defun usage-error (name flags &rest args) + "Print help and exit with a non-zero exit code." + (format *error-output* "~A: usage error~%" name) + (display-help name args flags) + (uiop:quit 100)) -;; TODO(sterni): handle relevant conditions (defun main () - (let* ((args (uiop:command-line-arguments)) - (help-p (or (not args) - (find-if (lambda (x) - (member x '("-h" "--help" "--usage") - :test #'string=)) - args)))) - (if help-p (format *error-output* "Usage: ~A~%" +synopsis+) - (loop for arg in args - do (note:apple-note-html-fragment - (note:make-apple-note (mime:mime-message (pathname arg))) - *standard-output*))))) + "Dispatch to correct main function based on arguments and UIOP:ARGV0." + (multiple-value-bind (flags args) + (partition-by (lambda (x) (starts-with #\- x)) + (uiop:command-line-arguments)) + + (let ((prog-name (pathname-name (pathname (uiop:argv0)))) + (help-requested-p (find-if (lambda (x) + (member x '("-h" "--help" "--usage") + :test #'string=)) + args))) + (apply + (if help-requested-p + #'display-help + (cond + ((and (string= prog-name "mnote-html") + (null flags)) + #'mnote-html) + ((and (string= prog-name "mblog") + (null flags) + (= 2 (length args))) + #'mblog) + (t #'usage-error))) + (append (list prog-name flags) + args))))) diff --git a/users/sterni/mblog/default.nix b/users/sterni/mblog/default.nix index cc605d7cd2ae..00e8b39ada0d 100644 --- a/users/sterni/mblog/default.nix +++ b/users/sterni/mblog/default.nix @@ -1,13 +1,14 @@ { depot, pkgs, ... }: -depot.nix.buildLisp.program { - name = "mnote-html"; +(depot.nix.buildLisp.program { + name = "mblog"; srcs = [ ./packages.lisp ./maildir.lisp ./transformer.lisp ./note.lisp + ./mblog.lisp ./cli.lisp ]; @@ -16,19 +17,29 @@ depot.nix.buildLisp.program { sbcl = depot.nix.buildLisp.bundled "uiop"; default = depot.nix.buildLisp.bundled "asdf"; } + depot.lisp.klatre depot.third_party.lisp.alexandria depot.third_party.lisp.babel depot.third_party.lisp.closure-html depot.third_party.lisp.cl-date-time-parser depot.third_party.lisp.cl-who + depot.third_party.lisp.local-time depot.third_party.lisp.mime4cl ]; - main = "mblog:main"; + main = "cli:main"; # due to sclf brokenOn = [ "ccl" "ecl" ]; -} +}).overrideAttrs (super: { + # The built binary dispatches based on argv[0]. Building two executables would + # waste a lot of space. + buildCommand = '' + ${super.buildCommand} + + ln -s "$out/bin/mblog" "$out/bin/mnote-html" + ''; +}) diff --git a/users/sterni/mblog/mblog.lisp b/users/sterni/mblog/mblog.lisp new file mode 100644 index 000000000000..1f971bc121d2 --- /dev/null +++ b/users/sterni/mblog/mblog.lisp @@ -0,0 +1,140 @@ +(in-package :mblog) + +;; util + +(defmacro with-overwrite-file ((&rest args) &body body) + "Like WITH-OPEN-FILE, but creates/supersedes the given file for writing." + `(with-open-file (,@args :direction :output + :if-exists :supersede + :if-does-not-exist :create) + ,@body)) + +(defvar *copy-buffer-size* 4096) + +(defun redirect-stream (in out) + "Consume input stream IN and write all its content to output stream OUT. + The streams' element types need to match." + (let ((buf (make-array *copy-buffer-size* :element-type (stream-element-type in)))) + (loop for pos = (read-sequence buf in) + while (> pos 0) + do (write-sequence buf out :end pos)))) + +;; CSS + +(defvar *style* " +header, main { + width: 100%; + max-width: 800px; +} + +main img { + max-width: 100%; +} + +a:link, a:visited { + color: blue; +} +") + +;; Templating + +(eval-when (:compile-toplevel :load-toplevel) + (setf (who:html-mode) :html5)) + +(defmacro render-page ((stream title &key root) &body body) + "Surround BODY with standard mblog document skeleton and render it to STREAM + using CL-WHO. If :ROOT is T, assume that the page is the top level index page. + Otherwise it is assumed to be one level below the index page." + `(who:with-html-output (,stream nil :prologue t) + (:html + (:head + (:meta :charset "utf-8") + (:meta :viewport "width=device-width") + (:title (who:esc ,title)) + (:link :rel "stylesheet" + :type "text/css" + :href ,(concatenate 'string (if root "" "../") "style.css")) + (:style "a:link, a:visited { color: blue; }")) + (:body + (:header + (:nav + (:a :href ,(who:escape-string (if root "" "..")) "index"))) + (:main ,@body))))) + +;; Build Logic + +(defun build-note-page (note note-dir) + "Convert NOTE to HTML and write it to index.html in NOTE-DIR alongside any + extra attachments NOTE contains." + (with-overwrite-file (html-stream (merge-pathnames "index.html" note-dir)) + (render-page (html-stream (apple-note-subject note)) + (:article + (apple-note-html-fragment note html-stream)))) + + (mime:do-parts (part note) + (unless (string= (mime:mime-id part) + (mime:mime-id (note:apple-note-text-part note))) + (let ((attachment-in (mime:mime-body-stream part)) + (attachment-dst (merge-pathnames + (mime:mime-part-file-name part) + note-dir))) + + (format *error-output* "Writing attachment ~A~%" attachment-dst) + + (with-overwrite-file (attachment-out attachment-dst + :element-type + (stream-element-type attachment-in)) + (redirect-stream attachment-in attachment-out))))) + + (values)) + +(defun build-index-page (notes-list destination) + "Write an overview page linking all notes in NOTE-LIST in the given order to + DESTINATION. The notes are assumed to be in a sibling directory named like the + each note's UUID." + (with-overwrite-file (listing-stream destination) + (render-page (listing-stream "mblog" :root t) + (:h1 "mblog") + (:table + (dolist (note notes-list) + (who:htm + (:tr + (:td (:a :href (who:escape-string (apple-note-uuid note)) + (who:esc (apple-note-subject note)))) + (:td (who:esc + (klatre:format-dottime + (universal-to-timestamp (apple-note-time note))))))))))) + (values)) + +(defun build-mblog (notes-dir html-dir) + "Take MIME messages from maildir NOTES-DIR and build a complete mblog in HTML-DIR." + (setf notes-dir (pathname-as-directory notes-dir)) + (setf html-dir (pathname-as-directory html-dir)) + + ;; TODO(sterni): avoid rewriting if nothing was updated + ;; TODO(sterni): clean up deleted things + ;; TODO(sterni): atom feed + + (let ((all-notes '())) + (dolist (message-path (maildir:list notes-dir)) + (let* ((note (make-apple-note (mime:mime-message message-path))) + (note-dir (merge-pathnames (make-pathname + :directory + `(:relative ,(apple-note-uuid note))) + html-dir))) + + (format *error-output* "Writing note message ~A to ~A~%" + message-path note-dir) + (ensure-directories-exist note-dir) + (build-note-page note note-dir) + (push note all-notes))) + + ;; reverse sort the entries by time for the index page + (setf all-notes (sort all-notes #'> :key #'apple-note-time)) + + (build-index-page all-notes (merge-pathnames "index.html" html-dir)) + + (with-overwrite-file (css-stream (merge-pathnames "style.css" html-dir)) + (write-string *style* css-stream)) + + (values))) diff --git a/users/sterni/mblog/packages.lisp b/users/sterni/mblog/packages.lisp index aa2fa952f1d0..651dc6f2618d 100644 --- a/users/sterni/mblog/packages.lisp +++ b/users/sterni/mblog/packages.lisp @@ -32,6 +32,20 @@ (defpackage :mblog (:use :common-lisp - :uiop + :klatre + :who + :maildir :note) + (:export :build-mblog) + (:import-from :local-time :universal-to-timestamp) + (:import-from :sclf :pathname-as-directory) + (:shadowing-import-from :common-lisp :list)) + +(defpackage :cli + (:use + :common-lisp + :uiop + :note + :mblog) + (:import-from :alexandria :starts-with) (:export :main)) |