Changeset 2417

Show
Ignore:
Timestamp:
01/29/08 13:19:19 (1 year ago)
Author:
hhubner
Message:

Snapshot the port of the BKNR web framework to Hunchentoot.
In the process, the request argument that many of functions had has been
removed. Instead, the request is accessed through the dynamic environment,
which is the default mode for Hunchentoot.

This commit works with SBCL and cmucl, but I am now workin with SBCL as
Slime works way better there, in particular for debugging errors in
hunchentoot handlers.

All BKNR handlers are registered in the BKNR.WEB::*HANDLERS* special variable.
BKNR registers only one dispatcher in Hunchtentoots *DISPATCHER-TABLE* that
scans the BKNR handlers for a match. This is done to enhance debugability,
as the *HANDLERS* table contains PAGE-HANDLER objects that carry information
about their path etc.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/trunk-reorg/bknr/datastore/patches/patch-around-mop-cmucl19.lisp

    r1372 r2417  
    11;;; This patch fixes the problem with get-accessor-method-function 
    2 ;;; throwing an internal error in cmucl 19a. 
     2;;; throwing an internal error in cmucl 19 
    33;;; 
    44;;; Not yet in cmucl 

  • branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd

    r2212 r2417  
    1919    :depends-on (:cl-interpol :cl-ppcre 
    2020                              :md5 
     21                              :hunchentoot ; (for hunchentoot-mp package) 
    2122                              :iconv) 
    2223 

  • branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd

    r2226 r2417  
    1818    :depends-on (:cl-interpol :cxml) 
    1919    :components ((:module "xml" :components ((:file "package") 
    20                                             (:file "xml"))))) 
     20                                            (:file "xml" :depends-on ("package")))))) 
    2121 

  • branches/trunk-reorg/bknr/datastore/src/data/object.lisp

    r2289 r2417  
    3636 
    3737(deftransaction update-instances-for-changed-class (class) 
    38   (unless *suppress-schema-warnings* 
    39     (warn "updating ~A instances of ~A for class changes" (length (class-instances class)) class)) 
    40   (mapc #'reinitialize-instance (class-instances class))) 
     38  (let ((instance-count (length (class-instances class)))) 
     39    (when (plusp instance-count) 
     40      (unless *suppress-schema-warnings* 
     41        (warn "updating ~A instances of ~A for class changes" instance-count class)) 
     42      (mapc #'reinitialize-instance (class-instances class))))) 
    4143 
    4244(defmethod instance :after ((class persistent-class) &rest args) 

  • branches/trunk-reorg/bknr/datastore/src/data/package.lisp

    r2267 r2417  
    55        :bknr.indices :bknr.statistics 
    66        :closer-mop ) 
     7  #+cmu 
     8  (:shadowing-import-from :common-lisp #:subtypep #:typep) 
    79  (:shadowing-import-from :cl-interpol quote-meta-chars) 
    810  (:export #:*store-debug* 

  • branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp

    r1069 r2417  
    1919  (actor-stop actor) 
    2020  (setf (slot-value actor 'process) 
    21     (process-run-function 
    22         (bknr-actor-name actor) 
    23       #'(lambda () 
    24           (funcall #'run-function actor))))) 
     21    (mp:make-process (lambda () 
     22                       (funcall #'run-function actor)) 
     23                     :name (bknr-actor-name actor)))) 
    2524 
    2625(defmethod actor-running-p ((actor bknr-actor)) 
    2726  (and (slot-boundp actor 'process) 
    28        (process-active-p (bknr-actor-process actor)))) 
     27       (mp:process-active-p (bknr-actor-process actor)))) 
    2928 
    3029(defmethod actor-stop ((actor bknr-actor)) 
    3130  (when (slot-boundp actor 'process) 
    32     (process-kill (bknr-actor-process actor)) 
     31    (mp:destroy-process (bknr-actor-process actor)) 
    3332    (slot-makunbound actor 'process))) 

  • branches/trunk-reorg/bknr/datastore/src/utils/class.lisp

    r1375 r2417  
    66  (destructuring-bind (name access &rest rest) slot 
    77    (let* ((initarg (make-keyword-from-string (symbol-name name))) 
    8            (package (symbol-package class)) 
    98           (accessor (intern (concatenate 'string (symbol-name class) "-" 
    10                                           (symbol-name name)) package))) 
     9                                          (symbol-name name)) *package*))) 
    1110      (push initarg rest) 
    1211      (push :initarg rest) 

  • branches/trunk-reorg/bknr/datastore/src/utils/package.lisp

    r2210 r2417  
    5555           #:find-all 
    5656           #:genlist 
     57           #+no-alexandria 
    5758           #:rotate 
    5859           #:nrotate 
    …… 
    6768 
    6869           ;; randomize 
     70           #+no-alexandria 
    6971           #:random-elt 
    7072           #:random-elts 

  • branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp

    r2210 r2417  
    284284    (apply #'values sum hash-tables))) 
    285285 
     286#+no-alexandria 
    286287(defun rotate (list) 
    287288  (when list 
    …… 
    351352  l) 
    352353 
     354#+no-alexandria 
    353355(defun random-elt (choices) 
    354356  (when choices 

  • branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp

    r2226 r2417  
    33(defpackage :bknr.impex 
    44  (:use :cl 
    5         #+clisp 
    6         :ext 
    7         :cl-user 
    85        :cxml 
    96        :closer-mop 
    …… 
    118        :bknr.xml 
    129        :bknr.indices) 
     10  #+cmu 
     11  (:shadowing-import-from :common-lisp #:subtypep #:typep) 
    1312 
    1413  (:export #:xml-class 

  • branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp

    r2226 r2417  
    1313  `(let ((*objects-written* (make-hash-table :test #'equal)) 
    1414         (cxml::*current-element* nil) 
    15          (cxml::*sink* (cxml:make-character-stream-sink ,output 
    16                                                         :indentation ,indentation :canonical ,canonical))) 
     15         (cxml::*sink* #+(or) (cxml:make-character-stream-sink ,output 
     16                                                              :indentation ,indentation :canonical ,canonical))) 
    1717     ,@body)) 
    1818 

  • branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp

    r2226 r2417  
    1919 
    2020(defun node-attribute (xml attribute-name) 
    21   (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) 
     21  (cadr (assoc attribute-name (node-attrs xml) :test #'equal))) 
    2222 
    2323(defun node-child-string-body (xml node-name) 

  • branches/trunk-reorg/bknr/modules/album/album.lisp

    r1565 r2417  
    3333  ()) 
    3434 
    35 (defmethod handle ((handler album-handler) req) 
     35(defmethod handle ((handler album-handler)) 
    3636  (multiple-value-bind (username album) 
    37       (parse-handler-url handler req) 
     37      (parse-handler-url handler) 
    3838    (let ((user (when username (find-user username)))) 
    3939      (cond ((and user album) 
    40              (with-bknr-page (req :title #?"${username} : ${album}") 
     40             (with-bknr-page (:title #?"${username} : ${album}") 
    4141               (album :username username :album album))) 
    4242            (user 
    43              (with-bknr-page (req :title #?"${username}'s albums") 
     43             (with-bknr-page (:title #?"${username}'s albums") 
    4444               (user-albums :username username))) 
    45             (t (with-bknr-page (req :title "No such album") 
     45            (t (with-bknr-page (:title "No such album") 
    4646                 (:h2 "No such album"))))))) 
    4747 

  • branches/trunk-reorg/bknr/modules/bknr-modules.asd

    r2227 r2417  
    1818                 :cl-ppcre 
    1919                 :cl-gd 
    20                  :aserve 
    21                  :net.post-office 
    2220                 :md5 
     21                 :closer-mop 
     22                 :cl-smtp 
    2323                 :cxml 
    2424                 :unit-test 
    …… 
    2626                 :puri 
    2727                 :stem 
    28                  :bknr 
    29                  :acl-compat) 
     28                 :bknr-web 
     29                 :parenscript) 
    3030 
    3131    :components ((:file "packages") 
    …… 
    4646                                              (:file "blog" 
    4747                                                     :depends-on ("article" "vector-search")) 
     48                                              #+(or) 
    4849                                              (:file "billboard" 
    4950                                                     :depends-on  ("article")) 
    …… 
    5455                                              (:file "blog-handlers" 
    5556                                                     :depends-on ("blog" "article-tags" "article-handlers")) 
     57                                              #+(or) 
    5658                                              (:file "billboard-handlers" 
    5759                                                     :depends-on ("billboard" "article-tags")) 
    …… 
    6567                          :depends-on ("packages")) 
    6668 
     69                 #+(or) 
    6770                 (:module "feed" :components ((:file "feed") 
    6871                                              (:file "feed-tags" 
    …… 
    131134                          :depends-on ("general" "web" "packages")) 
    132135 
     136                 #+(or) 
    133137                 (:module "track" :components ((:file "track") 
    134138                                               (:file "media" 
    …… 
    145149                          :depends-on ("packages")) 
    146150 
     151                 #+(or) 
    147152                 (:module "comics" :components ((:file "comics")))) 
    148153                          :depends-on ("packages")) 

  • branches/trunk-reorg/bknr/modules/bug/bug-handlers.lisp

    r1565 r2417  
    66  ()) 
    77 
    8 (defmethod object-handler-get-object ((hander bug-tracker-handler) req) 
    9   (let ((id-or-name (parse-url req))) 
     8(defmethod object-handler-get-object ((hander bug-tracker-handler)) 
     9  (let ((id-or-name (parse-url))) 
    1010    (when id-or-name 
    1111      (find-store-object id-or-name :class 'bug-tracker)))) 
    1212 
    13 (defmethod handle-object-form ((handler bug-tracker-handler) action (tracker (eql nil)) req) 
     13(defmethod handle-object-form ((handler bug-tracker-handler) action (tracker (eql nil))) 
    1414  (let ((bug-trackers (all-bug-trackers))) 
    15     (with-bknr-page (req :title "Bug trackers") 
     15    (with-bknr-page (:title "Bug trackers") 
    1616      (:h2 "all bug-trackers") 
    1717      (:ul (dolist (bug-tracker bug-trackers) 
    …… 
    2020                         (:princ-safe (mailinglist-name bug-tracker)))))))))) 
    2121 
    22 (defmethod handle-object-form ((handler bug-tracker-handler) action tracker req) 
    23   (with-bknr-page (req :title #?"bug-tracker for $((mailinglist-name tracker))") 
    24     (when (admin-p (bknr-request-user req)) 
     22(defmethod handle-object-form ((handler bug-tracker-handler) action tracker) 
     23  (with-bknr-page (:title #?"bug-tracker for $((mailinglist-name tracker))") 
     24    (when (admin-p (bknr-request-user)) 
    2525      (html ((:a :href (format nil "/edit-bug-tracker/~a" (store-object-id tracker))) 
    2626             "edit bug-tracker"))) 
    2727    (bug-tracker-page :bug-tracker-id (store-object-id tracker)))) 
    2828 
    29 (defmethod file-bug-report ((handler bug-tracker-handler) tracker req) 
    30   (let ((user (bknr-request-user req))) 
     29(defmethod file-bug-report ((handler bug-tracker-handler) tracker) 
     30  (let ((user (bknr-request-user))) 
    3131    ;; XXX check user rights 
    32     (with-query-params (req name status priority description) 
     32    (with-query-params (name status priority description) 
    3333      (let ((bug-report (make-object 'bug-report 
    3434                                     :tracker tracker 
    …… 
    4242 
    4343(defmethod handle-object-form ((handler bug-tracker-handler) (action (eql :create-bug-report)) 
    44                                tracker req) 
    45   (let ((bug-report (file-bug-report handler tracker req))) 
    46     (redirect (format nil "/bug-report/~a" (store-object-id bug-report)) req))) 
     44                               tracker) 
     45  (let ((bug-report (file-bug-report handler tracker))) 
     46    (redirect (format nil "/bug-report/~a" (store-object-id bug-report))))) 
    4747 
    4848(defclass bug-report-handler (edit-object-handler) 
    4949  ()) 
    5050 
    51 (defmethod object-handler-get-object ((handler bug-report-handler) req) 
    52   (let ((id-or-name (parse-url req))) 
     51(defmethod object-handler-get-object ((handler bug-report-handler)) 
     52  (let ((id-or-name (parse-url))) 
    5353    (when id-or-name 
    5454      (find-store-object id-or-name :class 'bug-report)))) 
    5555 
    56 (defmethod handle-object-form ((handler bug-report-handler) action (report (eql nil)) req) 
    57   (redirect "/bug-tracker" req)) 
    58  
    59 (defmethod handle-object-form ((handler bug-report-handler) action report req) 
    60   (with-bknr-page (req :title #?"bug-report") 
    61     (when (or (equal (bknr-request-user req) 
     56(defmethod handle-object-form ((handler bug-report-handler) action (report (eql nil))) 
     57  (redirect "/bug-tracker")) 
     58 
     59(defmethod handle-object-form ((handler bug-report-handler) action report) 
     60  (with-bknr-page (:title #?"bug-report") 
     61    (when (or (equal (bknr-request-user) 
    6262                     (bug-report-handler report)) 
    63               (admin-p (bknr-request-user req))) 
     63              (admin-p (bknr-request-user))) 
    6464      (html ((:a :href (format nil "/edit-bug-report/~a" (store-object-id report))) 
    6565             "edit bug-report"))) 
    …… 
    6767 
    6868(defmethod handle-object-form ((handler bug-report-handler) (action (eql :annotate)) 
    69                                report req) 
     69                               report) 
    7070  (if report 
    71       (let ((user (bknr-request-user req))) 
    72         (with-query-params (req title text) 
     71      (let ((user (bknr-request-user))) 
     72        (with-query-params (title text) 
    7373          (let ((article (make-object 'article 
    7474                                      :author user 
    …… 
    7878                (bug-report-add-annotation report article) 
    7979                (delete-object article)) 
    80             (handle-object-form handler nil report req)))) 
    81       (handle-object-form handler nil report req))) 
     80            (handle-object-form handler nil report)))) 
     81      (handle-object-form handler nil report))) 
    8282 
    8383(defclass edit-bug-tracker-handler (bug-tracker-handler) 
    …… 
    8585 
    8686(defmethod handle-object-form ((handler edit-bug-tracker-handler) action 
    87                                (bug-tracker (eql nil)) req) 
     87                               (bug-tracker (eql nil))) 
    8888  (let ((bug-trackers (all-bug-trackers))) 
    89     (with-bknr-page (req :title "Bug trackers") 
     89    (with-bknr-page (:title "Bug trackers") 
    9090      (:h2 "all bug-trackers") 
    9191      (:ul (dolist (bug-tracker bug-trackers) 
    …… 
    9797 
    9898(defmethod handle-object-form ((handler edit-bug-tracker-handler) 
    99                                (action (eql :create)) bug-tracker req) 
    100   (with-query-params (req name email description) 
     99                               (action (eql :create)) bug-tracker) 
     100  (with-query-params (name email description) 
    101101    (if (and name email) 
    102102        (let ((bug-tracker (make-object 'bug-tracker 
    …… 
    104104                                        :email email 
    105105                                        :description description))) 
    106           (redirect (format nil "/edit-bug-tracker/~a" (store-object-id bug-tracker)) req)) 
    107         (handle-object-form handler nil nil req)))) 
     106          (redirect (format nil "/edit-bug-tracker/~a" (store-object-id bug-tracker)))) 
     107        (handle-object-form handler nil nil)))) 
    108108 
    109109(defmethod handle-object-form ((handler edit-bug-tracker-handler) (action (eql :create-bug-report)) 
    110                                tracker req) 
    111   (file-bug-report handler tracker req) 
    112   (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)) req)) 
     110                               tracker) 
     111  (file-bug-report handler tracker) 
     112  (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)))) 
    113113 
    114114(defmethod handle-object-form ((handler edit-bug-tracker-handler) 
    115115                               (action (eql :save)) 
    116                                tracker req) 
    117   (if (admin-p (bknr-request-user req)) 
    118       (with-query-params (req name email description) 
     116                               tracker) 
     117  (if (admin-p (bknr-request-user)) 
     118      (with-query-params (name email description) 
    119119        (change-slot-values tracker 'name name 'email email 'description description) 
    120120        (call-next-method)) 
    121       (with-bknr-page (req :title #?"Edit bug tracker") 
     121      (with-bknr-page (:title #?"Edit bug tracker") 
    122122        (:p "You are not authorized to edit this bug tracker") 
    123123        ((:a :href "/bug-tracker") "return to bug-tracker page")))) 
    124124 
    125125(defmethod handle-object-form ((handler edit-bug-tracker-handler) action 
    126                                bug-tracker req) 
    127   (with-bknr-page (req :title #?"Edit bug tracker: $((mailinglist-name bug-tracker))") 
     126                               bug-tracker) 
     127  (with-bknr-page (:title #?"Edit bug tracker: $((mailinglist-name bug-tracker))") 
    128128    (bug-tracker-form :bug-tracker-id (store-object-id bug-tracker)))) 
    129129 
    …… 
    132132 
    133133(defmethod handle-object-form ((handler edit-bug-report-handler) 
    134                                action (bug-report (eql nil)) req) 
    135   (redirect "/edit-bug-tracker" req)) 
    136  
    137 (defmethod handle-object-form ((handler edit-bug-report-handler) 
    138                                action bug-report req) 
    139   (with-bknr-page (req :title #?"Edit bug report") 
     134                               action (bug-report (eql nil))) 
     135  (redirect "/edit-bug-tracker")) 
     136 
     137(defmethod handle-object-form ((handler edit-bug-report-handler) 
     138                               action bug-report) 
     139  (with-bknr-page (:title #?"Edit bug report") 
    140140    (if bug-report 
    141141        (bug-form :bug-id (store-object-id bug-report)) 
    142         (redirect "/edit-bug-tracker" req)))) 
     142        (redirect "/edit-bug-tracker")))) 
    143143 
    144144(defmethod handle-object-form ((handler edit-bug-report-handler) 
    145145                               (action (eql :save)) 
    146                                report req) 
    147   (if (or (admin-p (bknr-request-user req)) 
    148           (equal (bknr-request-user req) 
    149                  (bug-report-handler report))) 
    150       (with-query-params (req name status priority description) 
     146                               report) 
     147  (if (or (admin-p (bknr-request-user)) 
     148          (equal (bknr-request-user) 
     149                 (bug-report-handler report))) 
     150      (with-query-params (name status priority description) 
    151151        (let ((status-kw   (make-keyword-from-string status)) 
    152152              (priority-kw (make-keyword-from-string priority))) 
    …… 
    164164                                  'last-modified (get-universal-time))) 
    165165          (call-next-method))) 
    166       (with-bknr-page (req :title #?"Edit bug report") 
     166      (with-bknr-page (:title #?"Edit bug report") 
    167167        (:p "You are not the handler of this bug report") 
    168168        ((:a :href (format nil "/bug-report/~a" (store-object-id report))) 
    …… 
    171171(defmethod handle-object-form ((handler edit-bug-report-handler) 
    172172                               (action (eql :close)) 
    173                                report req) 
    174   (if (or (admin-p (bknr-request-user req)) 
    175           (equal (bknr-request-user req) 
     173                               report) 
     174  (if (or (admin-p (bknr-request-user)) 
     175          (equal (bknr-request-user) 
    176176                 (bug-report-handler report))) 
    177177      (progn 
    …… 
    180180                            'last-modified (get-universal-time)) 
    181181        (call-next-method)) 
    182       (with-bknr-page (req :title #?"Edit bug report") 
     182      (with-bknr-page (:title #?"Edit bug report") 
    183183        (:p "You are not the handler of this bug report") 
    184184        ((:a :href (format nil "/bug-report/~a" (store-object-id report))) 
    …… 
    187187(defmethod handle-object-form ((handler edit-bug-report-handler) 
    188188                               (action (eql :reopen)) 
    189                                report req) 
    190   (if (or (admin-p (bknr-request-user req)) 
    191           (equal (bknr-request-user req) 
     189                               report) 
     190  (if (or (admin-p (bknr-request-user)) 
     191          (equal (bknr-request-user) 
    192192                 (bug-report-handler report))) 
    193193      (progn 
    …… 
    196196                            'last-modified (get-universal-time)) 
    197197        (call-next-method)) 
    198       (with-bknr-page (req :title #?"Edit bug report") 
     198      (with-bknr-page (:title #?"Edit bug report") 
    199199        (:p "You are not the handler of this bug report") 
    200200        ((:a :href (format nil "/bug-report/~a" (store-object-id report))) 
    …… 
    203203(defmethod handle-object-form ((handler edit-bug-report-handler) 
    204204                               (action (eql :delete)) 
    205                                report req) 
    206   (if (or (admin-p (bknr-request-user req)) 
    207           (equal (bknr-request-user req) 
     205                               report) 
     206  (if (or (admin-p (bknr-request-user)) 
     207          (equal (bknr-request-user) 
    208208                 (bug-report-handler report))) 
    209209      (progn 
    …… 
    211211          (bug-tracker-remove-bug-report tracker report) 
    212212          (delete-object report) 
    213           (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)) req)) 
    214       (with-bknr-page (req :title #?"Edit bug report") 
     213          (redirect (format nil "/edit-bug-tracker/~a" (store-object-id tracker)))) 
     214      (with-bknr-page (:title #?"Edit bug report") 
    215215        (:p "You are not the handler of this bug report") 
    216216        ((:a :href (format nil "/bug-report/~a" (store-object-id report))) 
    …… 
    219219(defmethod handle-object-form ((handler edit-bug-report-handler) 
    220220                               (action (eql :handle)) 
    221                                report req) 
     221                               report) 
    222222  (if (or (null (bug-report-handler report)) 
    223           (admin-p (bknr-request-user req))) 
    224       (progn 
    225         (change-slot-values report 'handler (bknr-request-user req)) 
    226         (call-next-method)) 
    227       (with-bknr-page (req :title #?"Edit bug report") 
     223          (admin-p (bknr-request-user))) 
     224      (progn 
     225        (change-slot-values report 'handler (bknr-request-user)) 
     226        (call-next-method)) 
     227      (with-bknr-page (:title #?"Edit bug report") 
    228228        (:p "You can not become the handler of this bug report") 
    229229        ((:a :href (format nil "/bug-report/~a" (store-object-id report))) 

  • branches/trunk-reorg/bknr/modules/class-browser/class-browser.lisp

    r2045 r2417  
    55  (:default-initargs :default-package-name nil)) 
    66    
    7 (defmethod object-handler-get-object ((handler class-browser-handler) req) 
     7(defmethod object-handler-get-object ((handler class-browser-handler)) 
    88  (destructuring-bind (class-name &optional (package-name (slot-value handler 'default-package-name))) 
    9       (mapcar #'string-upcase (reverse (split "::" (parse-url req)))) 
     9      (mapcar #'string-upcase (reverse (split "::" (parse-url)))) 
    1010    (find-class (find-symbol class-name (find-package package-name)) nil))) 
    1111 
    12 (defmethod handle-object ((handler class-browser-handler) (class (eql nil)) req) 
    13   (user-error "Invalid class name ~A" (parse-url req))) 
     12(defmethod handle-object ((handler class-browser-handler) (class (eql nil))) 
     13  (user-error "Invalid class name ~A" (parse-url))) 
    1414 
    15 (defmethod handle-object ((handler class-browser-handler) class req) 
    16   (with-http-response (req *e