February 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2502 - branches/trunk-reorg/projects/bos/web
by ksprotte＠common-lisp.net 15 Feb '08

15 Feb '08

Author: ksprotte Date: Fri Feb 15 07:39:33 2008 New Revision: 2502 Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp Log: fix in sponsor-handlers for changing password by explicitly using SET-USER-PASSWORD Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp Fri Feb 15 07:39:33 2008 @@ -181,7 +181,9 @@ (let ((field-value (query-param (string-downcase (symbol-name field-name))))) (when (and field-value (not (equal field-value (slot-value sponsor field-name)))) - (change-slot-values sponsor field-name field-value) + (case field-name + (password (set-user-password sponsor field-value)) + (t (change-slot-values sponsor field-name field-value))) (setf changed t) (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name)))))))) (dolist (contract (sponsor-contracts sponsor))

1 0

[bknr-cvs] r2501 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 15 Feb '08

15 Feb '08

Author: ksprotte Date: Fri Feb 15 07:36:38 2008 New Revision: 2501 Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp Log: fix in sponsor-handlers for changing password by explicitly using SET-USER-PASSWORD Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/sponsor-handlers.lisp (original) +++ branches/bos/projects/bos/web/sponsor-handlers.lisp Fri Feb 15 07:36:38 2008 @@ -179,7 +179,9 @@ (let ((field-value (query-param req (string-downcase (symbol-name field-name))))) (when (and field-value (not (equal field-value (slot-value sponsor field-name)))) - (change-slot-values sponsor field-name field-value) + (case field-name + (password (set-user-password sponsor field-value)) + (t (change-slot-values sponsor field-name field-value))) (setf changed t) (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name)))))))) (dolist (contract (sponsor-contracts sponsor))

1 0

[bknr-cvs] r2500 - in branches/bos/projects/bos: payment-website/infosystem payment-website/templates/da payment-website/templates/de payment-website/templates/en web
by ksprotte＠common-lisp.net 15 Feb '08

15 Feb '08

Author: ksprotte Date: Fri Feb 15 07:21:20 2008 New Revision: 2500 Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js branches/bos/projects/bos/payment-website/templates/da/profil.xml branches/bos/projects/bos/payment-website/templates/de/profil.xml branches/bos/projects/bos/payment-website/templates/en/profil.xml branches/bos/projects/bos/web/sponsor-handlers.lisp Log: removed Google Earth links Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js ============================================================================== --- branches/bos/projects/bos/payment-website/infosystem/javascript.js (original) +++ branches/bos/projects/bos/payment-website/infosystem/javascript.js Fri Feb 15 07:21:20 2008 @@ -397,9 +397,6 @@ + ' m²</td></tr><tr> <td width="60" class="PoiNavigation">' + msg('seit') + ':</td><td class="PoiNavigation">' + n_profil.contracts[0].date + '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="10"/></td></tr>' - + '</td></tr><tr><td colspan="2" class="PoiNavigation"><a href="' + http_pfad + - '/contract-kml/' + n_profil.contracts[0].id + '">Google Earth View</a></td></tr>' - + '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="20"/></td></tr>' + '<tr> <td colspan="2" class="PoiNavigation">' + n_profil['nachricht'] + '</td></tr></table>'; Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/da/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/da/profil.xml Fri Feb 15 07:21:20 2008 @@ -55,8 +55,7 @@ </tr> <tr> <td class="Label">kvardratmeter</td> - <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt kordinater: $(geo-coord) - <a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> + <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt kordinater: $(geo-coord)</td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/payment-website/templates/de/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/de/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/de/profil.xml Fri Feb 15 07:21:20 2008 @@ -60,8 +60,7 @@ </tr> <tr> <td class="Label">Quadratmeter</td> - <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft Koordinate: $(geo-coord) - <a href="/contract-kml/$(contract-id)">Ihre Quadratmeter in Google Earth</a></td> + <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft Koordinate: $(geo-coord)</td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/en/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/en/profil.xml Fri Feb 15 07:21:20 2008 @@ -60,8 +60,7 @@ </tr> <tr> <td class="Label">square metres</td> - <td class="Input">a total of $(numsqm) m² has been bought coordinate: $(geo-coord) - <a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> + <td class="Input">a total of $(numsqm) m² has been bought coordinate: $(geo-coord)</td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/sponsor-handlers.lisp (original) +++ branches/bos/projects/bos/web/sponsor-handlers.lisp Fri Feb 15 07:21:20 2008 @@ -160,9 +160,7 @@ (m2-utm-x (first (contract-m2s (first (sponsor-contracts sponsor))))) (m2-utm-y (first (contract-m2s (first (sponsor-contracts sponsor)))))))) (:td (:princ-safe (if (contract-paidp contract) "paid" "not paid"))) - (:td (cmslink (format nil "contract-kml/~A" (store-object-id contract)) "Google Earth") - :br - (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate") + (:td (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate") (when (probe-file (contract-pdf-pathname contract)) (html :br (cmslink (contract-pdf-url contract) "Show Certificate"))) (when (contract-worldpay-trans-id contract)

1 0

[bknr-cvs] r2499 - in branches/trunk-reorg/projects/bos: m2 web
by ksprotte＠common-lisp.net 15 Feb '08

15 Feb '08

Author: ksprotte Date: Fri Feb 15 06:51:09 2008 New Revision: 2499 Modified: branches/trunk-reorg/projects/bos/m2/geometry.lisp branches/trunk-reorg/projects/bos/m2/make-certificate.lisp branches/trunk-reorg/projects/bos/m2/packages.lisp branches/trunk-reorg/projects/bos/web/tags.lisp Log: manually merged over some chs from bos branch Modified: branches/trunk-reorg/projects/bos/m2/geometry.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/geometry.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/geometry.lisp Fri Feb 15 06:51:09 2008 @@ -214,3 +214,56 @@ (traverse boundary-point initial-direction) (nreverse polygon)))) + +;;; formatting +;; proposed by Michael Weber on alexandria-devel +(defun format-mixed-radix-number (stream number radix-list format-list + &key lsb-first leading-zeros + (trailing-zeros t)) + "Prints NUMBER to STREAM in mixed-radix RADIX. +representation-LIST is a list of radixes, least-significant first. +FORMAT-LIST is a list of format directives, one for each digit. +When LSB-FIRST is nil (default), print most-significant digit first, +otherwise least-significant digit first. +When LEADING-ZEROS and TRAILING-ZEROS are nil, leading and +trailing zero digits are not printed, respectively. \(default: remove +leading zeros, keep trailing zeros)" + (let ((format-pairs + (loop with digit and fraction + initially (setf (values number fraction) + (truncate number)) + for f-list on format-list + and r-list = radix-list then (rest r-list) + collect (list (first f-list) + (cond ((endp r-list) + (shiftf number 0)) + ((rest f-list) + (setf (values number digit) + (truncate number (first r-list))) + digit) + (t number))) + into list + finally (progn + (incf (cadar list) fraction) + (return (nreverse list)))))) + (unless trailing-zeros + (setf format-pairs (member-if #'plusp format-pairs :key + #'second))) + (when lsb-first + (setf format-pairs (nreverse format-pairs))) + (unless leading-zeros + (setf format-pairs (member-if #'plusp format-pairs :key + #'second))) + (format stream "~{~{~@?~}~}" format-pairs))) + + +(defun format-decimal-degree (degree) + (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '(" ~,2F´´" " ~D´" "~D°"))) + +(defun format-lon-lat (stream lon lat) + (format stream "~A ~:[S~;N~], ~A ~:[W~;E~]" + (format-decimal-degree (abs lat)) + (plusp lat) + (format-decimal-degree (abs lon)) + (plusp lon))) + Modified: branches/trunk-reorg/projects/bos/m2/make-certificate.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/make-certificate.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/make-certificate.lisp Fri Feb 15 06:51:09 2008 @@ -42,8 +42,19 @@ :sponsor-id (sponsor-id sponsor) :master-code (sponsor-master-code sponsor) :sqm-count (length (contract-m2s contract)) - :sqm-ids (with-output-to-string (s) - (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*) - do (loop for nums on group - do (princ (car nums) s) - do (princ (if (cdr nums) #\Tab #\Newline) s))))))) + ;; :sqm-ids (with-output-to-string (s) + ;; (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*) + ;; do (loop for nums on group + ;; do (princ (car nums) s) + ;; do (princ (if (cdr nums) #\Tab #\Newline) s)))) + ;; should later be called :sqm-coordinates + :sqm-ids + (flet ((format-point (stream x y) + (apply #'geometry:format-lon-lat stream + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) + (- +nw-utm-y+ y) +utm-zone+ t)))) + (destructuring-bind (left top width height) + (contract-bounding-box contract) + (with-output-to-string (out) + (format-point out left top) (terpri out) + (format-point out (+ left width) (+ top height)) (terpri out))))))) Modified: branches/trunk-reorg/projects/bos/m2/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/packages.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/packages.lisp Fri Feb 15 06:51:09 2008 @@ -9,7 +9,8 @@ #:point-in-polygon-p #:point-in-circle-p #:find-boundary-point - #:region-to-polygon)) + #:region-to-polygon + #:format-lon-lat)) (defpackage :geo-utm (:use :cl) Modified: branches/trunk-reorg/projects/bos/web/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/tags.lisp (original) +++ branches/trunk-reorg/projects/bos/web/tags.lisp Fri Feb 15 06:51:09 2008 @@ -167,8 +167,14 @@ (setf (get-template-var :country) (sponsor-country sponsor)) (setf (get-template-var :infotext) (sponsor-info-text sponsor)) (setf (get-template-var :name) (user-full-name sponsor)) - (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) - (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) + (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) + (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) + (setf (get-template-var :geo-coord) (destructuring-bind (left top . ignore) + (contract-bounding-box contract) + (declare (ignore ignore)) + (apply #'geometry:format-lon-lat nil + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) + (- +nw-utm-y+ top) +utm-zone+ t)))) (setf (get-template-var :numsqm) (format nil "~D" (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))

1 0

[bknr-cvs] r2498 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 15 Feb '08

15 Feb '08

Author: hhubner Date: Fri Feb 15 01:42:26 2008 New Revision: 2498 Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp Log: merge 2462, fix password setting through CMS Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/sponsor-handlers.lisp (original) +++ branches/bos/projects/bos/web/sponsor-handlers.lisp Fri Feb 15 01:42:26 2008 @@ -181,9 +181,7 @@ (let ((field-value (query-param req (string-downcase (symbol-name field-name))))) (when (and field-value (not (equal field-value (slot-value sponsor field-name)))) - (if (eq field-name 'password) - (set-user-password sponsor field-value) - (change-slot-values sponsor field-name field-value)) + (change-slot-values sponsor field-name field-value) (setf changed t) (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name)))))))) (dolist (contract (sponsor-contracts sponsor))

1 0

[bknr-cvs] r2497 - in branches/trunk-reorg: bknr/datastore/src/utils bknr/web/src/images bknr/web/src/sysclasses bknr/web/src/web xhtmlgen
by hhubner＠common-lisp.net 14 Feb '08

14 Feb '08

Author: hhubner Date: Thu Feb 14 11:11:03 2008 New Revision: 2497 Modified: branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp branches/trunk-reorg/bknr/web/src/web/authorizer.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/xhtmlgen/package.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: if-modified-since fixed for images password checking fixed login works again, needs more testing xhtmlgen fixed, new macro with-xhtml to set up doctype Modified: branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp Thu Feb 14 11:11:03 2008 @@ -66,7 +66,7 @@ (unless (string-equal (subseq saltpw 0 3) "$1$") (error "not a md5 password ~a" saltpw)) (let ((salt (extract-salt saltpw))) - (string-equal (crypt-md5 password salt) saltpw))) + (string-equal (crypt-md5 (coerce password 'simple-string) salt) saltpw))) ;; 0 6 12 (4) ;; 1 7 13 (4) Modified: branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp Thu Feb 14 11:11:03 2008 @@ -34,7 +34,8 @@ (defmethod object-handler-get-object ((handler image-handler)) (let ((id-or-name (parse-url))) - (find-store-object id-or-name :class 'store-image :query-function #'store-image-with-name))) + (when id-or-name + (find-store-object id-or-name :class 'store-image :query-function #'store-image-with-name)))) (defclass browse-image-handler (image-handler) ()) Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Thu Feb 14 11:11:03 2008 @@ -167,21 +167,8 @@ (error-404)) (defmethod handle-object ((page-handler imageproc-handler) image) - (format t "if-modfied-since not implemented for hunchentoot~%") (with-http-response (:content-type (image-content-type (image-type-keyword image))) - (with-http-body () - (imageproc image (cdr (decoded-handler-path page-handler))))) - #+(or) - (with-http-response (:content-type (image-content-type (image-type-keyword image))) - (let ((ims (header-in :if-modified-since)) - (changed-time (blob-timestamp image))) - (setf (header-out :last-modified) (rfc-1123-date changed-time)) - (if (and ims - (<= changed-time (date-to-universal-time ims))) - (progn - (setf (return-code) +http-not-modified+) - (format t "; image ~A not changed~%" image) - (with-http-body ())) - (with-http-body () - (imageproc image (cdr (decoded-handler-path page-handler)))))))) + (handle-if-modified-since (blob-timestamp image)) + (setf (header-out "Last-Modified") (rfc-1123-date (blob-timestamp image))) + (imageproc image (cdr (decoded-handler-path page-handler))))) Modified: branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp (original) +++ branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp Thu Feb 14 11:11:03 2008 @@ -110,10 +110,11 @@ (defmethod verify-password ((user user) password) (when password (let ((upw (user-password user))) - (if (string-equal "$1$" (subseq upw 0 3)) + (if (equal "$1$" (and (> (length upw) 3) (subseq upw 0 3))) (verify-md5-password password (user-password user)) - (equal upw - (crypt password (subseq upw 0 +salt-length+))))))) + (when (> (length upw) +salt-length+) + (equal upw + (crypt password (subseq upw 0 +salt-length+)))))))) (defmethod user-disabled ((user user)) (user-has-flag user :disabled)) Modified: branches/trunk-reorg/bknr/web/src/web/authorizer.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/authorizer.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/authorizer.lisp Thu Feb 14 11:11:03 2008 @@ -21,15 +21,24 @@ "check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter" (session-value 'bknr-session)) -(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer)) +(define-condition login-failure (serious-condition) + () + (:report (lambda (c s) + (declare (ignore c)) + (format s "Login failed")))) + +(defun find-user-from-request-parameters () (with-query-params (__username __password) - (when (and __username (not (equal __username ""))) - (let ((user (find-user __username))) - (when user - (if (and (not (user-disabled user)) + (unless (and __username __password + (not (equal __username "")) + (not (equal __password ""))) + (return-from find-user-from-request-parameters nil)) + (let ((user (find-user __username))) + (when (and user + (not (user-disabled user)) (verify-password user __password)) - user - (warn "login failure for user ~a~%" user))))))) + (return-from find-user-from-request-parameters user))) + (error 'login-failure))) (defmethod authorize ((authorizer bknr-authorizer)) ;; Catch any errors that occur during request body processing Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Thu Feb 14 11:11:03 2008 @@ -221,10 +221,6 @@ t))) (defmethod invoke-handler ((handler page-handler)) - (start-session) - (unless (session-value 'bknr-session) - (setf (session-value 'bknr-session) - (make-instance 'bknr-session :user (find-user "anonymous")))) (let* ((*website* (page-handler-site handler)) (*req-var-hash* (or *req-var-hash* (make-hash-table)))) @@ -255,10 +251,28 @@ (defvar *handlers* nil) +(defun ensure-bknr-session () + "Ensure that the BKNR-SESSION session variable is set and that it +belongs to the user that is specified in the request." + (let ((request-user (find-user-from-request-parameters))) + (unless (and (session-value 'bknr-session) + (equal (bknr-session-user) + (find-user-from-request-parameters))) + (setf (session-value 'bknr-session) + (make-instance 'bknr-session :user (or request-user + (find-user "anonymous"))))))) + (defun bknr-dispatch (request) (declare (ignore request)) - (when-let ((handler (find-if #'handler-matches (website-handlers *website*)))) - (curry #'invoke-handler handler))) + (let ((handler (find-if #'handler-matches (website-handlers *website*)))) + (cond + (handler + (start-session) + (ensure-bknr-session) + (when (authorize (website-authorizer *website*)) + (curry #'invoke-handler handler))) + (t + 'error-404)))) (defmethod publish-handler ((website website) (handler page-handler)) (setf *handlers* (append *handlers* (list handler)))) @@ -309,6 +323,12 @@ (defclass prefix-handler (page-handler) ()) +#+(or) +(defmethod initialize-instance :after ((handler prefix-handler) &key) + (unless (eql #\/ (aref (page-handler-prefix handler) + (1- (length (page-handler-prefix handler))))) + (warn "prefix handler ~A does not have prefix ending with / - may match unexpectedly" handler))) + (defmethod handler-matches ((handler prefix-handler)) (and (>= (length (script-name)) (length (page-handler-prefix handler))) Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Thu Feb 14 11:11:03 2008 @@ -24,10 +24,10 @@ (let ((vars (loop for param in params when (and (symbolp param) (not (null param))) - collect (list param `(get-parameter ,(symbol-name param))) + collect (list param `(get-parameter ,(string-downcase (symbol-name param)))) when (consp param) collect (list (car param) - `(or (get-parameter ,(symbol-name (car param))) + `(or (get-parameter ,(string-downcase (symbol-name (car param)))) ,(second param)))))) (if vars `(let ,vars @@ -54,14 +54,8 @@ (defmacro with-http-body ((&key external-format) &body body) `(with-output-to-string (*html-stream*) - (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3))) - (sax:start-document *html-sink*) - (sax:start-dtd *html-sink* - "html" - "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") - ,@body - (sax:end-document *html-sink*)))) + (with-xhtml (*html-stream*) + ,@body))) (defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind Modified: branches/trunk-reorg/xhtmlgen/package.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/package.lisp (original) +++ branches/trunk-reorg/xhtmlgen/package.lisp Thu Feb 14 11:11:03 2008 @@ -4,6 +4,6 @@ (:use :common-lisp) (:export #:html #:html-stream - #:*html-sink* - #:set-string-encoding)) + #:with-xhtml + #:*html-sink*)) Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Thu Feb 14 11:11:03 2008 @@ -53,13 +53,26 @@ (,body) (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3))) (,body) - (sax:end-document *html-sink*)))))) + (sax:end-document *html-sink*)))))) (defmacro html-stream (stream &rest forms &environment env) `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3))) ,(process-html-forms forms env) (sax:end-document *html-sink*))) +(defmacro with-xhtml ((&optional stream &key (indentation 3)) &body body) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation ,indentation))) + (sax:start-document *html-sink*) + (sax:start-dtd *html-sink* + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + (sax:end-dtd *html-sink*) + (multiple-value-prog1 + (html + ,@body) + (sax:end-document *html-sink*)))) + (defun get-process (form) (let ((ent (gethash form *html-process-table*))) (unless ent

1 0

[bknr-cvs] r2496 - branches/trunk-reorg/bknr/web/src/web
by ksprotte＠common-lisp.net 14 Feb '08

14 Feb '08

Author: ksprotte Date: Thu Feb 14 10:42:55 2008 New Revision: 2496 Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Log: tweaked with-http-body and website-show-error-page Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Thu Feb 14 10:42:55 2008 @@ -499,10 +499,9 @@ (ensure-directories-exist spool-dir) spool-dir)) -(defmethod website-show-page ((website website) fn title) - (html - (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*) - (princ #\Newline *html-stream*) +(defmethod website-show-page ((website website) fn title) + (html + (:html (:head (header :title title)) @@ -515,34 +514,11 @@ (funcall fn) (session-info))))) -(defmethod website-show-error-page ((website website) error) - (if (website-template-handler website) - (send-error-response (website-template-handler website) (princ-to-string error)) - (html - (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*) - (princ #\Newline *html-stream*) - (:html - (:head - (header :title "Error processing your request")) - ((:body :class "cms") - (:h1 "Error processing your request") - (:p "While processing your request, an error occured:") - ((:div :class "error") - (:princ-safe error))))))) - (defun show-page-with-error-handlers (fn &key (response +http-ok+) title) (setf (return-code) response) - (handler-case - (let ((body (with-output-to-string (*html-stream*) - (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3))) - (website-show-page *website* fn title))))) - (with-http-response (:content-type "text/html; charset=UTF-8" :response response) - (with-http-body () - (princ body *html-stream*)))) - (serious-condition (c) - (with-http-response (:content-type "text/html; charset=UTF-8" :response +http-internal-server-error+) - (with-http-body () - (website-show-error-page *website* c)))))) + (with-http-response (:content-type "text/html; charset=UTF-8" :response response) + (with-http-body () + (website-show-page *website* fn title)))) (defmacro with-bknr-page ((&rest args) &body body) `(show-page-with-error-handlers (lambda () (html ,@body)) ,@args)) Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Thu Feb 14 10:42:55 2008 @@ -54,7 +54,14 @@ (defmacro with-http-body ((&key external-format) &body body) `(with-output-to-string (*html-stream*) - ,@body)) + (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3))) + (sax:start-document *html-sink*) + (sax:start-dtd *html-sink* + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + ,@body + (sax:end-document *html-sink*)))) (defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind

1 0

[bknr-cvs] r2495 - branches/trunk-reorg/projects/quickhoney/src
by hhubner＠common-lisp.net 14 Feb '08

14 Feb '08

Author: hhubner Date: Thu Feb 14 09:13:32 2008 New Revision: 2495 Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Log: Fix handler order so that /image-detail template is seen before /image prefix handler Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp Thu Feb 14 09:13:32 2008 @@ -33,17 +33,17 @@ ("/admin" admin-handler) ("/" redirect-handler :to "/frontpage") + ("/" template-handler + :destination ,(namestring (merge-pathnames "templates/" *website-directory*)) + :command-packages (("http://quickhoney.com/" . :quickhoney.tags) + ("http://bknr.net/" . :bknr.web))) user images ("/static" directory-handler :destination ,(merge-pathnames #p"static/" *website-directory*)) ("/favicon.ico" file-handler :destination ,(merge-pathnames #p"static/favicon.ico" *website-directory*) - :content-type "application/x-icon") - ("/" template-handler - :destination ,(namestring (merge-pathnames "templates/" *website-directory*)) - :command-packages (("http://quickhoney.com/" . :quickhoney.tags) - ("http://bknr.net/" . :bknr.web)))) + :content-type "application/x-icon")) :admin-navigation '(("user" . "/user/") ("images" . "/edit-images") ("import" . "/import")

1 0

[bknr-cvs] r2494 - branches/trunk-reorg
by ksprotte＠common-lisp.net 14 Feb '08

14 Feb '08

Author: ksprotte Date: Thu Feb 14 07:25:23 2008 New Revision: 2494 Modified: branches/trunk-reorg/ (props changed) Log: svn property ignore asd dir on the rootlevel

1 0

[bknr-cvs] r2493 - branches/trunk-reorg/projects/hello-web/src
by ksprotte＠common-lisp.net 14 Feb '08

14 Feb '08

Author: ksprotte Date: Thu Feb 14 07:23:14 2008 New Revision: 2493 Modified: branches/trunk-reorg/projects/hello-web/src/config.lisp branches/trunk-reorg/projects/hello-web/src/hello-web.asd branches/trunk-reorg/projects/hello-web/src/init.lisp branches/trunk-reorg/projects/hello-web/src/packages.lisp branches/trunk-reorg/projects/hello-web/src/webserver.lisp Log: ported hello-web for trunk-reorg Modified: branches/trunk-reorg/projects/hello-web/src/config.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/config.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/config.lisp Thu Feb 14 07:23:14 2008 @@ -3,10 +3,15 @@ ;; URL für BASE HREFs (defparameter *website-url* "http://hello-web.bknr.net") -(defparameter *root-directory* #p"home:bknr-svn/projects/hello-web/") +(defparameter *root-directory* + (let ((system-path (asdf:component-pathname (asdf:find-system :hello-web)))) + (truename + (merge-pathnames (make-pathname :directory '(:relative :up) :defaults system-path) + system-path)))) (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*)) (defparameter *website-directory* (merge-pathnames #p"website/" *root-directory*)) -(defparameter *webserver-port* 8080) \ No newline at end of file +(defparameter *webserver-port* 8080) +(defvar *webserver* nil) Modified: branches/trunk-reorg/projects/hello-web/src/hello-web.asd ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/hello-web.asd (original) +++ branches/trunk-reorg/projects/hello-web/src/hello-web.asd Thu Feb 14 07:23:14 2008 @@ -17,8 +17,7 @@ :long-description "" :depends-on (:cl-interpol - :cl-ppcre - :aserve + :cl-ppcre :cxml :bknr-modules) Modified: branches/trunk-reorg/projects/hello-web/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/init.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/init.lisp Thu Feb 14 07:23:14 2008 @@ -1,17 +1,29 @@ (in-package :hello-web) -(defun startup () +(defun startup (&key debug) (when *store* (close-store)) + ;; XXX hack hack hack + (mapcar #'cl-gd::load-foreign-library + '("/usr/lib/libcrypto.so" + "/usr/lib/libssl.so" + "/usr/local/lib/libgd.so" + "/home/hans/bknr-svn/thirdparty/cl-gd-0.5.6/cl-gd-glue.so")) + (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (make-instance 'store :directory *store-directory* :subsystems (list (make-instance 'store-object-subsystem) (make-instance 'blob-subsystem :n-blobs-per-directory 1000))) (unless (find-user "anonymous") - (make-user "anonymous") ; used for all anonymous sessions + (make-user "anonymous") ; used for all anonymous sessions (make-user "admin" :password "admin" :full-name "Administrator" :flags '(:admin)) - (import-image "bknr-logo.png" :keywords '(:banner :bknr)) + (import-image (merge-pathnames #p"src/bknr-logo.png" hello-web.config:*root-directory*) + :keywords '(:banner :bknr)) (make-rss-channel "default" "BKNR Hello Web" "default RSS channel of the BKNR hello web site" *website-url*)) - (publish-hello-web)) + (publish-hello-web) + (setq hunchentoot:*catch-errors-p* (not debug)) + (when *webserver* + (hunchentoot:stop-server *webserver*)) + (setq *webserver* (hunchentoot:start-server :port *webserver-port*))) Modified: branches/trunk-reorg/projects/hello-web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/packages.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/packages.lisp Thu Feb 14 07:23:14 2008 @@ -6,17 +6,17 @@ (:export #:*website-url* #:*website-directory* #:*webserver-port* - #:*store-directory*)) + #:*webserver* + #:*store-directory* + #:*root-directory*)) (defpackage :hello-web.tags (:use :cl :cl-user - :ext :bknr.web :xhtml-generator :hello-web.config) - (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) + (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:export #:hello)) (defpackage :hello-web.imageproc @@ -31,7 +31,6 @@ (defpackage :hello-web (:use :cl :cl-user - :ext :cl-interpol :cl-ppcre :bknr.utils Modified: branches/trunk-reorg/projects/hello-web/src/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/hello-web/src/webserver.lisp (original) +++ branches/trunk-reorg/projects/hello-web/src/webserver.lisp Thu Feb 14 07:23:14 2008 @@ -7,29 +7,27 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun publish-hello-web (&key (port *webserver-port*) (listeners 20)) - +(defun publish-hello-web () (make-instance 'website :name "Hello Web CMS" :handler-definitions `(("/hello-object" hello-object-handler) ("/" redirect-handler - :prefix "/" :to "/index") + :prefix "/" :to "/index") ("/rss" rss-handler) ("/" template-handler - :prefix "/" - :destination ,(namestring (merge-pathnames #p"templates/" *website-directory*)) - :command-packages ((:hello-web . :hello-web.tags) - (:bknr . :bknr.web) - (:menu . :bknr.site-menu))) + :prefix "/" + :destination ,(namestring (merge-pathnames #p"templates/" *website-directory*)) + :command-packages (("http://hello-web.bknr.net" . :hello-web.tags) + ("http://bknr.net" . :bknr.web))) + images + user ("/static" directory-handler - :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*)))) - :modules '(images user) + :destination ,(namestring (merge-pathnames #p"static/" *website-directory*)))) :admin-navigation '(("user" . "/user/") ("images" . "/edit-images") ("import" . "/import") ("logout" . "/logout")) :authorizer (make-instance 'bknr-authorizer) :style-sheet-urls '("/static/styles.css") - :javascript-urls '("/static/javascript.js")) + :javascript-urls '("/static/javascript.js"))) - (start :port port :listeners listeners))

1 0