Changeset 2424

Show
Ignore:
Timestamp:
01/30/08 14:02:24 (1 year ago)
Author:
hhubner
Message:

First session handling fixes.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r2045 r2424  
    169169      (write (n-blobs-per-directory subsystem) :stream s)))) 
    170170 
    171 (defun delete-orphaned-blob-files () 
     171(defun delete-orphaned-blob-files (&optional (cold-run t)) 
    172172  (dolist (blob-pathname (directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)) 
    173173                                                     (store-blob-root-pathname)))) 
    …… 
    178178            (labels ((delete-orphan (pathname) 
    179179                       (handler-case 
    180                            (delete-file pathname) 
     180                           (if cold-run 
     181                               (format t "cold run, not deleting ~A~%" pathname) 
     182                               (delete-file pathname)) 
    181183                         (error (e) 
    182184                           (warn "can't delete file ~A: ~A" pathname e))))) 

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

    r2417 r2424  
    2222(defmethod handle-object-form ((handler bug-tracker-handler) action tracker) 
    2323  (with-bknr-page (:title #?"bug-tracker for $((mailinglist-name tracker))") 
    24     (when (admin-p (bknr-request-user)) 
     24    (when (admin-p (bknr-session-user)) 
    2525      (html ((:a :href (format nil "/edit-bug-tracker/~a" (store-object-id tracker))) 
    2626             "edit bug-tracker"))) 
    …… 
    2828 
    2929(defmethod file-bug-report ((handler bug-tracker-handler) tracker) 
    30   (let ((user (bknr-request-user))) 
     30  (let ((user (bknr-session-user))) 
    3131    ;; XXX check user rights 
    3232    (with-query-params (name status priority description) 
    …… 
    5959(defmethod handle-object-form ((handler bug-report-handler) action report) 
    6060  (with-bknr-page (:title #?"bug-report") 
    61     (when (or (equal (bknr-request-user) 
     61    (when (or (equal (bknr-session-user) 
    6262                     (bug-report-handler report)) 
    63               (admin-p (bknr-request-user))) 
     63              (admin-p (bknr-session-user))) 
    6464      (html ((:a :href (format nil "/edit-bug-report/~a" (store-object-id report))) 
    6565             "edit bug-report"))) 
    …… 
    6969                               report) 
    7070  (if report 
    71       (let ((user (bknr-request-user))) 
     71      (let ((user (bknr-session-user))) 
    7272        (with-query-params (title text) 
    7373          (let ((article (make-object 'article 
    …… 
    115115                               (action (eql :save)) 
    116116                               tracker) 
    117   (if (admin-p (bknr-request-user)) 
     117  (if (admin-p (bknr-session-user)) 
    118118      (with-query-params (name email description) 
    119119        (change-slot-values tracker 'name name 'email email 'description description) 
    …… 
    145145                               (action (eql :save)) 
    146146                               report) 
    147   (if (or (admin-p (bknr-request-user)) 
    148           (equal (bknr-request-user) 
     147  (if (or (admin-p (bknr-session-user)) 
     148          (equal (bknr-session-user) 
    149149                 (bug-report-handler report))) 
    150150      (with-query-params (name status priority description) 
    …… 
    172172                               (action (eql :close)) 
    173173                               report) 
    174   (if (or (admin-p (bknr-request-user)) 
    175           (equal (bknr-request-user) 
     174  (if (or (admin-p (bknr-session-user)) 
     175          (equal (bknr-session-user) 
    176176                 (bug-report-handler report))) 
    177177      (progn 
    …… 
    188188                               (action (eql :reopen)) 
    189189                               report) 
    190   (if (or (admin-p (bknr-request-user)) 
    191           (equal (bknr-request-user) 
     190  (if (or (admin-p (bknr-session-user)) 
     191          (equal (bknr-session-user) 
    192192                 (bug-report-handler report))) 
    193193      (progn 
    …… 
    204204                               (action (eql :delete)) 
    205205                               report) 
    206   (if (or (admin-p (bknr-request-user)) 
    207           (equal (bknr-request-user) 
     206  (if (or (admin-p (bknr-session-user)) 
     207          (equal (bknr-session-user) 
    208208                 (bug-report-handler report))) 
    209209      (progn 
    …… 
    221221                               report) 
    222222  (if (or (null (bug-report-handler report)) 
    223           (admin-p (bknr-request-user))) 
    224       (progn 
    225         (change-slot-values report 'handler (bknr-request-user)) 
     223          (admin-p (bknr-session-user))) 
     224      (progn 
     225        (change-slot-values report 'handler (bknr-session-user)) 
    226226        (call-next-method)) 
    227227      (with-bknr-page (:title #?"Edit bug report") 

  • branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp

    r2417 r2424  
    107107      (let ((user (find-user email))) 
    108108        (if user 
    109             (if (admin-p (bknr-request-user)) 
     109            (if (admin-p (bknr-session-user)) 
    110110                (html-subscription-info user) 
    111111                (progn 

  • branches/trunk-reorg/bknr/modules/mail/register-handler.lisp

    r2417 r2424  
    110110                                     :subscribe-mailinglist mailinglist)) 
    111111                      (website-url (and mailinglist (mailinglist-website-url mailinglist)))) 
    112                  (if (admin-p (bknr-request-user)) 
     112                 (if (admin-p (bknr-session-user)) 
    113113                     (progn 
    114114                       (confirm-registration registration) 

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

    r2417 r2424  
    1616        (cond ((null tamagotchi) t) 
    1717              ((null (tamagotchi-owner tamagotchi)) t) 
    18               ((equal (bknr-request-user) (tamagotchi-owner tamagotchi)) t) 
     18              ((equal (bknr-session-user) (tamagotchi-owner tamagotchi)) t) 
    1919              (t nil))))) 
    2020 

  • branches/trunk-reorg/bknr/modules/text/article-handlers.lisp

    r2417 r2424  
    4242               (index-article article)) 
    4343        (setf article (make-object 'article 
    44                                    :author (bknr-request-user) 
     44                                   :author (bknr-session-user) 
    4545                                   :subject subject 
    4646                                   :text text))) 
    …… 
    105105        (expires (parse-date-field "expiration"))) 
    106106    (with-query-params (subject text layout) 
    107       (let ((snippet (make-object 'snippet :author (bknr-request-user) 
     107      (let ((snippet (make-object 'snippet :author (bknr-session-user) 
    108108                                  :subject (or subject "") 
    109109                                  :time (get-universal-time) 

  • branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp

    r2417 r2424  
    2020 
    2121(defun list-billboards-page () 
    22   (let ((may-edit (admin-p (bknr-request-user)))) 
     22  (let ((may-edit (admin-p (bknr-session-user)))) 
    2323    (with-bknr-page (:title "billboards") 
    2424      (html 
    …… 
    5454  (let ((billboard (parse-url))) 
    5555    (with-query-params (new show-all delete) 
    56       (let ((may-edit (admin-p (bknr-request-user)))) 
     56      (let ((may-edit (admin-p (bknr-session-user)))) 
    5757        (setf billboard (find-billboard (or billboard *default-billboard*))) 
    5858        (if delete 
    …… 
    6363            (if (and new may-edit) 
    6464                (let ((article (make-object 'article 
    65                                             :author (bknr-request-user)))) 
     65                                            :author (bknr-session-user)))) 
    6666                  (billboard-add-article billboard article) 
    6767                  (redirect (format nil "/edit-article/~a" (store-object-id article)))) 
    …… 
    7676                     for article in (billboard-articles billboard) 
    7777                     do (when (or show-all 
    78                                   (not (article-read article (bknr-request-user)))) 
     78                                  (not (article-read article (bknr-session-user)))) 
    7979                          (setf shown t) 
    8080                          (html 
    …… 
    107107                     (html 
    108108                      ((:input :type "submit" :name "show-all" :value "show-all")))) 
    109                    (when (admin-p (bknr-request-user)) 
     109                   (when (admin-p (bknr-session-user)) 
    110110                     (html 
    111111                      ((:input :type "submit" :name "new" :value "new")))))))))))) 

  • branches/trunk-reorg/bknr/modules/text/blog-handlers.lisp

    r2417 r2424  
    8686 
    8787(defmethod authorized-p ((handler edit-blog-handler)) 
    88   (let ((user (bknr-request-user)) 
     88  (let ((user (bknr-session-user)) 
    8989        (blog (object-handler-get-object handler))) 
    9090    (if blog 
    …… 
    116116        (let ((article (make-object 'blog-article 
    117117                                    :time (get-universal-time) 
    118                                     :author (bknr-request-user) 
     118                                    :author (bknr-session-user) 
    119119                                    :subject subject 
    120120                                    :text text 

  • branches/trunk-reorg/bknr/modules/text/paste-handlers.lisp

    r2417 r2424  
    4343    (if (and subject text) 
    4444        (let ((paste (make-object 'paste 
    45                                   :author (bknr-request-user) 
     45                                  :author (bknr-session-user) 
    4646                                  :subject subject 
    4747                                  :time (get-universal-time) 
    …… 
    6060      (with-query-params (text lisp) 
    6161        (let ((annotation (make-object 'keywords-article 
    62                                        :author (bknr-request-user) 
     62                                       :author (bknr-session-user) 
    6363                                       :subject "" 
    6464                                       :time (get-universal-time) 

  • branches/trunk-reorg/bknr/modules/text/wiki-handlers.lisp

    r2417 r2424  
    3535 
    3636(defmethod authorized-p ((handler edit-wiki-handler)) 
    37   (not (anonymous-p (bknr-request-user)))) 
     37  (not (anonymous-p (bknr-session-user)))) 
    3838 
    3939(defmethod handle-object-form ((handler edit-wiki-handler) 
    …… 
    5454    (let ((version (make-version (html-quote text) 
    5555                                 :comment (html-quote comment) 
    56                                  :author (bknr-request-user) 
     56                                 :author (bknr-session-user) 
    5757                                 :date (get-universal-time)))) 
    5858      (if article 

  • branches/trunk-reorg/bknr/modules/url/edit-url-handlers.lisp

    r2417 r2424  
    1010 
    1111(defmethod authorized-p ((handler form-handler)) 
    12   (not (equal (bknr-request-user) (find-user "anonymous")))) 
     12  (not (equal (bknr-session-user) (find-user "anonymous")))) 
    1313 
    1414#+(or) 
    …… 
    3636                    (ensure-form-field keywords) 
    3737                    (if (and cache 
    38                              (not (user-has-flag (bknr-request-user) :cache))) 
     38                             (not (user-has-flag (bknr-session-user) :cache))) 
    3939                        (error (make-condition 'form-not-authorized-condition 
    4040                                               :reason "You do not have the right to cache objects"))) 
    4141 
    4242                    (when cache 
    43                       (make-cached-url-from-url url :user (bknr-request-user) :depth 1 
     43                      (make-cached-url-from-url url :user (bknr-session-user) :depth 1 
    4444                                                :force nil)) 
    4545 
    …… 
    5656                                                     :keywords keywords 
    5757                                                     :date (get-universal-time) 
    58                                                      :submitter (bknr-request-user)))) 
     58                                                     :submitter (bknr-session-user)))) 
    5959                        (declare (ignore submission)) 
    6060                        (redirect (if redirect url "/url"))))) 

  • branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp

    r2417 r2424  
    8787      (with-query-params (name keyword) 
    8888        (let* ((image (import-image file-pathname 
    89                                     :user (bknr-request-user) 
     89                                    :user (bknr-session-user) 
    9090                                    :keywords (list keyword) 
    9191                                    :keywords-from-dir nil)) 

  • branches/trunk-reorg/bknr/web/src/images/import-images-handler.lisp

    r2417 r2424  
    3636    (import-directory spool-dir 
    3737                      :class-name class-name 
    38                       :user (bknr-request-user) 
     38                      :user (bknr-session-user) 
    3939                      :keywords keywords 
    4040                      :spool (import-handler-spool-dir handler) 

  • branches/trunk-reorg/bknr/web/src/packages.lisp

    r2420 r2424  
    379379    
    380380           #:host-name 
    381            #:bknr-request-user 
    382            #:bknr-request 
    383            #:bknr-request-session 
     381           #:bknr-session 
    384382           #:*session* 
    385383           #:anonymous-session 

  • branches/trunk-reorg/bknr/web/src/web/authorizer.lisp

    r2417 r2424  
    2020(defun session-from-request () 
    2121  "check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter" 
    22   (start-session) 
    2322  (session-value 'bknr-session)) 
    2423 
    …… 
    3534(defmethod authorize ((authorizer bknr-authorizer)) 
    3635  ;; Catch any errors that occur during request body processing 
    37   (start-session) 
    3836  (handler-case 
    3937      (when (session-value 'bknr-session) 

  • branches/trunk-reorg/bknr/web/src/web/event-log.lisp

    r2417 r2424  
    6363                      print-count)      ;; maximum number of events to print 
    6464    (when (and message (not (equal "" message))) 
    65       (make-event 'message-event :from (bknr-request-user) :text message)) 
     65      (make-event 'message-event :from (bknr-session-user) :text message)) 
    6666    ;; Parameter parsing, will move to with-query-params soon 
    6767    (if (and last-printed (not (equal "" last-printed))) 
    …… 
    7979                                       (list (find-class (find-symbol show-only-class (find-package "bknr"))))) 
    8080                                  (selected-classes (request-query)) 
    81                                   (mapcar #'find-class (get-user-preferences (bknr-request-user) :event-log-classes)) 
     81                                  (mapcar #'find-class (get-user-preferences (bknr-session-user) :event-log-classes)) 
    8282                                  (default-selected-classes)))) 
    8383        (unless show-only-class 
    84           (set-user-preferences (bknr-request-user) :event-log-classes (mapcar #'class-name selected-classes))) 
     84          (set-user-preferences (bknr-session-user) :event-log-classes (mapcar #'class-name selected-classes))) 
    8585        ;; selected-classes contains the list of event classes to print. 
    8686        (html 

  • branches/trunk-reorg/bknr/web/src/web/handlers.lisp

    r2420 r2424  
    156156  (html ((:div :id "session-info") 
    157157         "local time is " (:princ-safe (format-date-time)) 
    158          (if (bknr-request-user) 
    159              (html ", logged in as " (html-link (bknr-request-user))) 
     158         (if (bknr-session-user) 
     159             (html ", logged in as " (html-link (bknr-session-user))) 
    160160             (html ", not logged in"))))) 
    161161 
    …… 
    217217    (if (and require-user-flag 
    218218             (not (find require-user-flag 
    219                         (user-flags (bknr-request-user))))) 
     219                        (user-flags (bknr-session-user))))) 
    220220        nil 
    221221        t))) 
    222222 
    223223(defmethod invoke-handler ((handler page-handler)) 
     224  (start-session) 
     225  (unless (session-value 'bknr-session) 
     226    (setf (session-value 'bknr-session) 
     227          (make-instance 'bknr-session :user (find-user "anonymous")))) 
    224228  (let* ((*website* (page-handler-site handler)) 
    225          (*session* (bknr-request-session)) 
    226          (*user* (bknr-request-user)) 
    227229         (*req-var-hash* (or *req-var-hash* 
    228230                             (make-hash-table)))) 
    …… 
    412414 
    413415(defmethod authorized-p ((handler admin-only-handler)) 
    414   (admin-p (bknr-request-user))) 
     416  (admin-p (bknr-session-user))) 
    415417 
    416418(defclass xml-handler () 
    …… 
    488490 
    489491(defmethod import-handler-import-pathname ((handler import-handler)) 
    490   (let* ((user (bknr-request-user)) 
     492  (let* ((user (bknr-session-user)) 
    491493         (spool-dir (merge-pathnames (make-pathname 
    492494                                      :directory (list :relative (user-login user))) 

  • branches/trunk-reorg/bknr/web/src/web/sessions.lisp

    r2417 r2424  
    33(defclass bknr-session () 
    44  ((id :initarg :id :reader bknr-session-id :initform (get-universal-time)) 
    5    (user :initarg :user :reader bknr-session-user :initform nil) 
     5   (user :initarg :user) 
    66   (host :initarg :host :reader bknr-session-host :initform nil))) 
    77 
    88(defmethod print-object ((session bknr-session) stream) 
    99  (print-unreadable-object (session stream :type t :identity t) 
    10     (format stream "user ~A host ~A" (bknr-session-user session) (bknr-session-host session)) 
     10    (with-slots (user host) session 
     11      (format stream "user ~A host ~A" user host)) 
    1112    session)) 
    1213 
    13 (defmethod bknr-session-user ((user (eql nil))) 
    14   nil) 
     14(defun bknr-session () 
     15  (session-value 'bknr-session)) 
    1516 
    16 (defun bknr-request-user () 
    17   (bknr-session-user (session-value 'bknr-session))) 
    18  
    19 (defun bknr-request-session () 
    20   (session-value 'bknr-session)) 
     17(defun bknr-session-user () 
     18  (slot-value (bknr-session) 'user)) 
    2119 
    2220(defun do-log-request () 
    …… 
    2422  (return-from do-log-request) 
    2523  #+(or) 
    26   (let* ((session (bknr-request-session)) 
     24  (let* ((session (bknr-session)) 
    2725         (user (bknr-session-user session)) 
    2826         (host (bknr-session-host session)) 
    …… 
    4644  (format *debug-io* "Error: ~A~%" error) 
    4745  #+(or) 
    48   (let* ((session (bknr-request-session)) 
     46  (let* ((session (bknr-session)) 
    4947         (user (bknr-session-user session)) 
    5048         (host (bknr-session-host session)) 

  • branches/trunk-reorg/bknr/web/src/web/tags.lisp

    r2417 r2424  
    227227                       :text name))))) 
    228228  (when (and (website-admin-navigation *website*) 
    229              (admin-p (bknr-request-user))) 
     229             (admin-p (bknr-session-user))) 
    230230    (html ((:div :class "navi") 
    231231           "admin: " 

  • branches/trunk-reorg/bknr/web/src/web/user-handlers.lisp

    r2417 r2424  
    4040(defmethod authorized-p ((handler user-handler)) 
    4141  (let* ((user (object-handler-get-object handler)) 
    42          (web-user (bknr-request-user)) 
     42         (web-user (bknr-session-user)) 
    4343         (action (query-param "action")) 
    4444         (action-keyword (when action (make-keyword-from-string action)))) 
    …… 
    8888(defmethod handle-object-form ((handler user-handler) (action (eql :save)) user) 
    8989  (unless user 
    90     (setf user (bknr-request-user))) 
     90    (setf user (bknr-session-user))) 
    9191  (when user 
    9292    (with-query-params (password password-repeat 
    …… 
    9999      (change-slot-values user 'email email 'full-name full-name))) 
    100100 
    101   (when (admin-p (bknr-request-user)) 
     101  (when (admin-p (bknr-session-user)) 
    102102    (let* ((all-flags (all-user-flags)) 
    103103           (set-flags (keywords-from-query-param-list (query-param-list "flags"))) 
    …… 
    113113 
    114114(defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user) 
    115   (unless (admin-p (bknr-request-user)) 
     115  (unless (admin-p (bknr-session-user)) 
    116116    (error 'unauthorized-error)) 
    117117  (when user 

  • branches/trunk-reorg/projects/quickhoney/src/handlers.lisp

    r2417 r2424  
    7676(defmethod handle ((handler login-js-handler)) 
    7777  (format *html-stream* "parent.login_complete(~A, ~S);~%" 
    78           (if (admin-p (bknr-request-user)) "true" "false") 
    79           (user-login (bknr-request-user)))) 
     78          (if (admin-p (bknr-session-user)) "true" "false") 
     79          (user-login (bknr-session-user)))) 
    8080 
    8181(defclass clients-js-handler (javascript-handler page-handler) 

  • branches/trunk-reorg/projects/quickhoney/src/init.lisp

    r2419 r2424  
    33(defun startup () 
    44  (setq cxml::*default-catalog* '("/home/hans/share/xml/catalog")) 
     5  ;; XXX hack hack hack 
     6  (mapcar #'cl-gd::load-foreign-library 
     7          '("/usr/lib/libcrypto.so" "/usr/lib/libssl.so" "/usr/local/lib/libgd.so" "/home/hans/bknr-svn/thirdparty/cl-gd/cl-gd-glue.so")) 
    58  (when *store* 
    69    (close-store)) 

  • branches/trunk-reorg/projects/quickhoney/src/webserver.lisp

    r2419 r2424  
    33 
    44(enable-interpol-syntax) 
     5 
     6(defclass admin-handler (admin-only-handler page-handler) 
     7  ()) 
     8 
     9(defmethod handle ((handler admin-handler)) 
     10  (with-bknr-page (:title "CMS") 
     11    "Please choose an administration activity from the menu above")) 
    512 
    613;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
    …… 
    2431                                        ("/upload-button" upload-button-handler) 
    2532                                        ("/rss" rss-handler) 
     33                                        ("/admin" admin-handler) 
    2634                                        ("/" redirect-handler 
    2735                                         :to "/frontpage")