summaryrefslogtreecommitdiff
path: root/journal.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'journal.lisp')
-rwxr-xr-xjournal.lisp419
1 files changed, 2 insertions, 417 deletions
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))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 08:11:01 +0000