diff options
| -rw-r--r-- | defpackage.lisp | 26 | ||||
| -rw-r--r-- | globals.lisp | 64 | ||||
| -rw-r--r-- | journal-content.lisp | 153 | ||||
| -rwxr-xr-x | journal.cgi | 2 | ||||
| -rwxr-xr-x | journal.lisp | 419 | ||||
| -rw-r--r-- | main.lisp | 110 | ||||
| -rw-r--r-- | mulk-journal.asd | 35 | ||||
| -rwxr-xr-x | run.lisp | 55 | ||||
| -rw-r--r-- | utils.lisp | 167 |
9 files changed, 613 insertions, 418 deletions
diff --git a/defpackage.lisp b/defpackage.lisp new file mode 100644 index 0000000..cc828b3 --- /dev/null +++ b/defpackage.lisp @@ -0,0 +1,26 @@ +;;;; -*- coding: utf-8; mode: lisp -*- +;;;; Copyright 2007, Matthias Andreas Benkard. + +;;;------------------------------------------------------------------------ +;;; This file is part of The Mulkblog Project. +;;; +;;; The Mulkblog Project is free software. You can redistribute it and/or +;;; modify it under the terms of the Affero General Public License as +;;; published by Affero, Inc.; either version 1 of the License, or +;;; (at your option) any later version. +;;; +;;; The Mulkblog Project is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty +;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the Affero General Public +;;; License in the COPYING file that comes with The Mulkblog Project; if +;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San +;;; Francisco, CA 94107 USA. +;;;------------------------------------------------------------------------ + +(defpackage #:mulk.journal + (:nicknames #:journal) + (:use #:cl #:fad #:iterate #:markdown #:yaclml #:http #:alexandria + #:xml-emitter #:split-sequence)) diff --git a/globals.lisp b/globals.lisp new file mode 100644 index 0000000..1764089 --- /dev/null +++ b/globals.lisp @@ -0,0 +1,64 @@ +;;;; -*- coding: utf-8; mode: lisp -*- +;;;; Copyright 2007, Matthias Andreas Benkard. + +;;;------------------------------------------------------------------------ +;;; This file is part of The Mulkblog Project. +;;; +;;; The Mulkblog Project is free software. You can redistribute it and/or +;;; modify it under the terms of the Affero General Public License as +;;; published by Affero, Inc.; either version 1 of the License, or +;;; (at your option) any later version. +;;; +;;; The Mulkblog Project is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty +;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the Affero General Public +;;; License in the COPYING file that comes with The Mulkblog Project; if +;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San +;;; Francisco, CA 94107 USA. +;;;------------------------------------------------------------------------ + +(in-package #:mulk.journal) + + +(defparameter *site* nil + "One of :WIRSELKRAUT and :NFS.NET.") + +(defparameter *debugging-p* nil) + +(defparameter *query* nil + "The HTTP query string transformed into a property list.") + +(defparameter *http-env* nil + "A hash table of HTTP environment variables.") + +(defparameter *subpath-query* nil + "The query string stripped of the script location.") + +(defparameter *subpath-string* nil + "The query string stripped of the script location and query parameters, + that is, the virtual path below the script.") + +(defparameter *subpath* nil + "*SUBPATH-STRING* parsed into a list of nested directories.") + +(defparameter *post-number* nil + "The identification number of the journal entry to be acted upon. + May be NIL.") + +(defparameter *action* nil + "One of NIL, :INDEX, :VIEW-ATOM-FEED, :VIEW, :POST, :EDIT, :PREVIEW, + and :POST-COMMENT.") + +(defparameter *method* nil + "One of :GET, :POST, :PUT, and :DELETE.") + +(defparameter *script-filename* nil) + +(defparameter *journal-entries* nil + "A list of JOURNAL-ENTRY objects.") + +(defparameter *cgi-p* nil + "Whether we have been called as a CGI script or not.") diff --git a/journal-content.lisp b/journal-content.lisp new file mode 100644 index 0000000..c914269 --- /dev/null +++ b/journal-content.lisp @@ -0,0 +1,153 @@ +;;;; -*- coding: utf-8; mode: lisp -*- +;;;; Copyright 2007, Matthias Andreas Benkard. + +;;;------------------------------------------------------------------------ +;;; This file is part of The Mulkblog Project. +;;; +;;; The Mulkblog Project is free software. You can redistribute it and/or +;;; modify it under the terms of the Affero General Public License as +;;; published by Affero, Inc.; either version 1 of the License, or +;;; (at your option) any later version. +;;; +;;; The Mulkblog Project is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty +;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the Affero General Public +;;; License in the COPYING file that comes with The Mulkblog Project; if +;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San +;;; Francisco, CA 94107 USA. +;;;------------------------------------------------------------------------ + +(in-package #:mulk.journal) + + +;;; (@* "Class definitions") +(defclass journal-entry () + ((id :type (integer 0) + :accessor id-of + :initarg :id) + (uuid :type string + :accessor uuid-of + :initarg :uuid) + (file :type (or null pathname) + :accessor file-of + :initarg :file) + (title :type string + :accessor title-of + :initarg :title + :initform "") + (date :type (integer 0) + :accessor date-of + :initarg :date) + (last-modification :type (or null (integer 0)) + :accessor last-modification-of + :initarg :last-modification + :initform nil) + (body :type string + :accessor body-of + :initarg :body + :initform "") + (categories :type list + :accessor categories-of + :initarg :categories + :initform '()) + (comments :type list + :accessor comments-about + :initarg :comments + :initform '()))) + + +(defclass journal-comment () + ((id :type (integer 0) + :accessor id-of + :initarg :id) + (uuid :type string + :accessor uuid-of + :initarg :uuid) + (date :type (integer 0) + :accessor date-of + :initarg :date) + (body :type string + :accessor body-of + :initarg :body + :initform "") + (author :type (or null string) + :accessor author-of + :initarg :author + :initform nil) + (email :type (or null string) + :accessor email-of + :initarg :email + :initform nil) + (website :type (or null string) + :accessor website-of + :initarg :website + :initform nil))) + + +;; (@* "Journal entry operations") +(defmethod shared-initialize ((journal-entry journal-entry) slot-names + &key) + (with-slots (id) journal-entry + (when (or (eq slot-names t) + (member 'id slot-names)) + (setf id (1+ (reduce #'max *journal-entries* + :key #'id-of + :initial-value -1))))) + (call-next-method)) + + +(defun find-entry (number) + (find number *journal-entries* :key #'id-of)) + + +(defun journal-markup->html (markup) + (if (string= "" markup) + markup + (handler-bind + ((error ;; method-call-type-error or not + ;; Work around a weird bug in cl-markdown or CLISP. (I + ;; don't know which.) + #'(lambda (c) + (declare (ignore c)) + #+nil (<:as-html + (with-output-to-string (s) + (system::pretty-print-condition c s))) + (invoke-restart 'return nil)))) + (fixup-markdown-output + (with-output-to-string (s) + ;; Normally, we shouldn't need to create our own stream to + ;; write into, but this is, of course, yet another + ;; CLISP/Markdown hack, because Markdown's default + ;; *OUTPUT-STREAM* seems to spontaneously close itself, making + ;; everything break when Markdown tries to render more stuff. + (markdown markup :stream s)))))) + + +(defun read-journal-entry (filename) + (with-open-file (file filename :direction :input + :external-format #+clisp charset:utf-8 + #+sbcl :utf-8) + (let ((*read-eval* nil)) + (let ((data (read file))) + (let ((comments (member :comments data))) + (when comments + (setf (second comments) + (mapcar #'(lambda (comment-record) + (apply #'make-instance + 'journal-comment + comment-record)) + (second comments))))) + (apply #'make-instance 'journal-entry :file filename data))))) + + +(defun compute-journal-last-modified-date () + #-clisp (get-universal-time) + #+clisp + (loop for file in (list* *script-filename* ;; journal.cgi + (merge-pathnames (make-pathname :type "lisp") + *script-filename*) ;; journal.lisp + (find-journal-entry-files)) + maximize (posix:file-stat-mtime (posix:file-stat file)))) diff --git a/journal.cgi b/journal.cgi index 96e46d9..a23b433 100755 --- a/journal.cgi +++ b/journal.cgi @@ -1,3 +1,3 @@ #! /bin/sh DIR=`dirname "$0"` -exec clisp -M "$DIR/lispinit.mem.gz" "$DIR/journal.lisp" "$@" +exec clisp -M "$DIR/lispinit.mem.gz" "$DIR/run.lisp" "$@" diff --git a/journal.lisp b/journal.lisp index 0d16198..6db96e3 100755 --- a/journal.lisp +++ b/journal.lisp @@ -1,8 +1,7 @@ -#! /usr/bin/env clisp ;;;; -*- coding: utf-8; mode: lisp -*- ;;;; Copyright 2007, Matthias Andreas Benkard. -;;;----------------------------------------------------------------------- +;;;------------------------------------------------------------------------ ;;; This file is part of The Mulkblog Project. ;;; ;;; The Mulkblog Project is free software. You can redistribute it and/or @@ -19,381 +18,11 @@ ;;; License in the COPYING file that comes with The Mulkblog Project; if ;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San ;;; Francisco, CA 94107 USA. -;;;----------------------------------------------------------------------- - - -;;; TAKE NOTICE: If you want to run this script from the command line or -;;; from a web server, be sure to use a core image including the systems -;;; this script depends upon. The DEFSYSTEM form below has mainly been -;;; written for purposes of documentation. -(asdf:defsystem #:mulk.journal - :description "Matthias Benkard's simple web journal engine" - :licence "Affero General Public License, version 1 or higher" - :depends-on (#:cl-ppcre #:cl-fad #:iterate #:cl-markdown #:parenscript - #:yaclml #:lisp-cgi-utils #:alexandria #:xml-emitter - #:split-sequence)) - - -;;; The following does not generally work in a CGI setting because of -;;; security restrictions. Then again, loading all the dependencies -;;; individually rather than using a core image would certainly be too -;;; slow for any serious CGI usage, anyway, so what the heck. -(unless (find-package '#:http) - (asdf:oos 'asdf:load-op '#:mulk.journal)) - - -(defpackage #:mulk.journal - (:nicknames #:journal) - (:use #:cl #:fad #:iterate #:markdown #:yaclml #:http #:alexandria - #:xml-emitter #:split-sequence)) +;;;------------------------------------------------------------------------ (in-package #:mulk.journal) -(defun keywordify (thing) - (if (null thing) - thing - (intern (etypecase thing - (string (string-upcase thing)) - (symbol (symbol-name thing))) - '#:keyword))) - - -(defparameter *site* - (if (file-exists-p #p"/home/mulk") :mst-plus :nfs.net) - "One of :WIRSELKRAUT and :NFS.NET.") - -(defparameter *debugging-p* - (eq *site* :mst-plus)) - -(defparameter *query* - #+clisp - (mapcan #'(lambda (param) - (list (keywordify param) - (ext:convert-string-from-bytes - (ext:convert-string-to-bytes - (http-query-parameter param) - charset:iso-8859-1) - charset:utf-8))) - (http-query-parameter-list)) - #-clisp '() - "The HTTP query string transformed into a property list.") - -(defparameter *http-env* - (http-get-env-vars) - "A hash table of HTTP environment variables.") - -(defparameter *subpath-query* - (subseq (gethash "REQUEST_URI" *http-env*) - (length (if (eq *site* :mst-plus) - (gethash "SCRIPT_NAME" *http-env*) - "/journal"))) - "The query string stripped of the script location.") - -(defparameter *subpath-string* - (subseq *subpath-query* - 0 - (or (position #\? *subpath-query*) - (length *subpath-query*))) - "The query string stripped of the script location and query parameters, - that is, the virtual path below the script.") - -(defparameter *subpath* - (split-sequence #\/ *subpath-string* - :remove-empty-subseqs t) - "*SUBPATH-STRING* parsed into a list of nested directories.") - -(defparameter *post-number* - (parse-integer (or (first *subpath*) - (getf *query* :id "")) - :junk-allowed t #|| :radix 12 ||#) - "The identification number of the journal entry to be acted upon. - May be NIL.") - -(defparameter *action* - (or (keywordify (getf *query* :action)) - (cond (*post-number* :view) - ((string= "feed" (first *subpath*)) :view-atom-feed) - (t nil))) - "One of NIL, :INDEX, :VIEW-ATOM-FEED, :VIEW, :POST, :EDIT, :PREVIEW, - and :POST-COMMENT.") - -(defparameter *method* - (keywordify (gethash "REQUEST_METHOD" (http-get-env-vars))) - "One of :GET, :POST, :PUT, and :DELETE.") - -(defparameter *script-filename* - (pathname-as-file (or (gethash "SCRIPT_FILENAME" *http-env*) - "/home/mulk/Dokumente/Projekte/Mulkblog/journal.cgi"))) - -(defparameter *journal-entries* - '() - "A list of JOURNAL-ENTRY objects.") - - -(defclass journal-entry () - ((id :type (integer 0) - :accessor id-of - :initarg :id) - (uuid :type string - :accessor uuid-of - :initarg :uuid) - (file :type (or null pathname) - :accessor file-of - :initarg :file) - (title :type string - :accessor title-of - :initarg :title - :initform "") - (date :type (integer 0) - :accessor date-of - :initarg :date) - (last-modification :type (or null (integer 0)) - :accessor last-modification-of - :initarg :last-modification - :initform nil) - (body :type string - :accessor body-of - :initarg :body - :initform "") - (categories :type list - :accessor categories-of - :initarg :categories - :initform '()) - (comments :type list - :accessor comments-about - :initarg :comments - :initform '()))) - - -(defclass journal-comment () - ((id :type (integer 0) - :accessor id-of - :initarg :id) - (uuid :type string - :accessor uuid-of - :initarg :uuid) - (date :type (integer 0) - :accessor date-of - :initarg :date) - (body :type string - :accessor body-of - :initarg :body - :initform "") - (author :type (or null string) - :accessor author-of - :initarg :author - :initform nil) - (email :type (or null string) - :accessor email-of - :initarg :email - :initform nil) - (website :type (or null string) - :accessor website-of - :initarg :website - :initform nil))) - - -(defmethod shared-initialize ((journal-entry journal-entry) slot-names - &key) - (with-slots (id) journal-entry - (when (or (eq slot-names t) - (member 'id slot-names)) - (setf id (1+ (reduce #'max *journal-entries* - :key #'id-of - :initial-value -1))))) - (call-next-method)) - - -(defun find-entry (number) - (find number *journal-entries* :key #'id-of)) - - -(defun make-uuid () - "Generate a version 4 UUID according to RFC 4122, section 4.4." - (format nil "~(~8,'0x-~4,'0x-~4,'0x-~2,'0x~2,'0x-~12,'0x~)" - (random #x100000000) ;; time_low - (random #x10000) ;; time_mid - (logior #b0100000000000000 - (logand #b0000111111111111 - (random #x10000))) ;; time_hi_and_version - (logior #b10000000 - (logand #b00111111 - (random #x100))) ;; clock_seq_hi_and_reserved - (random #x100) ;; clock_seq_low - (random #x1000000000000))) ;; node - - -(defun fixup-markdown-output (markup) - ;; No, cl-markdown is certainly not perfect. - ;; - ;; First, convert "<a ...> bla</a>" into " <a ...>bla</a>" (note the - ;; excess space to the right of the opening tag in the unprocessed - ;; string, which we move to the left of the same opening tag, where we - ;; expect it to make more sense in the general case). - (loop - for matches = (ppcre:all-matches "<a [^>]*?> " markup) - while (not (null matches)) - do (progn - (setf markup - (replace markup markup :start1 (1+ (first matches)) - :end1 (second matches) - :start2 (first matches) - :end2 (1- (second matches)))) - (setf (elt markup (first matches)) #\Space))) - markup) - - -(defun journal-markup->html (markup) - (if (string= "" markup) - markup - (handler-bind - ((error ;; method-call-type-error or not - ;; Work around a weird bug in cl-markdown or CLISP. (I - ;; don't know which.) - #'(lambda (c) - (declare (ignore c)) - #+nil (<:as-html - (with-output-to-string (s) - (system::pretty-print-condition c s))) - (invoke-restart 'return nil)))) - (fixup-markdown-output - (with-output-to-string (s) - ;; Normally, we shouldn't need to create our own stream to - ;; write into, but this is, of course, yet another - ;; CLISP/Markdown hack, because Markdown's default - ;; *OUTPUT-STREAM* seems to spontaneously close itself, making - ;; everything break when Markdown tries to render more stuff. - (markdown markup :stream s)))))) - - -(defun read-journal-entry (filename) - (with-open-file (file filename :direction :input - :external-format #+clisp charset:utf-8 - #+sbcl :utf-8) - (let ((*read-eval* nil)) - (let ((data (read file))) - (let ((comments (member :comments data))) - (when comments - (setf (second comments) - (mapcar #'(lambda (comment-record) - (apply #'make-instance - 'journal-comment - comment-record)) - (second comments))))) - (apply #'make-instance 'journal-entry :file filename data))))) - - -(defun find-journal-entry-files () - (let ((directory - (make-pathname - :directory (pathname-directory - (merge-pathnames - (make-pathname :directory '(:relative "journal-entries") - :name nil) - *script-filename*)))) - (journal-entry-files (list))) - (when (file-exists-p directory) - (walk-directory directory - #'(lambda (x) - (push x journal-entry-files)) - :test (complement #'directory-pathname-p))) - journal-entry-files)) - - -(defun read-journal-entries () - (let ((journal-entry-files (find-journal-entry-files))) - (sort (mapcar #'read-journal-entry journal-entry-files) - #'>= - :key #'id-of))) - - -(defmacro regex-case (string &body clauses) - (once-only (string) - `(cond ,@(loop for (keys . forms) in clauses - collect - `(,(if (and (symbolp keys) - (or (eq t keys) - (equal "OTHERWISE" (symbol-name keys)))) - 't - `(or ,@(loop for key in (if (listp keys) - keys - (list keys)) - collect - `(ppcre:scan-to-strings ,key ,string)))) - ,@forms))))) - - -(defun name-of-day (day-of-week) - (case day-of-week - (0 "Montag") - (1 "Dienstag") - (2 "Mittwoch") - (3 "Donnerstag") - (4 "Freitag") - (5 "Samstag") - (6 "Sonntag"))) - - -(defun format-date (destination date-control-string universal-time - &optional (time-zone nil time-zone-supplied-p)) - "Format DATE according to the description given by DATE-FORMAT-STRING. - -Recognised format directives are: %day, %mon, %yr, %day-of-week, %zone, -%@day-of-week (name of day), %sec, %min, %hr, %daylight-p. - -Note that you can mix FORMAT and FORMAT-DATE painlessly by calling them -after another in any arbitrary order." - (format - destination "~A" - (with-output-to-string (out) - (multiple-value-bind (sec min hr day mon yr day-of-week daylight-p zone) - (if time-zone-supplied-p - (decode-universal-time universal-time time-zone) - (decode-universal-time universal-time)) - (let ((first-match-p t)) - (ppcre:do-matches (start end "%[^%]*" date-control-string) - (let ((substring (subseq date-control-string start end))) - (multiple-value-bind (control value offset) - (regex-case substring - ("^%day-of-week" (values "~D" day-of-week 12)) - ("^%@day-of-week" (values "~A" - (name-of-day day-of-week) - 13)) - ("^%daylight-p" (values "~A" daylight-p 11)) - ("^%zone" (values "~D" zone 5)) - ("^%day" (values "~D" day 4)) - ("^%mon" (values "~D" mon 4)) - ("^%yr" (values "~D" yr 3)) - ("^%sec" (values "~D" sec 4)) - ("^%min" (values "~D" min 4)) - ("^%hr" (values "~D" hr 3)) - ("^%2day" (values "~2,'0D" day 5)) - ("^%2mon" (values "~2,'0D" mon 5)) - ("^%4yr" (values "~4,'0D" yr 4)) - ("^%2sec" (values "~2,'0D" sec 5)) - ("^%2min" (values "~2,'0D" min 5)) - ("^%2hr" (values "~2,'0D" hr 4))) - (when first-match-p - (format out (subseq date-control-string 0 start)) - (setf first-match-p nil)) - (if control - (progn - (format out control value) - (format out "~A" (subseq substring offset))) - (format out "~A" substring)))))))))) - - -(defun compute-journal-last-modified-date () - #-clisp (get-universal-time) - #+clisp - (loop for file in (list* *script-filename* ;; journal.cgi - (merge-pathnames (make-pathname :type "lisp") - *script-filename*) ;; journal.lisp - (find-journal-entry-files)) - maximize (posix:file-stat-mtime (posix:file-stat file)))) - - (defun link-to (action &key post-id (absolute nil)) (with-output-to-string (out) (format out "~A" (if absolute @@ -692,47 +321,3 @@ after another in any arbitrary order." :website ,website :body ,body)))) :stream out)))) - - -#+clisp -(defun main () - (let ((*journal-entries* (read-journal-entries)) - (*random-state* (make-random-state t))) - (ext:letf ((custom:*terminal-encoding* (ext:make-encoding - :charset charset:utf-8))) - (case *action* - (:post-comment (let ((entry (find-entry *post-number*))) - (push (make-instance 'journal-comment - :id (1+ (reduce #'max (comments-about entry) - :key #'id-of - :initial-value -1)) - :uuid (make-uuid) - :date (get-universal-time) - :author (getf *query* :author) - :email (getf *query* :email) - :website (getf *query* :website) - :body (getf *query* :comment-body)) - (comments-about entry)) - (write-out-entry entry)) - (show-web-journal)) - (:view-atom-feed (show-atom-feed)) - (otherwise (show-web-journal)))))) - - -#+clisp -(handler-bind - ((error #' - (lambda (e) - (declare (ignorable e)) - (<:html - (<:head - (<:title "Kompottkins Weisheiten: Fehler")) - (<:body - (<:h1 "Kompottkins Weisheiten: Fehlerbericht") - (<:p "Leider ist waehrend der Bearbeitung Ihrer Anfrage ein - Fehler aufgetreten. Wir bitten dies zu entschuldigen. - Ein detaillierter Fehlerbericht folgt.") - (<:pre (<:as-html (with-output-to-string (out) - #+clisp (system::pretty-print-condition e out) - #+clisp (system::print-backtrace :out out))))))))) - (main)) diff --git a/main.lisp b/main.lisp new file mode 100644 index 0000000..f27a989 --- /dev/null +++ b/main.lisp @@ -0,0 +1,110 @@ +;;;; -*- coding: utf-8; mode: lisp -*- +;;;; Copyright 2007, Matthias Andreas Benkard. + +;;;------------------------------------------------------------------------ +;;; This file is part of The Mulkblog Project. +;;; +;;; The Mulkblog Project is free software. You can redistribute it and/or +;;; modify it under the terms of the Affero General Public License as +;;; published by Affero, Inc.; either version 1 of the License, or +;;; (at your option) any later version. +;;; +;;; The Mulkblog Project is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty +;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the Affero General Public +;;; License in the COPYING file that comes with The Mulkblog Project; if +;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San +;;; Francisco, CA 94107 USA. +;;;------------------------------------------------------------------------ + +(in-package #:mulk.journal) + + +(defun call-with-initialised-journal (func) + (let* ((*site* (if (file-exists-p #p"/home/mulk") :mst-plus :nfs.net)) + (*debugging-p* (eq *site* :mst-plus)) + (*query* #+clisp (mapcan #'(lambda (param) + (list (keywordify param) + (ext:convert-string-from-bytes + (ext:convert-string-to-bytes + (http-query-parameter param) + charset:iso-8859-1) + charset:utf-8))) + (http-query-parameter-list)) + #-clisp '()) + (*http-env* (http-get-env-vars)) + (*subpath-query* (subseq (gethash "REQUEST_URI" *http-env*) + (length (if (eq *site* :mst-plus) + (gethash "SCRIPT_NAME" *http-env*) + "/journal")))) + (*subpath-string* (subseq *subpath-query* + 0 + (or (position #\? *subpath-query*) + (length *subpath-query*)))) + (*subpath* (split-sequence #\/ *subpath-string* + :remove-empty-subseqs t)) + (*post-number* (parse-integer (or (first *subpath*) + (getf *query* :id "")) + :junk-allowed t #|| :radix 12 ||#)) + (*action* (or (keywordify (getf *query* :action)) + (cond (*post-number* :view) + ((string= "feed" (first *subpath*)) :view-atom-feed) + (t nil)))) + (*method* (keywordify (gethash "REQUEST_METHOD" *http-env*))) + (*script-filename* (pathname-as-file + (or (gethash "SCRIPT_FILENAME" *http-env*) + "/home/mulk/Dokumente/Projekte/Mulkblog/journal.cgi"))) + (*journal-entries* (read-journal-entries))) + (funcall func))) + + +(defmacro with-initialised-journal (&body body) + `(call-with-initialised-journal #'(lambda () ,@body))) + + +#+clisp +(defun journal-main () + (with-initialised-journal + (let ((*random-state* (make-random-state t))) + (ext:letf ((custom:*terminal-encoding* (ext:make-encoding + :charset charset:utf-8))) + (case *action* + (:post-comment (let ((entry (find-entry *post-number*))) + (push (make-instance 'journal-comment + :id (1+ (reduce #'max (comments-about entry) + :key #'id-of + :initial-value -1)) + :uuid (make-uuid) + :date (get-universal-time) + :author (getf *query* :author) + :email (getf *query* :email) + :website (getf *query* :website) + :body (getf *query* :comment-body)) + (comments-about entry)) + (write-out-entry entry)) + (show-web-journal)) + (:view-atom-feed (show-atom-feed)) + (otherwise (show-web-journal))))))) + + +#+clisp +(defun cl-user::script-main () + (handler-bind + ((error #' + (lambda (e) + (declare (ignorable e)) + (<:html + (<:head + (<:title "Kompottkins Weisheiten: Fehler")) + (<:body + (<:h1 "Kompottkins Weisheiten: Fehlerbericht") + (<:p "Leider ist waehrend der Bearbeitung Ihrer Anfrage ein + Fehler aufgetreten. Wir bitten dies zu entschuldigen. + Ein detaillierter Fehlerbericht folgt.") + (<:pre (<:as-html (with-output-to-string (out) + #+clisp (system::pretty-print-condition e out) + #+clisp (system::print-backtrace :out out))))))))) + (journal-main))) diff --git a/mulk-journal.asd b/mulk-journal.asd new file mode 100644 index 0000000..3742d77 --- /dev/null +++ b/mulk-journal.asd @@ -0,0 +1,35 @@ +;;;; -*- coding: utf-8; mode: lisp -*- +;;;; Copyright 2007, Matthias Andreas Benkard. + +;;;------------------------------------------------------------------------ +;;; This file is part of The Mulkblog Project. +;;; +;;; The Mulkblog Project is free software. You can redistribute it and/or +;;; modify it under the terms of the Affero General Public License as +;;; published by Affero, Inc.; either version 1 of the License, or +;;; (at your option) any later version. +;;; +;;; The Mulkblog Project is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty +;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the Affero General Public +;;; License in the COPYING file that comes with The Mulkblog Project; if +;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San +;;; Francisco, CA 94107 USA. +;;;------------------------------------------------------------------------ + +(asdf:defsystem #:mulk-journal + :description "Matthias Benkard's simple web journal engine" + :licence "Affero General Public License, version 1 or higher" + :depends-on (#:cl-ppcre #:cl-fad #:iterate #:cl-markdown #:parenscript + #:yaclml #:lisp-cgi-utils #:alexandria #:xml-emitter + #:split-sequence) + :components ((:file "defpackage") + (:file "utils") + (:file "globals") + (:file "journal-content") + (:file "journal") + (:file "main")) + :serial t) diff --git a/run.lisp b/run.lisp new file mode 100755 index 0000000..df60d76 --- /dev/null +++ b/run.lisp @@ -0,0 +1,55 @@ +#! /usr/bin/env clisp +;;;; -*- coding: utf-8; mode: lisp -*- +;;;; Copyright 2007, Matthias Andreas Benkard. + +;;;------------------------------------------------------------------------ +;;; This file is part of The Mulkblog Project. +;;; +;;; The Mulkblog Project is free software. You can redistribute it and/or +;;; modify it under the terms of the Affero General Public License as +;;; published by Affero, Inc.; either version 1 of the License, or +;;; (at your option) any later version. +;;; +;;; The Mulkblog Project is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty +;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the Affero General Public +;;; License in the COPYING file that comes with The Mulkblog Project; if +;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San +;;; Francisco, CA 94107 USA. +;;;------------------------------------------------------------------------ + +(in-package #:cl-user) + +;;; TAKE NOTICE: If you want to run this script from the command line or +;;; from a web server, be sure to use a core image including the systems +;;; this script depends upon. The ASDF system definition has mainly +;;; been written for purposes of debugging, development and +;;; documentation. + + +(defclass load-source-simple-op (asdf:operation) ()) +(defmethod asdf:perform ((o load-source-simple-op) (c asdf:component)) + nil) +(defmethod asdf:perform ((o load-source-simple-op) (m asdf:module)) + (dolist (c (asdf:module-components m)) + (load (asdf:component-pathname c)))) + + +;;; The following does not generally work in a CGI setting because of +;;; security restrictions. Then again, loading all the dependencies +;;; individually rather than using a core image would certainly be too +;;; slow for any serious CGI usage, anyway, so what the heck. +(ignore-errors + (unless (asdf:find-system :mulk-journal nil) + (let ((*package* (find-package :asdf))) + (load "mulk-journal.asd"))) + + (unless (find-package '#:mulk.journal) + (asdf:oos 'load-source-simple-op '#:mulk-journal))) + + +#+clisp +(script-main) diff --git a/utils.lisp b/utils.lisp new file mode 100644 index 0000000..842bb0f --- /dev/null +++ b/utils.lisp @@ -0,0 +1,167 @@ +;;;; -*- coding: utf-8; mode: lisp -*- +;;;; Copyright 2007, Matthias Andreas Benkard. + +;;;------------------------------------------------------------------------ +;;; This file is part of The Mulkblog Project. +;;; +;;; The Mulkblog Project is free software. You can redistribute it and/or +;;; modify it under the terms of the Affero General Public License as +;;; published by Affero, Inc.; either version 1 of the License, or +;;; (at your option) any later version. +;;; +;;; The Mulkblog Project is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty +;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the Affero General Public +;;; License in the COPYING file that comes with The Mulkblog Project; if +;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San +;;; Francisco, CA 94107 USA. +;;;------------------------------------------------------------------------ + +(in-package #:mulk.journal) + + +(defun keywordify (thing) + (if (null thing) + thing + (intern (etypecase thing + (string (string-upcase thing)) + (symbol (symbol-name thing))) + '#:keyword))) + + +(defun make-uuid () + "Generate a version 4 UUID according to RFC 4122, section 4.4." + (format nil "~(~8,'0x-~4,'0x-~4,'0x-~2,'0x~2,'0x-~12,'0x~)" + (random #x100000000) ;; time_low + (random #x10000) ;; time_mid + (logior #b0100000000000000 + (logand #b0000111111111111 + (random #x10000))) ;; time_hi_and_version + (logior #b10000000 + (logand #b00111111 + (random #x100))) ;; clock_seq_hi_and_reserved + (random #x100) ;; clock_seq_low + (random #x1000000000000))) ;; node + + +(defun fixup-markdown-output (markup) + ;; No, cl-markdown is certainly not perfect. + ;; + ;; First, convert "<a ...> bla</a>" into " <a ...>bla</a>" (note the + ;; excess space to the right of the opening tag in the unprocessed + ;; string, which we move to the left of the same opening tag, where we + ;; expect it to make more sense in the general case). + (loop + for matches = (ppcre:all-matches "<a [^>]*?> " markup) + while (not (null matches)) + do (progn + (setf markup + (replace markup markup :start1 (1+ (first matches)) + :end1 (second matches) + :start2 (first matches) + :end2 (1- (second matches)))) + (setf (elt markup (first matches)) #\Space))) + markup) + + +(defun find-journal-entry-files () + (let ((directory + (make-pathname + :directory (pathname-directory + (merge-pathnames + (make-pathname :directory '(:relative "journal-entries") + :name nil) + *script-filename*)))) + (journal-entry-files (list))) + (when (file-exists-p directory) + (walk-directory directory + #'(lambda (x) + (push x journal-entry-files)) + :test (complement #'directory-pathname-p))) + journal-entry-files)) + + +(defun read-journal-entries () + (let ((journal-entry-files (find-journal-entry-files))) + (sort (mapcar #'read-journal-entry journal-entry-files) + #'>= + :key #'id-of))) + + +(defmacro regex-case (string &body clauses) + (once-only (string) + `(cond ,@(loop for (keys . forms) in clauses + collect + `(,(if (and (symbolp keys) + (or (eq t keys) + (equal "OTHERWISE" (symbol-name keys)))) + 't + `(or ,@(loop for key in (if (listp keys) + keys + (list keys)) + collect + `(ppcre:scan-to-strings ,key ,string)))) + ,@forms))))) + + +(defun name-of-day (day-of-week) + (case day-of-week + (0 "Montag") + (1 "Dienstag") + (2 "Mittwoch") + (3 "Donnerstag") + (4 "Freitag") + (5 "Samstag") + (6 "Sonntag"))) + + +(defun format-date (destination date-control-string universal-time + &optional (time-zone nil time-zone-supplied-p)) + "Format DATE according to the description given by DATE-FORMAT-STRING. + +Recognised format directives are: %day, %mon, %yr, %day-of-week, %zone, +%@day-of-week (name of day), %sec, %min, %hr, %daylight-p. + +Note that you can mix FORMAT and FORMAT-DATE painlessly by calling them +after another in any arbitrary order." + (format + destination "~A" + (with-output-to-string (out) + (multiple-value-bind (sec min hr day mon yr day-of-week daylight-p zone) + (if time-zone-supplied-p + (decode-universal-time universal-time time-zone) + (decode-universal-time universal-time)) + (let ((first-match-p t)) + (ppcre:do-matches (start end "%[^%]*" date-control-string) + (let ((substring (subseq date-control-string start end))) + (multiple-value-bind (control value offset) + (regex-case substring + ("^%day-of-week" (values "~D" day-of-week 12)) + ("^%@day-of-week" (values "~A" + (name-of-day day-of-week) + 13)) + ("^%daylight-p" (values "~A" daylight-p 11)) + ("^%zone" (values "~D" zone 5)) + ("^%day" (values "~D" day 4)) + ("^%mon" (values "~D" mon 4)) + ("^%yr" (values "~D" yr 3)) + ("^%sec" (values "~D" sec 4)) + ("^%min" (values "~D" min 4)) + ("^%hr" (values "~D" hr 3)) + ("^%2day" (values "~2,'0D" day 5)) + ("^%2mon" (values "~2,'0D" mon 5)) + ("^%4yr" (values "~4,'0D" yr 4)) + ("^%2sec" (values "~2,'0D" sec 5)) + ("^%2min" (values "~2,'0D" min 5)) + ("^%2hr" (values "~2,'0D" hr 4))) + (when first-match-p + (format out (subseq date-control-string 0 start)) + (setf first-match-p nil)) + (if control + (progn + (format out control value) + (format out "~A" (subseq substring offset))) + (format out "~A" substring)))))))))) |