summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-06-30 21:32:02 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-06-30 21:32:02 +0200
commitc74c449d11281c942965ca85d84c59b9107e4521 (patch)
tree2883b565a5ac35e068b5e4fbb6ee23591f5d701c
parent6ac73d81cbf82be95179fb30bd7902bce8955525 (diff)
Split journal.lisp into multiple files.
darcs-hash:5621824874dbddcf61282b66c975266d16d1fa6f
-rw-r--r--defpackage.lisp26
-rw-r--r--globals.lisp64
-rw-r--r--journal-content.lisp153
-rwxr-xr-xjournal.cgi2
-rwxr-xr-xjournal.lisp419
-rw-r--r--main.lisp110
-rw-r--r--mulk-journal.asd35
-rwxr-xr-xrun.lisp55
-rw-r--r--utils.lisp167
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))))))))))