Use URI subpaths instead of query strings.

darcs-hash:80a76a4a6eabc05f9766796bdf0b779fc78ec4d3

3 files changed, 76 insertions, 36 deletions

diff --git a/journal.lisp b/journal.lisp
index 9042b62..9753cf7 100755
--- a/journal.lisp
+++ b/journal.lisp
@@ -30,20 +30,22 @@
   :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))
+                #:yaclml #:lisp-cgi-utils #:alexandria #:xml-emitter
+                #:split-sequence))
 
 
 ;;; The following does not generally work in a CGI setting because of
 ;;; security restrictions.  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.
-#+nil (asdf:oos 'asdf:load-op '#:mulk.journal)
+(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))
+        #:xml-emitter #:split-sequence))
 
 (in-package #:mulk.journal)
 
@@ -57,6 +59,13 @@
               '#: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)
@@ -70,17 +79,45 @@
   #-clisp '()
   "The HTTP query string transformed into a property list.")
 
-(defparameter *action*
-  (keywordify (getf *query* :action))
-  "One of NIL, :INDEX, :VIEW-ATOM-FEED, :VIEW, :POST, :EDIT, :PREVIEW,
-   and :POST-COMMENT.")
+(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 (getf *query* :id "")
+  (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.")
@@ -89,10 +126,6 @@
   '()
   "A list of JOURNAL-ENTRY objects.")
 
-(defparameter *http-env*
-  (http-get-env-vars)
-  "A hash table of HTTP environment variables.")
-
 
 (defclass journal-entry ()
   ((id :type (integer 0)
@@ -344,18 +377,23 @@ after another in any arbitrary order."
 
 (defun link-to (action &key post-id (absolute nil))
   (with-output-to-string (out)
-    (format out (if absolute
-                    "http://benkard.nfshost.com/journal/journal.cgi"
-                    "journal.cgi"))
-
+    (format out "~A" (if absolute
+                         "http://matthias.benkard.de/journal"
+                         ;; When testing on the local webserver, don't
+                         ;; use /journal as a relative URI, because it
+                         ;; won't work.
+                         (if (search ".cgi"
+                                     (gethash "REQUEST_URI" *http-env* ""))
+                             (gethash "SCRIPT_NAME" *http-env* "")
+                             "/journal")))
     (multiple-value-call
         #'(lambda (&rest args) (apply #'format out args))
       (case action
         (:index "")
-        (:view-atom-feed (values "?action=view-atom-feed"))
-        (:view (values "?action=view&id=~D" post-id))
-        (:edit (values "?action=edit&id=~D" post-id))
-        (:post-comment (values "?action=view&id=~D" post-id))))))
+        (:view-atom-feed (values "/feed"))
+        (:view (values "/~D" post-id))
+        (:edit (values "/~D?action=edit" post-id))
+        (:post-comment (values "/~D" post-id))))))
 
 
 (defun show-atom-feed ()
@@ -410,9 +448,9 @@ after another in any arbitrary order."
                                   ("href" ,(link-to :view
                                                     :post-id id
                                                     :absolute t)))))
-              (with-tag ("content" '(("type" "xhtml")
+              (with-tag ("content" `(("type" "xhtml")
                                      ("xml:lang" "de")
-                                     ("xml:base" "http://benkard.nfshost.com/journal")))
+                                     ("xml:base" ,(link-to :index :absolute t))))
                 (with-tag ("div" '(("xmlns" "http://www.w3.org/1999/xhtml")))
                   (xml-as-is (journal-markup->html (body-of journal-entry))))))))))))
 
@@ -587,17 +625,18 @@ after another in any arbitrary order."
     (<:div :id :navigation))
 
 
-    #+debug
-    (loop for (x . y) in `(("Action" . ,*action*)
-                           ("Request method" . ,*method*)
-                           ("Query" . ,*query*)
-                           ("Query string" . ,(http-get-query-string))
-                           ("Environment" . ,(http-get-env-vars)))
-       do (<:p
-           (<:hr)
-           (<:h2 (<:as-html x))
-           (<:p "Type " (<:em (<:as-html (type-of y))) ".")
-           (<:pre (<:as-html (prin1-to-string y)))))))
+    (when *debugging-p*
+      (loop for (x . y) in `(("Action" . ,*action*)
+                             ("Request method" . ,*method*)
+                             ("Query" . ,*query*)
+                             ("Query string" . ,(http-get-query-string))
+                             ("Subpath" . ,*subpath*)
+                             ("Environment" . ,(http-get-env-vars)))
+         do (<:p
+             (<:hr)
+             (<:h2 (<:as-html x))
+             (<:p "Type " (<:em (<:as-html (type-of y))) ".")
+             (<:pre (<:as-html (prin1-to-string y))))))))
 
 
 (defun write-out-entry (entry)
diff --git a/make-clisp-package.sh b/make-clisp-package.sh
index b254b62..c3f094e 100755
--- a/make-clisp-package.sh
+++ b/make-clisp-package.sh
@@ -1,5 +1,5 @@
 #! /bin/sh
 cd ~
-for x in Downloads/Darcs/{metabang-bind,iterate,cl-markdown,cl-containers,defsystem-compatibility,alexandria,lw-compat,moptilities,metatilities,Bese/arnesi_dev,Bese/yaclml,asdf-system-connections,closer-mop,parenscript} .clc/site/{xml-emitter-1.0.2,lisp-cgi-utils-0.9,cl-utilities-1.2.4} /usr/share/common-lisp/source/{asdf,cl-fad,cl-ppcre,slime}; do
+for x in Downloads/Darcs/{metabang-bind,iterate,cl-markdown,cl-containers,defsystem-compatibility,alexandria,lw-compat,moptilities,metatilities,Bese/arnesi_dev,Bese/yaclml,asdf-system-connections,closer-mop,parenscript} .clc/site/{xml-emitter-1.0.2,lisp-cgi-utils-0.9,cl-utilities-1.2.4} /usr/share/common-lisp/source/{asdf,cl-fad,cl-ppcre,slime,split-sequence}; do
 	find "$x" -not -regex ".*/_darcs/.*" \( -regex ".*\\.lisp" -or -regex ".*\\.asd" \)
-done | tar -T - -cjf - | ssh mulk_benkard@ssh.phx.nearlyfreespeech.net 'mkdir -p /tmp/clisp-stuff && cd /tmp/clisp-stuff && tar xjf - && mkdir -p /tmp/asdf && cd /tmp/asdf && find ../clisp-stuff -name "*.asd" | xargs -I "{}" ln -sf "{}" . && cd ../clisp-stuff && mkdir -p /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/images && touch /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/index.lml && clisp -x "(load \"usr/share/common-lisp/source/asdf/asdf.lisp\")" -x "(let ((asdf:*central-registry* (quote (#p\"/tmp/asdf/\")))) (dolist (x (list :cl-ppcre :cl-fad :iterate :cl-markdown :parenscript :yaclml :lisp-cgi-utils :alexandria :xml-emitter)) (asdf:oos (quote asdf:load-op) x)) (saveinitmem \"lispinit.mem\"))" && gzip -f lispinit.mem && mv lispinit.mem.gz /home/private/ && rm -rf /tmp/clisp-stuff && rm -rf /tmp/asdf'
+done | tar -T - -cjf - | ssh mulk_benkard@ssh.phx.nearlyfreespeech.net 'mkdir -p /tmp/clisp-stuff && cd /tmp/clisp-stuff && tar xjf - && mkdir -p /tmp/asdf && cd /tmp/asdf && find ../clisp-stuff -name "*.asd" | xargs -I "{}" ln -sf "{}" . && cd ../clisp-stuff && mkdir -p /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/images && touch /home/tmp/clisp-stuff/Downloads/Darcs/asdf-system-connections/website/source/index.lml && clisp -x "(load \"usr/share/common-lisp/source/asdf/asdf.lisp\")" -x "(let ((asdf:*central-registry* (quote (#p\"/tmp/asdf/\")))) (dolist (x (list :cl-ppcre :cl-fad :iterate :cl-markdown :parenscript :yaclml :lisp-cgi-utils :alexandria :xml-emitter :split-sequence)) (asdf:oos (quote asdf:load-op) x)) (saveinitmem \"lispinit.mem\"))" && gzip -f lispinit.mem && mv lispinit.mem.gz /home/private/ && rm -rf /tmp/clisp-stuff && rm -rf /tmp/asdf'
diff --git a/make-core-image.sh b/make-core-image.sh
index 1c65f35..28cbb9a 100755
--- a/make-core-image.sh
+++ b/make-core-image.sh
@@ -1,7 +1,8 @@
 #! /bin/sh
 clisp -q -q -on-error exit <<EOF
 (dolist (system '(:cl-ppcre :cl-fad :iterate :cl-markdown :parenscript
-                  :yaclml :lisp-cgi-utils :alexandria :xml-emitter))
+                  :yaclml :lisp-cgi-utils :alexandria :xml-emitter
+                  :split-sequence))
   (clc:clc-require system))
 (saveinitmem "lispinit.mem")
 (quit)