summaryrefslogtreecommitdiff
path: root/main.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'main.lisp')
-rw-r--r--main.lisp110
1 files changed, 110 insertions, 0 deletions
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)))