[Lisppaste-cvs] CVS update: lisppaste2/web-server.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Fri May 21 21:29:11 UTC 2004
Update of /project/lisppaste/cvsroot/lisppaste2
In directory common-lisp.net:/home/bmastenbrook/lisppaste2
Modified Files:
web-server.lisp
Log Message:
pagination (woot!)
Date: Fri May 21 17:29:11 2004
Author: bmastenbrook
Index: lisppaste2/web-server.lisp
diff -u lisppaste2/web-server.lisp:1.46 lisppaste2/web-server.lisp:1.47
--- lisppaste2/web-server.lisp:1.46 Fri May 21 12:42:38 2004
+++ lisppaste2/web-server.lisp Fri May 21 17:29:11 2004
@@ -1,4 +1,4 @@
-;;;; $Id: web-server.lisp,v 1.46 2004/05/21 16:42:38 bmastenbrook Exp $
+;;;; $Id: web-server.lisp,v 1.47 2004/05/21 21:29:11 bmastenbrook Exp $
;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $
;;;; See the LICENSE file for licensing information.
@@ -36,16 +36,18 @@
(let* ((annotate-string (araneida:body-param "annotate" (araneida:request-body request)))
(annotate-number (if annotate-string (parse-integer annotate-string :junk-allowed t)))
(annotate (if annotate-number (find annotate-number *pastes* :key #'paste-number)))
- (default-channel (find-if #'(lambda (e) (> (length e) 1))
- (list
- (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=)
- (concatenate 'string "#"
- (araneida:request-cookie request "CHANNEL"))
- (and (eql method :post)
- (araneida:body-param "channel"
- (araneida:request-body request)))))))
+ (default-channel
+ (or (and annotate (paste-channel annotate))
+ (find-if #'(lambda (e) (> (length e) 1))
+ (list
+ (substitute #\# #\/ (araneida::request-unhandled-part request) :test #'char=)
+ (concatenate 'string "#"
+ (araneida:request-cookie request "CHANNEL"))
+ (and (eql method :post)
+ (araneida:body-param "channel"
+ (araneida:request-body request))))))))
(cond
- ((and default-channel (find default-channel *channels* :test #'string=))
+ ((and default-channel (find default-channel *channels* :test #'string=))
(araneida:request-send-headers request :expires 0 :set-cookie (format nil "CHANNEL=~A; path=/" (subseq default-channel 1)))
(new-paste-form request :annotate annotate :default-channel default-channel))
(t (araneida:request-send-headers request :expires 0)
@@ -58,6 +60,7 @@
(body
(h2 "Select a channel")
((form :method post :action ,(araneida:urlstring *new-paste-url*))
+ ((input :type "hidden" :name "annotate" :value ,annotate-string))
"Please select a channel to lisppaste to: "
((select :name "channel")
((option :value ""))
@@ -244,69 +247,120 @@
(defmethod araneida:handle-request-response ((handler list-paste-handler) method request)
(araneida:request-send-headers request :expires 0)
(format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">")
- (let ((discriminate-channel (or
- (araneida:body-param "channel" (araneida:request-body request))
- (if (not (string= (araneida::request-unhandled-part request) ""))
- (substitute #\# #\/ (araneida::request-unhandled-part request)
- :test #'char=)))))
- (if (string-equal discriminate-channel "allchannels")
- (setf discriminate-channel nil))
- (araneida:html-stream
- (araneida:request-stream request)
- `(html
- (head (title "All pastes")
- ,(rss-link-header))
- (body
- (center (h2 ,(if discriminate-channel
- (format nil "All pastes in channel ~A" discriminate-channel)
- "All pastes in system")))
- ,@(if discriminate-channel
- (if (not (member discriminate-channel *channels* :test #'string-equal))
- `(((h2) ((font :color "red") ,(format nil "Warning: no channel named ~A found!"
- discriminate-channel))))))
- (center
- ((form :method post :action ,(araneida:urlstring *list-paste-url*))
- (table
- (tr ((td :align left) "View only: ")
- ((td :valign top)
- ((select :name "channel")
- ((option :value "allchannels") "All channels")
- ,@(mapcar #'(lambda (e)
- `((option :value ,e ,@(if (and discriminate-channel
- (string-equal e discriminate-channel))
- '(:selected)))
- ,(encode-for-pre e))) *channels*)))
- ((td :valign top)
- ((input :type submit :value "Submit"))))
- (tr ((td :align left)
- ,(if discriminate-channel "Syndicate this channel: " "Syndicate all channels: "))
- ((td :align center)
- ((a :href ,(concatenate 'string
- (araneida:urlstring *rss-url*)
- (if discriminate-channel
- (substitute #\? #\# discriminate-channel) ""))) "Basic")
- " | "
- ((a :href ,(concatenate 'string
- (araneida:urlstring *rss-full-url*)
- (if discriminate-channel
- (substitute #\? #\# discriminate-channel) ""))) "Full"))
- (td)))))
- (p)
- ((table :width "100%" :cellpadding 2)
- (tr (td) (td "By") (td "Where") (td "When") (td "Titled") (td "Ann."))
- ,@(mapcar #'(lambda (paste)
- `(tr ((td :nowrap "nowrap") ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste)))))
- ,(concatenate 'string "#" (prin1-to-string (paste-number paste)))))
- ((td :nowrap "nowrap") ,(encode-for-pre (max-length (paste-user paste) 12)))
- ((td :nowrap "nowrap") ,(encode-for-pre (paste-channel paste)))
- ((td :nowrap "nowrap") ,(time-delta (paste-universal-time paste) :level 1 :ago-p nil))
- ((td :width "100%" :bgcolor "#F4F4F4" :nowrap "nowrap") ,(encode-for-pre (max-length (paste-title paste) 50)))
- ((td :nowrap "nowrap") ,(length (paste-annotations paste)))))
- (if discriminate-channel
- (remove discriminate-channel *pastes* :test-not #'string-equal
- :key #'paste-channel)
- *pastes*)))
- ,@(bottom-links))))))
+ (flet ((page-url (discriminate-channel i)
+ (araneida:urlstring
+ (let ((url (araneida:copy-url *list-paste-url*)))
+ (if discriminate-channel
+ (setf (araneida:url-path url)
+ (concatenate 'string
+ (araneida:url-path url)
+ "/")))
+ (araneida:merge-url
+ url
+ (format nil "~A?~A"
+ (if discriminate-channel
+ (subseq discriminate-channel 1) "")
+ i))))))
+ (destructuring-bind
+ (channel &rest others) (split-sequence:split-sequence
+ #\?
+ (araneida::request-unhandled-part request))
+ (let* ((discriminate-channel (or
+ (araneida:body-param "channel" (araneida:request-body request))
+ (if (not (string= channel ""))
+ (substitute #\# #\/ channel
+ :test #'char=))))
+ (discriminate-channel
+ (if (string-equal discriminate-channel "allchannels")
+ nil discriminate-channel))
+ (page (if others
+ (parse-integer (car others) :junk-allowed t) 0))
+ (discriminated-pastes
+ (if discriminate-channel
+ (remove discriminate-channel *pastes* :test-not #'string-equal
+ :key #'paste-channel)
+ *pastes*))
+ (highest-page (floor (/ (- (length discriminated-pastes) 1)
+ *pastes-per-page*)))
+ (page-links
+ `(,@(if (> page 0)
+ `(((a :href ,(page-url discriminate-channel (1- page)))
+ "Newer <") " "))
+ ,@(loop for i from 0 to highest-page
+ appending
+ `(,(if (not (eql i page))
+ `((a :href ,(page-url discriminate-channel i))
+ ,(1+ i))
+ (1+ i)) ,@(if (eql i highest-page)
+ nil
+ '(" "))))
+ ,@(if (< page highest-page)
+ `(((a :href ,(page-url discriminate-channel (1+ page)))
+ "> Older"))))))
+ (araneida:html-stream
+ (araneida:request-stream request)
+ `(html
+ (head (title "All pastes")
+ ,(rss-link-header))
+ (body
+ (center (h2 ,(if discriminate-channel
+ (format nil "All pastes in channel ~A" discriminate-channel)
+ "All pastes in system")))
+ ,@(if discriminate-channel
+ (if (not (member discriminate-channel *channels* :test #'string-equal))
+ `(((h2) ((font :color "red") ,(format nil "Warning: no channel named ~A found!"
+ discriminate-channel))))))
+ (center
+ ((form :method post :action ,(araneida:urlstring *list-paste-url*))
+ (table
+ (tr ((td :align left) "View only: ")
+ ((td :valign top)
+ ((select :name "channel")
+ ((option :value "allchannels") "All channels")
+ ,@(mapcar #'(lambda (e)
+ `((option :value ,e ,@(if (and discriminate-channel
+ (string-equal e discriminate-channel))
+ '(:selected)))
+ ,(encode-for-pre e))) *channels*)))
+ ((td :valign top)
+ ((input :type submit :value "Submit"))))
+ (tr ((td :align left)
+ ,(if discriminate-channel "Syndicate this channel: " "Syndicate all channels: "))
+ ((td :align center)
+ ((a :href ,(concatenate 'string
+ (araneida:urlstring *rss-url*)
+ (if discriminate-channel
+ (substitute #\? #\# discriminate-channel) ""))) "Basic")
+ " | "
+ ((a :href ,(concatenate 'string
+ (araneida:urlstring *rss-full-url*)
+ (if discriminate-channel
+ (substitute #\? #\# discriminate-channel) ""))) "Full"))
+ (td))
+ (tr ((td :align left)
+ "Page: ")
+ ((td :align center)
+ , at page-links))
+ )))
+ (p)
+ ((table :width "100%" :cellpadding 2)
+ (tr (td) (td "By") (td "Where") (td "When") (td "Titled") (td "Ann."))
+ ,@(mapcar #'(lambda (paste)
+ `(tr ((td :nowrap "nowrap") ((a :href ,(araneida:urlstring (araneida:merge-url *display-paste-url* (prin1-to-string (paste-number paste)))))
+ ,(concatenate 'string "#" (prin1-to-string (paste-number paste)))))
+ ((td :nowrap "nowrap") ,(encode-for-pre (max-length (paste-user paste) 12)))
+ ((td :nowrap "nowrap") ,(encode-for-pre (paste-channel paste)))
+ ((td :nowrap "nowrap") ,(time-delta (paste-universal-time paste) :level 1 :ago-p nil))
+ ((td :width "100%" :bgcolor "#F4F4F4" :nowrap "nowrap") ,(encode-for-pre (max-length (paste-title paste) 50)))
+ ((td :nowrap "nowrap") ,(length (paste-annotations paste)))))
+ (loop for i from 0
+ to (- (* (1+ page) *pastes-per-page*) 1)
+ for j in discriminated-pastes
+ if (>= i (* page *pastes-per-page*))
+ collect j)))
+ (center
+ "Page: " , at page-links)
+ ,@(bottom-links))))))))
(defun handle-rss-request (request &key full)
(araneida:request-send-headers request :expires 0 :content-type "application/rss+xml")
@@ -361,7 +415,7 @@
(defmethod araneida:handle-request-response ((handler rss-full-handler) method request)
(handle-rss-request request :full t))
-(defun new-paste-form (request &key (message "") (annotate nil) (default-channel ""))
+(defun new-paste-form (request &key (message "") (annotate nil) (default-channel "") (default-user "") (default-title "") (default-contents ""))
(format (araneida:request-stream request) "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">")
(araneida:html-stream
(araneida:request-stream request)
@@ -392,41 +446,48 @@
,(encode-for-pre e))) *channels*))))))
(tr
(th "Enter your username:")
- (td ((input :type text :name "username"))))
+ (td ((input :type text :name "username"
+ :value ,(encode-for-pre default-user)))))
(tr
(th "Enter a title:")
- (td ((input :type text :name "title"))))
+ (td ((input :type text :name "title"
+ :value ,(encode-for-pre default-title)))))
(tr
((th :valign top) "Enter your paste:")
- (td ((textarea :rows 24 :cols 80 :name "text"))))
+ (td ((textarea :rows 24 :cols 80 :name "text")
+ ,(encode-for-pre default-contents))))
(tr
((th) "Submit your paste:")
((td) ((input :type submit :value "Submit paste")) " " ((input :type reset :value "Clear paste"))))))
,@(bottom-links)))))
(defmethod araneida:handle-request-response ((handler submit-paste-handler) method request)
- (let ((username (araneida:body-param "username" (araneida:request-body request)))
- (title (araneida:body-param "title" (araneida:request-body request)))
- (text (araneida:body-param "text" (araneida:request-body request)))
- (annotate (araneida:body-param "annotate" (araneida:request-body request)))
- (channel (araneida:body-param "channel" (araneida:request-body request))))
+ (let* ((username (araneida:body-param "username" (araneida:request-body request)))
+ (title (araneida:body-param "title" (araneida:request-body request)))
+ (text (araneida:body-param "text" (araneida:request-body request)))
+ (annotate (araneida:body-param "annotate" (araneida:request-body request)))
+ (annotate-number (if annotate (parse-integer annotate :junk-allowed t)))
+ (annotate-paste (if annotate-number (find annotate-number *pastes* :key #'paste-number)))
+ (channel (araneida:body-param "channel" (araneida:request-body request))))
(if (> (length channel) 1)
(araneida:request-send-headers request :expires 0
:set-cookie (format nil "CHANNEL=~A; path=/" (subseq channel 1)))
- (araneida:request-send-headers request :expires 0))
+ (araneida:request-send-headers request :expires 0))
(cond
+ ((> (length text) *paste-maximum-size*)
+ (new-paste-form request :message "Paste too large." :default-channel channel :annotate annotate-paste :default-user username :default-title title))
((zerop (length channel))
- (new-paste-form request :message "Please select a channel." :default-channel channel))
+ (new-paste-form request :message "Please select a channel." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text))
((zerop (length username))
- (new-paste-form request :message "Please enter your username." :default-channel channel))
+ (new-paste-form request :message "Please enter your username." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text))
((zerop (length title))
- (new-paste-form request :message "Please enter a title." :default-channel channel))
+ (new-paste-form request :message "Please enter a title." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text))
((zerop (length text))
- (new-paste-form request :message "Please enter your paste." :default-channel channel))
- ((and annotate (not (parse-integer annotate :junk-allowed t)))
- (new-paste-form request :message "Malformed annotation request." :default-channel channel))
+ (new-paste-form request :message "Please enter your paste." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text))
+ ((and annotate (not annotate-paste))
+ (new-paste-form request :message "Malformed annotation request." :default-channel channel :default-user username :default-title title :default-contents text))
((not (member channel *channels* :test #'string-equal))
- (new-paste-form request :message "Whatever channel that is, I don't know about it." :default-channel channel))
+ (new-paste-form request :message "Whatever channel that is, I don't know about it." :default-channel channel :annotate annotate-paste :default-user username :default-title title :default-contents text))
(t
(let* ((paste-number (if annotate (parse-integer annotate :junk-allowed t) (incf *paste-counter*)))
(paste-to-annotate (if annotate (find paste-number *pastes* :key #'paste-number)))
More information about the Lisppaste-cvs
mailing list