bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

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

14 Feb '08

Author: hhubner Date: Thu Feb 14 07:12:33 2008 New Revision: 2492 Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp Log: Fix with-bknr-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 07:12:33 2008 @@ -534,7 +534,8 @@ (setf (return-code) response) (handler-case (let ((body (with-output-to-string (*html-stream*) - (website-show-page *website* fn title)))) + (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*))))

1 0

[bknr-cvs] r2491 - in branches/trunk-reorg/thirdparty: slime uffi-1.6.0/src
by hhubner＠common-lisp.net 14 Feb '08

14 Feb '08

Author: hhubner Date: Thu Feb 14 04:02:22 2008 New Revision: 2491 Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp Log: Fixes for thirdparty packages to make quickhoney run on CCL (and it does!): UFFI: Support pointer-to-pointer in structures SLIME: Fix Marco's package deletion fix again Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank.lisp Thu Feb 14 04:02:22 2008 @@ -82,9 +82,12 @@ "Abbreviate dotted package names to their last component if T.") (defvar *swank-io-package* - (let ((package (make-package :swank-io-package :use '()))) - (import '(nil t quote) package) - package)) + (progn + (when (find-package :swank-io-package) + (delete-package :swank-io-package)) + (let ((package (make-package :swank-io-package :use '()))) + (import '(nil t quote) package) + package))) (defconstant default-server-port 4005 "The default TCP port for the server (when started manually).") Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp (original) +++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp Thu Feb 14 04:02:22 2008 @@ -286,7 +286,10 @@ #+openmcl ((eq (car result) :address) (if (eq context :struct) - (append '(:*) (cdr result)) + (append '(:*) (if (listp (cadr result)) + ;; hack to make pointers to pointers work + (list (convert-from-uffi-type (cadr result) context)) + (cdr result))) :address)) #+digitool ((and (eq (car result) :pointer) (eq context :allocation) :pointer))

1 0

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

14 Feb '08

Author: hhubner Date: Thu Feb 14 03:10:49 2008 New Revision: 2490 Modified: branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp Log: Fix bug that was not a bug Modified: branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp Thu Feb 14 03:10:49 2008 @@ -27,8 +27,8 @@ (let ((color (parse-color background-color :image mask-image)) (white (parse-color "ffffff" :image mask-image))) (do-pixels (mask-image) - (when t (eql (ldb (byte 24 0) (raw-pixel)) white) - (setf (raw-pixel) color)))) + (when (eql (ldb (byte 24 0) (raw-pixel)) white) + (setf (raw-pixel) color)))) (copy-image mask-image button-image 0 0 0 0

1 0

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

14 Feb '08

Author: ksprotte Date: Thu Feb 14 00:56:35 2008 New Revision: 2489 Modified: branches/trunk-reorg/projects/bos/m2/bos.m2.asd Log: in bos.m2.asd: m2.lisp depends-on on geometry dont know why this never became apparent earlier Modified: branches/trunk-reorg/projects/bos/m2/bos.m2.asd ============================================================================== --- branches/trunk-reorg/projects/bos/m2/bos.m2.asd (original) +++ branches/trunk-reorg/projects/bos/m2/bos.m2.asd Thu Feb 14 00:56:35 2008 @@ -15,7 +15,8 @@ "utils" "make-certificate" "mail-generator" - "geo-utm")) + "geo-utm" + "geometry")) (:file "contract-expiry" :depends-on ("m2")) (:file "allocation" :depends-on ("m2")) (:file "allocation-cache" :depends-on ("packages" "geometry"))

1 0

[bknr-cvs] r2488 - in branches/trunk-reorg: bknr/web/src/images bknr/web/src/web projects/bos/web projects/quickhoney/src xhtmlgen
by hhubner＠common-lisp.net 13 Feb '08

13 Feb '08

Author: hhubner Date: Wed Feb 13 15:22:21 2008 New Revision: 2488 Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/projects/bos/web/webserver.lisp branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp branches/trunk-reorg/projects/quickhoney/src/tags.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: Fixes for templater and toplevel, BOS templates now work a bit better. 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 Wed Feb 13 15:22:21 2008 @@ -16,35 +16,35 @@ (defun apply-imageproc-operation (operation-name args image) (apply (or (gethash (make-keyword-from-string operation-name) *imageproc-operations*) - (error "invalid imageproc operation name ~A" operation-name)) - image args)) + (error "invalid imageproc operation name ~A" operation-name)) + image args)) (defun imageproc (image operations) (with-store-image (input-image image) (setf (save-alpha-p :image input-image) t) (let ((working-image input-image)) (dolist (operation operations) - (destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal) - (let ((returned-image (apply-imageproc-operation operation-name args working-image))) - (unless (not returned-image) - (unless (or (eq working-image returned-image) - (eq working-image input-image)) - (destroy-image working-image)) - (setf working-image returned-image))))) + (destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal) + (let ((returned-image (apply-imageproc-operation operation-name args working-image))) + (unless (not returned-image) + (unless (or (eq working-image returned-image) + (eq working-image input-image)) + (destroy-image working-image)) + (setf working-image returned-image))))) (when (and (true-color-p working-image) - (not (true-color-p input-image))) - (true-color-to-palette :dither t :image working-image :colors-wanted 256)) + (not (true-color-p input-image))) + (true-color-to-palette :dither t :image working-image :colors-wanted 256)) (let ((stream (send-headers))) - (setf (flex:flexi-stream-element-type stream) 'flex:octet) - (write-image-to-stream stream (image-type-keyword image) :image working-image)) + (setf (flex:flexi-stream-element-type stream) 'flex:octet) + (write-image-to-stream stream (image-type-keyword image) :image working-image)) (unless (eq working-image input-image) - (destroy-image working-image))))) + (destroy-image working-image))))) #+(or) (unless (member type '(:jpg :jpeg)) (when (true-color-p input-image) (true-color-to-palette :dither t :image input-image - :colors-wanted 256))) + :colors-wanted 256))) (defparameter *cell-border-width* 5) @@ -54,38 +54,38 @@ (setf bgcolor (if (and (stringp bgcolor) (not (zerop (length bgcolor)))) bgcolor nil)) (setq border-width (if border-width (parse-integer border-width) *cell-border-width*)) (let* ((width (image-width input-image)) - (height (image-height input-image)) - (ratio (max (/ width (- cell-width (* border-width 2))) - (/ height (- cell-height (* border-width 2))))) - (thumbnail-width (min width (round (/ width ratio)))) - (thumbnail-height (min height (round (/ height ratio)))) - (x-offset (round (/ (- cell-width thumbnail-width) 2))) - (y-offset (round (/ (- cell-height thumbnail-height) 2))) - (cell (create-image cell-width cell-height t))) + (height (image-height input-image)) + (ratio (max (/ width (- cell-width (* border-width 2))) + (/ height (- cell-height (* border-width 2))))) + (thumbnail-width (min width (round (/ width ratio)))) + (thumbnail-height (min height (round (/ height ratio)))) + (x-offset (round (/ (- cell-width thumbnail-width) 2))) + (y-offset (round (/ (- cell-height thumbnail-height) 2))) + (cell (create-image cell-width cell-height t))) (with-default-image (cell) (let ((color (if bgcolor - (parse-color bgcolor) - (allocate-color 255 255 255)))) - (fill-image 0 0 :color color) - (copy-image input-image cell - 0 0 - x-offset - y-offset - width height - :resize t :resample t - :dest-width thumbnail-width :dest-height thumbnail-height) - (unless bgcolor - (setf (transparent-color) color) - (let ((cr (ldb (byte 8 16) color)) - (cg (ldb (byte 8 8) color)) - (cb (ldb (byte 8 0) color))) - (flet ((color-distance (c) - (+ (abs (- (ldb (byte 8 16) c) cr)) - (abs (- (ldb (byte 8 8) c) cg)) - (abs (- (ldb (byte 8 0) c) cb))))) - (do-pixels () - (when (< (color-distance (raw-pixel)) 6) - (setf (raw-pixel) color)))))))) + (parse-color bgcolor) + (allocate-color 255 255 255)))) + (fill-image 0 0 :color color) + (copy-image input-image cell + 0 0 + x-offset + y-offset + width height + :resize t :resample t + :dest-width thumbnail-width :dest-height thumbnail-height) + (unless bgcolor + (setf (transparent-color) color) + (let ((cr (ldb (byte 8 16) color)) + (cg (ldb (byte 8 8) color)) + (cb (ldb (byte 8 0) color))) + (flet ((color-distance (c) + (+ (abs (- (ldb (byte 8 16) c) cr)) + (abs (- (ldb (byte 8 8) c) cg)) + (abs (- (ldb (byte 8 0) c) cb))))) + (do-pixels () + (when (< (color-distance (raw-pixel)) 6) + (setf (raw-pixel) color)))))))) cell)) (define-imageproc-handler thumbnail (input-image &optional bgcolor max-width max-height) @@ -93,50 +93,50 @@ (setf max-width (if max-width (parse-integer max-width) *thumbnail-max-width*)) (setf max-height (if max-height (parse-integer max-height) *thumbnail-max-height*)) (let ((width (image-width input-image)) - (height (image-height input-image))) + (height (image-height input-image))) (when (or (< max-width width) - (< max-height height)) + (< max-height height)) (let* ((ratio (max (/ width max-width) - (/ height max-height))) - (thumbnail-width (round (/ width ratio))) - (thumbnail-height (round (/ height ratio))) - (thumbnail (create-image thumbnail-width - thumbnail-height - t))) - (with-default-image (thumbnail) - (fill-image 0 0 :color (parse-color bgcolor)) - (copy-image input-image thumbnail - 0 0 0 0 - width height - :resize t :resample t - :dest-width thumbnail-width :dest-height thumbnail-height)) - thumbnail)))) + (/ height max-height))) + (thumbnail-width (round (/ width ratio))) + (thumbnail-height (round (/ height ratio))) + (thumbnail (create-image thumbnail-width + thumbnail-height + t))) + (with-default-image (thumbnail) + (fill-image 0 0 :color (parse-color bgcolor)) + (copy-image input-image thumbnail + 0 0 0 0 + width height + :resize t :resample t + :dest-width thumbnail-width :dest-height thumbnail-height)) + thumbnail)))) (define-imageproc-handler double (input-image &optional (times "2")) (let* ((width (image-width input-image)) - (height (image-height input-image)) - (ratio (/ 1 (parse-integer times))) - (double-image-width (round (/ width ratio))) - (double-image-height (round (/ height ratio))) - (double-image (create-image double-image-width double-image-height nil))) + (height (image-height input-image)) + (ratio (/ 1 (parse-integer times))) + (double-image-width (round (/ width ratio))) + (double-image-height (round (/ height ratio))) + (double-image (create-image double-image-width double-image-height nil))) (with-default-image (double-image) (setf (transparent-color double-image) - (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t)) + (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t)) (fill-image 0 0 :color (transparent-color double-image)) (copy-image input-image double-image - 0 0 0 0 width height - :resize t - :dest-width double-image-width :dest-height double-image-height)) + 0 0 0 0 width height + :resize t + :dest-width double-image-width :dest-height double-image-height)) double-image)) (define-imageproc-handler color (input-image &rest color-mappings) (with-default-image (input-image) (let ((colors (loop for (old new) on color-mappings by #'cddr - collect (cons (parse-color old) (parse-color new))))) + collect (cons (parse-color old) (parse-color new))))) (do-pixels (input-image) - (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) - (when (cdr new-color) - (setf (raw-pixel) (cdr new-color))))))) + (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) + (when (cdr new-color) + (setf (raw-pixel) (cdr new-color))))))) input-image) (defun image-url (image &key process (prefix "/image")) @@ -146,19 +146,19 @@ (if (string-equal color-string "transparent") (transparent-color image) (let ((components (multiple-value-bind (match strings) - (scan-to-strings "^#?(..)(..)(..)?$" color-string) - (if match - (mapcar #'(lambda (string) (when string (parse-integer string :radix 16))) - (coerce strings 'list)) - (progn - (warn "can't parse color spec ~a" color-string) - '(0 0 0)))))) - (let ((color (find-color (first components) (second components) (third components) - :exact t :image image))) - (unless color - (setf color (find-color (first components) (second components) (third components) - :exact nil :resolve t :image image))) - color)))) + (scan-to-strings "^#?(..)(..)(..)?$" color-string) + (if match + (mapcar #'(lambda (string) (when string (parse-integer string :radix 16))) + (coerce strings 'list)) + (progn + (warn "can't parse color spec ~a" color-string) + '(0 0 0)))))) + (let ((color (find-color (first components) (second components) (third components) + :exact t :image image))) + (unless color + (setf color (find-color (first components) (second components) (third components) + :exact nil :resolve t :image image))) + color)))) (defclass imageproc-handler (image-handler) ()) @@ -174,14 +174,14 @@ #+(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))) + (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)))))))) + (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)))))))) Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Wed Feb 13 15:22:21 2008 @@ -4,7 +4,7 @@ (defvar *toplevel-children*) -(define-bknr-tag toplevel (&key children title (template "toplevel")) +(define-bknr-tag toplevel (&key title (template "toplevel")) (setf (get-template-var :title) title) (when (and (not (scan "^/" template)) (scan "/" (request-variable :template-path))) @@ -14,8 +14,8 @@ (let* ((expander *template-expander*) (pathname (find-template-pathname expander template)) (toplevel (get-cached-template pathname expander)) - (*toplevel-children* children)) - (emit-template-node toplevel))) + (*toplevel-children* *tag-children*)) + (emit-template-node *template-expander* toplevel))) (define-bknr-tag tag-body () (let ((*tag-children* *toplevel-children*)) Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/webserver.lisp (original) +++ branches/trunk-reorg/projects/bos/web/webserver.lisp Wed Feb 13 15:22:21 2008 @@ -195,6 +195,7 @@ (setf *worldpay-test-mode* worldpay-test-mode) (setf bknr.web:*upload-file-size-limit* 20000000) + (setf hunchentoot::*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (make-instance 'bos-website :name "create-rainforest.org CMS" Modified: branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp Wed Feb 13 15:22:21 2008 @@ -4,36 +4,35 @@ (define-imageproc-handler cutout-button (input-image &optional keyword (background-color "ffffff")) (let ((button-image (create-image *button-size* *button-size* t)) - (square-size (min (image-width input-image) (image-height input-image))) - (x-offset (if (> (image-width input-image) (image-height input-image)) - (round (/ (- (image-width input-image) (image-height input-image)) 2)) - 0))) + (square-size (min (image-width input-image) (image-height input-image))) + (x-offset (if (> (image-width input-image) (image-height input-image)) + (round (/ (- (image-width input-image) (image-height input-image)) 2)) + 0))) (copy-image input-image button-image - x-offset 0 - 0 0 - square-size square-size - :resize t :resample t - :dest-width *button-size* :dest-height *button-size*) + x-offset 0 + 0 0 + square-size square-size + :resize t :resample t + :dest-width *button-size* :dest-height *button-size*) (when keyword (let ((type-store-image (store-image-with-name (format nil "type-~(~A~)" keyword)))) - (unless type-store-image - (error "can't find type image for keyword ~A" keyword)) - (with-store-image (type-image type-store-image) - (copy-image type-image button-image - 0 0 - 0 0 - (image-width type-image) (image-height type-image))))) + (unless type-store-image + (error "can't find type image for keyword ~A" keyword)) + (with-store-image (type-image type-store-image) + (copy-image type-image button-image + 0 0 + 0 0 + (image-width type-image) (image-height type-image))))) (with-store-image (mask-image (store-image-with-name "button-mask")) - #-(or) ;; notyet (let ((color (parse-color background-color :image mask-image)) - (white (parse-color "ffffff" :image mask-image))) - (do-pixels (mask-image) - (if (eql (ldb (byte 24 0) (raw-pixel)) white) - (setf (raw-pixel) color)))) + (white (parse-color "ffffff" :image mask-image))) + (do-pixels (mask-image) + (when t (eql (ldb (byte 24 0) (raw-pixel)) white) + (setf (raw-pixel) color)))) (copy-image mask-image button-image - 0 0 - 0 0 - *button-size* *button-size*)) + 0 0 + 0 0 + *button-size* *button-size*)) button-image)) (define-imageproc-handler center-thumbnail (input-image width height) Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/tags.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp Wed Feb 13 15:22:21 2008 @@ -2,6 +2,8 @@ (define-bknr-tag version-and-last-change (&rest args) (format *debug-io* "hello world: ~A~%" args) - (html "v1.1 | updated " (:princ-safe (string-downcase - (substitute #\Space #\- - (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil)))))) \ No newline at end of file + (html "v1.1 | updated " + (:princ-safe (string-downcase + (substitute #\Space #\- + (format-date-time (last-image-upload-timestamp) + :vms-style t :show-time nil)))))) \ No newline at end of file Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Wed Feb 13 15:22:21 2008 @@ -129,6 +129,8 @@ (defun emit-without-quoting (str) ;; das ist fuer WPDISPLAY + (format t "emit-without-quoting does not work~%") + #+(or) (let ((s (cxml::chained-handler *html-sink*))) (cxml::maybe-close-tag s) (map nil (lambda (c) (cxml::write-rune c s)) str)))

1 0

[bknr-cvs] r2487 - in branches/trunk-reorg/thirdparty/drakma-0.11.3: . doc
by hhubner＠common-lisp.net 13 Feb '08

13 Feb '08

Author: hhubner Date: Wed Feb 13 14:41:09 2008 New Revision: 2487 Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/ branches/trunk-reorg/thirdparty/drakma-0.11.3/CHANGELOG.txt (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/cookies.lisp (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/ branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/index.html (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/drakma.asd (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/packages.lisp (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/read.lisp (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/request.lisp (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/specials.lisp (contents, props changed) branches/trunk-reorg/thirdparty/drakma-0.11.3/util.lisp (contents, props changed) Log: Add drakma Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/CHANGELOG.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/CHANGELOG.txt Wed Feb 13 14:41:09 2008 @@ -0,0 +1,147 @@ +Version 0.11.3 +2008-01-14 +The previous change is only needed for Windows + +Version 0.11.2 +2008-01-14 +Disable WRITE-TIMEOUT for LW5.0 if SSL is used (reported by Nico de Jager) + +Version 0.11.1 +2007-10-11 +Make Drakma work with AllegroCL's "modern" mode (patch by Ross Jekel) +Needs at least Chunga 0.4.1 and FLEXI-STREAMS 0.13.1 + +Version 0.11.0 +2007-10-01 +Added *TEXT-CONTENT-TYPES* and *BODY-FORMAT-FUNCTION* (suggested by Peter Eddy) + +Version 0.10.2 +2007-09-29 +Fixed bug introduced in latest change... (reported by Ross Jekel) + +Version 0.10.1 +2007-09-25 +Use parameters in URI if they weren't used up for the content body (suggested by Jan Rychter) + +Version 0.10.0 +2007-09-18 +Added support for "HttpOnly" cookie attribute (due to a bug report by Alexey Goldin) + +Version 0.9.1 +2007-07-12 +Improved CL+SSL support (patch by David Lichteblau) + +Version 0.9.0 +2007-06-30 +Added reason phrase to return values (patch by Holger D�rer) + +Version 0.8.0 +2007-06-25 +In cookie dates, accept time zones different from "GMT" (reported by Didier Verna) +Added *ignore-unparseable-cookie-dates-p* + +Version 0.7.1 +2007-06-17 +Allow streams or functions as file designators (suggested by Andrei Stebakov) + +Version 0.7.0 +2007-04-07 +Switched from trivial-sockets to usocket (patch by Erik Huelsmann) + +Version 0.6.2 +2007-03-09 +Fixed release dates (thanks to Jeffrey Cunningham) + +Version 0.6.1 +2007-03-08 +Changed SPLIT-STRING so that it doesn't rely on unspecified behaviour (reported by Jianshi Huang) + +Version 0.6.0 +2007-02-08 +Make sure stream is closed in case of early errors (thanks to Chris Dean for test data) +Robustified cookie parsing +Send all outgoing cookies in one fell swoop (for Sun's buggy web server) +Deal with empty Location headers +Deal with corrupted Content-Type headers + +Version 0.5.5 +2007-02-05 +Fixed socket leak in case of redirects (bug report by Chris Dean) + +Version 0.5.4 +2006-12-01 +Workaround for servers which send headers after 100 status line (provided by Donavon Keithley) + +Version 0.5.3 +2006-10-11 +Set stream element type for binary streams as needed for CLISP (reported by Magnus Henoch) + +Version 0.5.2 +2006-10-08 +Adhere to user-provided content length if FORM-DATA is true + +Version 0.5.1 +2006-10-07 +Take Content-Encoding header into account (due to a bug report by Gregory Tod) + +Version 0.5.0 +2006-09-25 +Fixed bug where body sometimes wasn't read (reported by Ivan Toshkov) +Added AUTO-REFERER feature (thanks to Colin Simmonds) + +Version 0.4.4 +2006-09-24 +Treat "localhost" special for cookies (reported by Ivan Toshkov) + +Version 0.4.3 +2006-09-24 +Circumvent CL+SSL for AllegroCL (suggested by David Lichteblau) + +Version 0.4.2 +2006-09-07 +Fixed :OPTIONS* method + +Version 0.4.1 +2006-09-07 +Added more methods including :OPTIONS* pseudo method (suggested by Ralf Mattes) +Always (except for POST) add parameters to URI query +Always read body (unless there's no chunking and no content length) + +Version 0.4.0 +2006-09-05 +Added file uploads +Added multipart/form-data +Added enforced computation of request bodies in RAM +Use LF line endings in default external format + +Version 0.3.1 +2006-09-04 +Don't use underlying streams of flexi streams anymore +Returned streams now have element type OCTET when FORCE-BINARY is true +Better default "User-Agent" header for some Lisps +Added info about mailing lists +Added note about Gentoo + +Version 0.3.0 +2006-09-02 +Added client-side chunked encoding and various ways to send the content + +Version 0.2.0 +2006-09-01 +Completely re-factored for portability, chunking code is in Chunga now + +Version 0.1.3 +2006-08-30 +REQUIRE "comm" before WITH-STREAM-INPUT-BUFFER is used + +Version 0.1.2 +2006-08-27 +Notes about SSL and listener font + +Version 0.1.1 +2006-08-27 +Note about CL-BASE64 and KMRCL + +Version 0.1.0 +2006-08-27 +First public release Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/cookies.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/cookies.lisp Wed Feb 13 14:41:09 2008 @@ -0,0 +1,309 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/drakma/cookies.lisp,v 1.15 2008/01/14 01:57:01 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :drakma) + +(defclass cookie () + ((name :initarg :name + :initform (error "A cookie must have a name.") + :accessor cookie-name + :documentation "The name of the cookie.") + (value :initarg :value + :initform "" + :accessor cookie-value + :documentation "The cookie's value.") + (domain :initarg :domain + :initform (error "A cookie must have a domain.") + :accessor cookie-domain + :documentation "The domain the cookie is valid for.") + (path :initarg :path + :initform "/" + :accessor cookie-path + :documentation "The path prefix the cookie is valid for.") + (expires :initarg :expires + :initform nil + :accessor cookie-expires + :documentation "When the cookie expires. A Lisp +universal time or NIL.") + (securep :initarg :securep + :initform nil + :accessor cookie-securep + :documentation "Whether the cookie must only be +transmitted over secure connections.") + (http-only-p :initarg :http-only-p + :initform nil + :accessor cookie-http-only-p + :documentation "Whether the cookie should not be +accessible from Javascript. + +This is a Microsoft extension that has been implemented in Firefox as +well. See <http://msdn2.microsoft.com/en-us/library/ms533046.aspx>.")) + (:documentation "Elements of this class represent HTTP cookies.")) + +(defun render-cookie-date (time) + "Returns a string representation of the universal time TIME +which can be used for cookie headers." + (multiple-value-bind (second minute hour date month year weekday) + (decode-universal-time time 0) + (format nil "~A, ~2,'0d-~2,'0d-~4,'0d ~2,'0d:~2,'0d:~2,'0d GMT" + (aref #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") weekday) + date month year hour minute second))) + +(defmethod print-object ((cookie cookie) stream) + "Prints a representation of COOKIE similar to a `Set-Cookie' header." + (print-unreadable-object (cookie stream :type t) + (with-slots (name value expires path domain securep http-only-p) + cookie + (format stream "~A~@[=~A~]~@[; expires=~A~]~@[; path=~A~]~@[; domain=~A~]~@[; secure~]~@[; HttpOnly~]" + name (and (plusp (length value)) value) + (and expires (render-cookie-date expires)) + path domain securep http-only-p)))) + +(defun normalize-cookie-domain (domain) + "Adds a dot at the beginning of the string DOMAIN unless there +is already one." + (cond ((starts-with-p domain ".") domain) + (t (format nil ".~A" domain)))) + +(defun valid-cookie-domain-p (domain) + "Checks if the string DOMAIN contains enough dots to be +acceptable." + (or (string-equal domain "localhost") + (> (count #\. (normalize-cookie-domain domain) :test #'char=) 1))) + +(defun cookie-domain-matches (domain uri) + "Checks if the domain DOMAIN \(a string) matches the \(PURI) URI URI." + (ends-with-p (normalize-cookie-domain (uri-host uri)) + (normalize-cookie-domain domain))) + +(defun send-cookie-p (cookie uri force-ssl) + "Checks if the cookie COOKIE should be sent to the server +depending on the \(PURI) URI URI and the value of FORCE-SSL \(as +in HTTP-REQUEST)." + (and ;; check domain + (cookie-domain-matches (cookie-domain cookie) uri) + ;; check path + (starts-with-p (uri-path uri) (cookie-path cookie)) + ;; check expiry date + (let ((expires (cookie-expires cookie))) + (or (null expires) + (> expires (get-universal-time)))) + ;; check if connection must be secure + (or (null (cookie-securep cookie)) + force-ssl + (eq (uri-scheme uri) :https)))) + +(defun check-cookie (cookie) + "Checks if the slots of the COOKIE object COOKIE have valid +values and raises a corresponding error otherwise." + (with-slots (name value domain path expires) + cookie + (unless (and (stringp name) (plusp (length name))) + (error "Cookie name ~S must be a non-empty string." name)) + (unless (stringp value) + (error "Cookie value ~S must be a non-empty string." value)) + (unless (valid-cookie-domain-p domain) + (error "Invalid cookie domain ~S." domain)) + (unless (and (stringp path) (plusp (length path))) + (error "Cookie path ~S must be a non-empty string." path)) + (unless (or (null expires) + (and (integerp expires) + (plusp expires))) + (error "Cookie expiry ~S should have been NIL or a universal time." expires)))) + +(defmethod initialize-instance :after ((cookie cookie) &rest initargs) + "Check cookie validity after creation." + (declare (ignore initargs)) + (check-cookie cookie)) + +(defmethod (setf cookie-name) :after (new-value (cookie cookie)) + "Check cookie validity after name change." + (declare (ignore new-value)) + (check-cookie cookie)) + +(defmethod (setf cookie-value) :after (new-value (cookie cookie)) + "Check cookie validity after value change." + (declare (ignore new-value)) + (check-cookie cookie)) + +(defmethod (setf cookie-domain) :after (new-value (cookie cookie)) + "Check cookie validity after domain change." + (declare (ignore new-value)) + (check-cookie cookie)) + +(defmethod (setf cookie-path) :after (new-value (cookie cookie)) + "Check cookie validity after path change." + (declare (ignore new-value)) + (check-cookie cookie)) + +(defmethod (setf cookie-expires) :after (new-value (cookie cookie)) + "Check cookie validity after expiry change." + (declare (ignore new-value)) + (check-cookie cookie)) + +(defun cookie= (cookie1 cookie2) + "Returns true if the cookies COOKIE1 and COOKIE2 are equal. +Two cookies are considered to be equal if name and path are +equal." + (and (string= (cookie-name cookie1) (cookie-name cookie2)) + (string= (cookie-path cookie1) (cookie-path cookie2)))) + +(defclass cookie-jar () + ((cookies :initarg :cookies + :initform nil + :accessor cookie-jar-cookies + :documentation "A list of the cookies in this cookie jar.")) + (:documentation "A COOKIE-JAR object is a collection of cookies.")) + +(defmethod print-object ((cookie-jar cookie-jar) stream) + "Print a cookie jar, showing the number of cookies it contains." + (print-unreadable-object (cookie-jar stream :type t :identity t) + (format stream "(with ~A cookie~:P)" (length (cookie-jar-cookies cookie-jar))))) + +(defun parse-cookie-date (string) + "Parses a cookie expiry date and returns it as a Lisp universal +time. Currently understands the following formats: + + \"Wed, 06-Feb-2008 21:01:38 GMT\" + \"Wed, 06-Feb-08 21:01:38 GMT\" + \"Tue Feb 13 08:00:00 2007 GMT\" + \"Wednesday, 07-February-2027 08:55:23 GMT\" + \"Wed, 07-02-2017 10:34:45 GMT\" + +Instead of \"GMT\" time zone abbreviations like \"CEST\" and UTC +offsets like \"GMT-01:30\" are also allowed." + ;; it seems like everybody and their sister invents their own format + ;; for this, so (as there's no real standard for it) we'll have to + ;; make this function more flexible once we come across something + ;; new; as an alternative we could use net-telent-date, but it also + ;; fails to parse some of the stuff you encounter in the wild; or we + ;; could try to employ CL-PPCRE, but that'd add a new dependency + ;; without making this code much cleaner + (handler-case + (let* ((last-space-pos (or (position #\Space string :test #'char= :from-end t) + (error "Can't parse cookie date ~S, no space found." string))) + (time-zone-string (subseq string (1+ last-space-pos))) + (time-zone (interpret-as-time-zone time-zone-string)) + second minute hour day month year) + (dolist (part (rest (split-string (subseq string 0 last-space-pos)))) + (when (and day month) + (cond ((every #'digit-char-p part) + (when year + (error "Can't parse cookie date ~S, confused by ~S part." string part)) + (setq year (parse-integer part))) + ((= (count #\: part :test #'char=) 2) + (let ((h-m-s (mapcar #'safe-parse-integer (split-string part ":")))) + (setq hour (first h-m-s) + minute (second h-m-s) + second (third h-m-s)))) + (t (error "Can't parse cookie date ~S, confused by ~S part." string part)))) + (cond ((null day) + (unless (setq day (safe-parse-integer part)) + (setq month (interpret-as-month part)))) + ((null month) + (setq month (interpret-as-month part))))) + (unless (and second minute hour day month year) + (error "Can't parse cookie date ~S, component missing." string)) + (when (< year 100) + (setq year (+ year 2000))) + (encode-universal-time second minute hour day month year time-zone)) + (error (condition) + (cond (*ignore-unparseable-cookie-dates-p* + (warn "~A" condition) + nil) + (t (error condition)))))) + +(defun parse-set-cookie (string) + "Parses the `Set-Cookie' header line STRING and returns a list +of three-element lists where each one contains the name of the +cookie, the value of the cookie, and an attribute/value list for +the optional cookie parameters." + (with-input-from-string (stream string) + (loop with *current-error-message* = (format nil "While parsing cookie header ~S:" string) + for first = t then nil + for next = (and (skip-whitespace stream) + (or first (assert-char stream #\,)) + (skip-whitespace stream) + (skip-more-commas stream)) + for name/value = (and next (read-name-value-pair stream + :cookie-syntax t)) + for parameters = (and name/value (read-name-value-pairs stream + :value-required-p nil + :cookie-syntax t)) + while name/value + collect (list (car name/value) (cdr name/value) parameters)))) + +(defun get-cookies (headers uri) + "Returns a list of COOKIE objects corresponding to the +`Set-Cookie' header as found in HEADERS \(an alist as returned by +HTTP-REQUEST). Collects only cookies which match the domain of +the \(PURI) URI URI." + (loop with set-cookie-header = (header-value :set-cookie headers) + with parsed-cookies = (and set-cookie-header (parse-set-cookie set-cookie-header)) + for (name value parameters) in parsed-cookies + for expires = (parameter-value "expires" parameters) + for domain = (or (parameter-value "domain" parameters) (uri-host uri)) + when (and (valid-cookie-domain-p domain) + (cookie-domain-matches domain uri)) + collect (make-instance 'cookie + :name name + :value value + :path (or (parameter-value "path" parameters) + (uri-path uri) + "/") + :expires (and expires + (plusp (length expires)) + (parse-cookie-date expires)) + :domain domain + :securep (not (not (parameter-present-p "secure" parameters))) + :http-only-p (not (not (parameter-present-p "HttpOnly" parameters)))))) + +(defun update-cookies (new-cookies cookie-jar) + "Updates the cookies in COOKIE-JAR by replacing those which are +equal to a cookie in \(the list) NEW-COOKIES with the corresponding +`new' cookie and adding those which are really new." + (setf (cookie-jar-cookies cookie-jar) + (let ((updated-cookies + (loop for old-cookie in (cookie-jar-cookies cookie-jar) + collect (or (find old-cookie new-cookies :test #'cookie=) + old-cookie)))) + (union updated-cookies + (set-difference new-cookies updated-cookies)))) + cookie-jar) + +(defun delete-old-cookies (cookie-jar) + "Removes all cookies from COOKIE-JAR which have either expired +or which don't have an expiry date." + (setf (cookie-jar-cookies cookie-jar) + (loop with now = (get-universal-time) + for cookie in (cookie-jar-cookies cookie-jar) + for expires = (cookie-expires cookie) + unless (or (null expires) (< expires now)) + collect cookie)) + cookie-jar) Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/index.html ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/index.html Wed Feb 13 14:41:09 2008 @@ -0,0 +1,1472 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<html> + +<head> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> + <title>DRAKMA - A Common Lisp web client</title> + <style type="text/css"> + pre { padding:5px; background-color:#e0e0e0 } + h3, h4 { text-decoration: underline; } + a { text-decoration: none; padding: 1px 2px 1px 2px; } + a:visited { text-decoration: none; padding: 1px 2px 1px 2px; } + a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } + a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; } + a.none { text-decoration: none; padding: 0; } + a.none:visited { text-decoration: none; padding: 0; } + a.none:hover { text-decoration: none; border: none; padding: 0; } + a.none:focus { text-decoration: none; border: none; padding: 0; } + a.noborder { text-decoration: none; padding: 0; } + a.noborder:visited { text-decoration: none; padding: 0; } + a.noborder:hover { text-decoration: none; border: none; padding: 0; } + a.noborder:focus { text-decoration: none; border: none; padding: 0; } + pre.none { padding:5px; background-color:#ffffff } + </style> +</head> + +<body bgcolor=white> + +<h2>DRAKMA - A Common Lisp web client</h2> + +<blockquote> +   <h3><a name=abstract class=none>Abstract</a></h3> + +Drakma is a fully-featured web client (implemented in Common Lisp) +that knows how to handle <a href="#chunked">HTTP/1.1 +chunking</a>, <a href="#keep-alive">persistent +connections</a>, <a href="#re-use">re-usable +sockets</a>, <a href="#force-ssl">SSL</a>, <a href="#cont">continuable +uploads</a>, <a href="#form-data">file uploads</a>, <a href="#cookie-jar-param">cookies</a>, and other +things. And it's probably a result of +my <a href="http://en.wikipedia.org/wiki/Not_Invented_Here">NIH +syndrome</a>... + +Drakma was developed and tested +with <a href="http://www.lispworks.com/">LispWorks</a>, but it should +also work with a couple of other Common Lisp implementations depending +on the <a href="#download">supporting libraries</a>. Some tests +with <a href="http://www.sbcl.org/">SBCL</a> seem to confirm this. + +The code comes with +a <a +href="http://www.opensource.org/licenses/bsd-license.php">BSD-style +license</a> so you can basically do with it whatever you want. + + +Download shortcut: <a href="http://weitz.de/files/drakma.tar.gz">http://weitz.de/files/drakma.tar.gz</a>. +</blockquote> + +   <h3><a class=none name="contents">Contents</a></h3> +<ol> + <li><a href="#example">Examples</a> + <li><a href="#download">Download and installation</a> + <li><a href="#mail">Support and mailing lists</a> + <li><a href="#dictionary">The Drakma dictionary</a> + <ol> + <li><a href="#request">The request</a> + <ol> + <li><a href="#http-request"><code>http-request</code></a> + <li><a href="#*drakma-default-external-format*"><code>*drakma-default-external-format*</code></a> + <li><a href="#*text-content-types*"><code>*text-content-types*</code></a> + <li><a href="#*body-format-function*"><code>*body-format-function*</code></a> + <li><a href="#*header-stream*"><code>*header-stream*</code></a> + </ol> + <li><a href="#cookies">Cookies</a> + <ol> + <li><a href="#cookie"><code>cookie</code></a> + <li><a href="#cookie-name"><code>cookie-name</code></a> + <li><a href="#cookie-value"><code>cookie-value</code></a> + <li><a href="#cookie-domain"><code>cookie-domain</code></a> + <li><a href="#cookie-path"><code>cookie-path</code></a> + <li><a href="#cookie-expires"><code>cookie-expires</code></a> + <li><a href="#cookie-securep"><code>cookie-securep</code></a> + <li><a href="#cookie-http-only-p"><code>cookie-http-only-p</code></a> + <li><a href="#cookie-jar"><code>cookie-jar</code></a> + <li><a href="#cookie-jar-cookies"><code>cookie-jar-cookies</code></a> + <li><a href="#cookie="><code>cookie=</code></a> + <li><a href="#delete-old-cookies"><code>delete-old-cookies</code></a> + <li><a href="#*ignore-unparseable-cookie-dates-p*"><code>*ignore-unparseable-cookie-dates-p*</code></a> + </ol> + <li><a href="#headers">Headers</a> + <ol> + <li><a href="#header-value"><code>header-value</code></a> + <li><a href="#split-tokens"><code>split-tokens</code></a> + <li><a href="#read-tokens-and-parameters"><code>read-tokens-and-parameters</code></a> + <li><a href="#parameter-present-p"><code>parameter-present-p</code></a> + <li><a href="#parameter-value"><code>parameter-value</code></a> + <li><a href="#get-content-type"><code>get-content-type</code></a> + </ol> + </ol> + <li><a href="#prob">Potential problems</a> + <li><a href="#ack">Acknowledgements</a> +</ol> + +   <h3><a class=none name="example">Examples</a></h3> + +Here's an example session with Drakma 0.3.0 which demonstrates +some of its features. (Some linebreaks were added or removed to +enhance legibility.) Note that this doesn't necessarily reflect the +current versions of Drakma and Hunchentoot. The examples should work +nevertheless - kind of... + +<pre> +;; create a log file of this sessions +CL-USER 1 > (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/f_dribbl.htm">dribble</a> "/tmp/drakma_dribble") +; Loading C:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\ccl\dribble.ofasl on demand... + +;; load Drakma +CL-USER 2 > (<a class=noborder href="http://www.cliki.net/asdf">asdf</a>:oos 'asdf:load-op :drakma) +; loading system definition from c:\home\lisp\drakma\drakma.asd into +; #<The ASDF0 package, 0/16 internal, 0/16 external> +; Loading text file c:\home\lisp\drakma\drakma.asd +; registering #<SYSTEM :DRAKMA 21D6D24F> as DRAKMA +;; Creating system COMMON-LISP-USER::DRAKMA +; loading system definition from c:\home\lisp\<a class=noborder href="http://globalia.net/donlope/fz/songs/Chunga's_Revenge.html">chunga</a>\chunga.asd into +; #<The ASDF0 package, 0/16 internal, 0/16 external> +; Loading text file c:\home\lisp\chunga\chunga.asd +; registering #<SYSTEM :CHUNGA 200B12A3> as CHUNGA +;; Creating system COMMON-LISP-USER::CHUNGA +; loading system definition from c:\home\lisp\flexi-streams\flexi-streams.asd into +; #<The ASDF0 package, 0/16 internal, 0/16 external> +; Loading text file c:\home\lisp\flexi-streams\flexi-streams.asd +; registering #<SYSTEM :FLEXI-STREAMS 200E8017> as FLEXI-STREAMS +;; Creating system COMMON-LISP-USER::FLEXI-STREAMS +; loading system definition from c:\home\lisp\trivial-gray-streams\trivial-gray-streams.asd into +; #<The ASDF0 package, 0/16 internal, 0/16 external> +; Loading text file c:\home\lisp\trivial-gray-streams\trivial-gray-streams.asd +; registering #<SYSTEM :TRIVIAL-GRAY-STREAMS 21D6741F> as TRIVIAL-GRAY-STREAMS +;; Creating system COMMON-LISP-USER::TRIVIAL-GRAY-STREAMS +; loading system definition from c:\home\lisp\cl-base64-3.3.2\cl-base64.asd into +; #<The ASDF0 package, 0/16 internal, 0/16 external> +; Loading text file c:\home\lisp\cl-base64-3.3.2\cl-base64.asd +; registering #<SYSTEM CL-BASE64 21D6D277> as CL-BASE64 +;; Creating system COMMON-LISP-USER::CL-BASE64 +; registering #<SYSTEM CL-BASE64-TESTS 2009701B> as CL-BASE64-TESTS +;; Creating system COMMON-LISP-USER::CL-BASE64-TESTS +; loading system definition from c:\home\lisp\puri-1.5\puri.asd into +; #<The ASDF0 package, 0/16 internal, 0/16 external> +; Loading text file c:\home\lisp\puri-1.5\puri.asd +; registering #<SYSTEM PURI 21D6B093> as PURI +;; Creating system COMMON-LISP-USER::PURI +; registering #<SYSTEM PURI-TESTS 200CFEEF> as PURI-TESTS +;; Creating system COMMON-LISP-USER::PURI-TESTS +; Loading fasl file c:\home\lisp\trivial-gray-streams\package.ofasl +; Loading fasl file c:\home\lisp\trivial-gray-streams\mixin.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\packages.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\ascii.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\iso-8859.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\code-pages.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\specials.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\util.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\external-format.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\in-memory.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\stream.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\output.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\input.ofasl +; Loading fasl file c:\home\lisp\flexi-streams\strings.ofasl +; Loading fasl file c:\home\lisp\chunga\packages.ofasl +; Loading fasl file c:\home\lisp\chunga\specials.ofasl +; Loading fasl file c:\home\lisp\chunga\util.ofasl +; Loading fasl file c:\home\lisp\chunga\read.ofasl +; Loading fasl file c:\home\lisp\chunga\streams.ofasl +; Loading fasl file c:\home\lisp\chunga\input.ofasl +; Loading fasl file c:\home\lisp\chunga\output.ofasl +; Loading fasl file c:\home\lisp\cl-base64-3.3.2\package.ofasl +; Loading fasl file c:\home\lisp\cl-base64-3.3.2\encode.ofasl +; Loading fasl file c:\home\lisp\cl-base64-3.3.2\decode.ofasl +; Loading fasl file c:\home\lisp\puri-1.5\src.ofasl +; Loading fasl file c:\home\lisp\drakma\packages.ofasl +; Loading fasl file c:\home\lisp\drakma\specials.ofasl +; Loading fasl file c:\home\lisp\drakma\util.ofasl +; Loading c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\comm-defsys.lisp on demand... +;; Creating system COMM + +; Loading text file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\comm-pkg.lisp +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\sockets.ofasl +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl-constants.ofasl +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl-foreign-types.ofasl +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl.ofasl +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl-certs.ofasl +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0001.ofasl +; Loaded public patch COMM 1.1 + +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0002.ofasl +; Loaded public patch COMM 1.2 + +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0003.ofasl +; Loaded public patch COMM 1.3 + +; Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0004.ofasl +; Loaded public patch COMM 1.4 + +; Loading fasl file c:\home\lisp\drakma\read.ofasl +; Loading fasl file c:\home\lisp\drakma\cookies.ofasl +; Loading fasl file c:\home\lisp\drakma\request.ofasl +NIL + +;; create a package to work in +CL-USER 3 > (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_defpkg.htm" class=noborder>defpackage</a> :drakma-user (:use :cl :drakma)) +#<The DRAKMA-USER package, 0/16 internal, 0/16 external> + +;; switch to this package +CL-USER 4 > (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_in_pkg.htm" class=noborder>in-package</a> :drakma-user) +#<The DRAKMA-USER package, 0/16 internal, 0/16 external> + +;; log headers, so we can see what happens - +;; output to <a class=noborder href="#*header-stream*"><code>*HEADER-STREAM*</code></a> will be shown in green below +DRAKMA-USER 5 > (setq <a class=noborder href="#*header-stream*">*header-stream*</a> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/v_debug_.htm" class=noborder>*standard-output*</a>) +#<Broadcast stream to (#<Echo Stream Input = #<EDITOR::RUBBER-STREAM #<EDITOR:BUFFER CAPI interactive-pane 2> 2198ECD7>, + Output = #<STREAM::LATIN-1-FILE-STREAM c:\tmp\drakma_dribble>> + #<EDITOR::RUBBER-STREAM #<EDITOR:BUFFER CAPI interactive-pane 2> 2198ECD7>)> + +;; note how Drakma automatically follows the 301 redirect and how the fourth return value shows the new URI +DRAKMA-USER 6 > (<a class=noborder href="#http-request">http-request</a> "<a href="http://lisp.org/" class=noborder>http://lisp.org/</a>") +GET / HTTP/1.1 +Host: lisp.org +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 301 Moved Permanently +Date: Sat, 26 Aug 2006 15:46:31 GMT +Connection: Close +Server: <a href="http://opensource.franz.com/aserve/" class=noborder>AllegroServe</a>/1.2.37 +Transfer-Encoding: chunked +LOCATION: /index.html + +GET /index.html HTTP/1.1 +Host: lisp.org +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 15:46:32 GMT +Connection: Close +Server: AllegroServe/1.2.37 +Content-Type: text/html +Content-Length: 82 +LAST-MODIFIED: Mon, 16 Feb 2004 09:30:02 GMT + +"<title>redirect...</title> +<meta http-equiv=\"Refresh\" content=\"0; url=/alu/home\"> +" +200 +((:DATE . "Sat, 26 Aug 2006 15:46:32 GMT") + (:CONNECTION . "Close") + (:SERVER . "AllegroServe/1.2.37") + (:CONTENT-TYPE . "text/html") + (:CONTENT-LENGTH . "82") + (:LAST-MODIFIED . "Mon, 16 Feb 2004 09:30:02 GMT")) +#<URI http://lisp.org/index.html> +#<FLEXI-STREAMS:FLEXI-IO-STREAM 201017D3> +T + +;; here, Drakma automatically interprets the 'charset=utf-8' part correctly - +;; might look a bit different in your listener depending on the font you've chosen +DRAKMA-USER 7 > (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_subseq.htm" class=noborder>subseq</a> (<a class=noborder href="#http-request">http-request</a> "<a href="http://www.cl.cam.ac.uk/~mgk25/ucs/examples/digraphs.txt" class=noborder>http://www.cl.cam.ac.uk/~mgk25/ucs/examples/digraphs.txt</a>") 0 298) +GET /~mgk25/ucs/examples/digraphs.txt HTTP/1.1 +Host: www.cl.cam.ac.uk +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 16:02:56 GMT +Server: Apache/1.3.37 (Unix) mod_ucam_webauth/1.2.2 +Last-Modified: Thu, 05 Jan 2006 20:49:55 GMT +ETag: "17cd62-298-43bd8673" +Accept-Ranges: bytes +Content-Length: 664 +Connection: close +Content-Type: text/plain; charset=utf-8 + +"Latin Digraphs and Ligatures in ISO10646-1 + +A short table of ligatures and digraphs follows. Some of these may not be +ligatures/digraphs in the technical sense, (for example, � is a seperate +letter in English), but visually they behave that way. + +A�E : U+00C6 +a�e : U+00E6 +ſ�s : U+00DF +IĲJ : U+0132" + +;; a vector of octets is returned for (non-text) binary data - a picture in this case +DRAKMA-USER 8 > (<a class=noborder href="#http-request">http-request</a> "<a href="http://zappa.com/favicon.ico" class=noborder>http://zappa.com/favicon.ico</a>") +GET /favicon.ico HTTP/1.1 +Host: zappa.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 16:02:59 GMT +Server: Apache/2.0.46 (Red Hat) +Last-Modified: Fri, 17 Mar 2006 08:11:07 GMT +ETag: "3a4080-b6-59d5bcc0" +Accept-Ranges: bytes +Content-Length: 182 +Connection: close +Content-Type: image/gif + +#(71 73 70 56 57 97 17 0 17 0 179 1 0 150 151 153 255 255 255 37 37 36 112 114 115 + 201 202 204 0 0 0 80 83 84 26 28 26 230 231 231 249 249 249 12 13 14 219 221 222 + 18 21 22 239 240 241 52 52 54 64 66 66 33 249 4 1 0 0 1 0 44 0 0 0 0 17 0 17 0 0 + 4 99 48 200 73 107 109 54 172 101 129 120 196 180 12 12 51 80 64 161 42 3 48 28 + 170 106 72 141 16 223 120 113 166 121 95 0 14 95 239 33 236 41 98 10 129 114 185 + 188 29 127 25 201 224 73 60 4 8 0 130 22 59 64 52 96 135 148 35 96 80 152 159 186 + 192 64 183 112 0 200 61 65 0 1 192 76 214 185 113 102 241 88 26 90 8 81 18 8 94 + 130 134 22 17 0 59) +200 +((:DATE . "Sat, 26 Aug 2006 16:02:59 GMT") + (:SERVER . "Apache/2.0.46 (Red Hat)") + (:LAST-MODIFIED . "Fri, 17 Mar 2006 08:11:07 GMT") + (:ETAG . "\"3a4080-b6-59d5bcc0\"") + (:ACCEPT-RANGES . "bytes") + (:CONTENT-LENGTH . "182") + (:CONNECTION . "close") + (:CONTENT-TYPE . "image/gif")) +#<URI http://zappa.com/favicon.ico> +#<FLEXI-STREAMS:FLEXI-IO-STREAM 200D59BF> +T + +;; a secure connection (see <a class=noborder href="#download">below</a>) - +;; also note that the server uses <a class=noborder name="chunked" href="http://www.rfc.net/rfc2616.html#s3.6.1">chunked transfer encoding</a> for its reply +DRAKMA-USER 9 > (<a class=noborder href="http://weitz.de/cl-ppcre/">ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#scan-to-strings">scan-to-strings</a> "(?s)You have.*your data." + (<a class=noborder href="#http-request">http-request</a> "<a href="https://www.fortify.net/cgi/ssl_2.pl" class=noborder>https://www.fortify.net/cgi/ssl_2.pl</a>")) +GET /cgi/ssl_2.pl HTTP/1.1 +Host: www.fortify.net +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 16:10:06 GMT +Server: Apache +Connection: close +Transfer-Encoding: chunked +Content-Type: text/html + + +"You have connected to this web server using the DHE-RSA-AES256-SHA encryption cipher + with a key length of 256 bits. + + This is a high-grade encryption connection, regarded by most experts as being suitable + for sending or receiving even the most sensitive or valuable information + across a network. + + In a crude analogy, using this cipher is similar to sending or storing your data inside + a high quality safe - compared to an export-grade cipher which is similar to using + a paper envelope to protect your data." +#() + +;; using a different 'User-Agent' header +DRAKMA-USER 10 > (<a class=noborder href="http://weitz.de/cl-ppcre/">ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#regex-replace-all">regex-replace-all</a> + "<.*?>" + (<a class=noborder href="http://weitz.de/cl-ppcre/">ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#scan-to-strings">scan-to-strings</a> "(?s)Your browser reports.*?</table>" + (<a class=noborder href="#http-request">http-request</a> "<a class=noborder href="http://bcheck.scanit.be/bcheck/">http://bcheck.scanit.be/bcheck/</a>" + :user-agent :explorer)) + "") +GET /bcheck/ HTTP/1.1 +Host: bcheck.scanit.be +User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727) +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 16:21:50 GMT +Server: Apache +Connection: close +Transfer-Encoding: chunked +Content-Type: text/html + + +"Your browser reports to be: + +Browser name: MSIE +Version: 6.0 +Platform: Windows NT 5.1 +" + +;; sending parameters in a POST request and working with <a href="#cookie" class=noborder>cookies</a> - +;; note how Drakma sends the cookie back in the second request +DRAKMA-USER 11 > (let ((cookie-jar (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_ins.htm" class=noborder>make-instance</a> '<a class=noborder href="#cookie-jar">cookie-jar</a>))) + (<a class=noborder href="#http-request">http-request</a> "<a class=noborder href="http://www.phpsecurepages.com/test/test.php">http://www.phpsecurepages.com/test/test.php</a>" + :method :post + :parameters '(("entered_login" . "test") + ("entered_password" . "test")) + :cookie-jar cookie-jar) + (<a class=noborder href="#http-request">http-request</a> "<a class=noborder href="http://www.phpsecurepages.com/test/test2.php">http://www.phpsecurepages.com/test/test2.php</a>" + :cookie-jar cookie-jar) + (<a class=noborder href="#cookie-jar-cookies">cookie-jar-cookies</a> cookie-jar)) +POST /test/test.php HTTP/1.1 +Host: www.phpsecurepages.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Content-Length: 40 +Content-Type: application/x-www-form-urlencoded +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 18:26:17 GMT +Server: Apache/2.0.51 (Fedora) +X-Powered-By: PHP/4.3.10 +Expires: Thu, 19 Nov 1981 08:52:00 GMT +Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0 +Pragma: no-cache +Set-Cookie: PHPSESSID=3ce33aa3e326ab4bf5da7feecc3248b4; path=/ +Connection: close +Transfer-Encoding: chunked +Content-Type: text/html + + +GET /test/test2.php HTTP/1.1 +Host: www.phpsecurepages.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Cookie: PHPSESSID=3ce33aa3e326ab4bf5da7feecc3248b4 +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 18:26:18 GMT +Server: Apache/2.0.51 (Fedora) +X-Powered-By: PHP/4.3.10 +Expires: Thu, 19 Nov 1981 08:52:00 GMT +Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0 +Pragma: no-cache +Connection: close +Transfer-Encoding: chunked +Content-Type: text/html + + +(#<<a href="#cookie" class=noborder>COOKIE</a> PHPSESSID=3ce33aa3e326ab4bf5da7feecc3248b4; path=/; domain=www.phpsecurepages.com>) + +;; now we are going to <a name="re-use" class=noborder>re-use</a> a socket for the second connection to the same server +;; this will also work with chunked encoding +DRAKMA-USER 12 > (let ((stream (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 4 (<a class=noborder href="#http-request">http-request</a> "<a class=noborder href="http://www.lispworks.com/">http://www.lispworks.com/</a>" :close nil)))) + (nth-value 2 (<a class=noborder href="#http-request">http-request</a> "<a class=noborder href="http://www.lispworks.com/success-stories/index.html">http://www.lispworks.com/success-stories/index.html</a>" + :stream stream))) +GET / HTTP/1.1 +Host: www.lispworks.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 18:34:20 GMT +Server: Apache/1.3.37 Ben-SSL/1.57 (Unix) +Last-Modified: Tue, 08 Aug 2006 18:20:49 GMT +ETag: "28ee4f0-22db-44d8d601" +Accept-Ranges: bytes +Content-Length: 8923 +Content-Type: text/html + +GET /success-stories/index.html HTTP/1.1 +Host: www.lispworks.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Date: Sat, 26 Aug 2006 18:34:20 GMT +Server: Apache/1.3.37 Ben-SSL/1.57 (Unix) +Last-Modified: Tue, 08 Aug 2006 18:22:19 GMT +ETag: "28f3f42-2325-44d8d65b" +Accept-Ranges: bytes +Content-Length: 8997 +Connection: close +Content-Type: text/html + +((:DATE . "Sat, 26 Aug 2006 18:34:20 GMT") + (:SERVER . "Apache/1.3.37 Ben-SSL/1.57 (Unix)") + (:LAST-MODIFIED . "Tue, 08 Aug 2006 18:22:19 GMT") + (:ETAG . "\"28f3f42-2325-44d8d65b\"") + (:ACCEPT-RANGES . "bytes") + (:CONTENT-LENGTH . "8997") + (:CONNECTION . "close") + (:CONTENT-TYPE . "text/html")) + +;; testing basic authorization against a local <a href="http://weitz.de/hunchentoot/" class=noborder>Hunchentoot</a> server +DRAKMA-USER 13 > (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 1 (<a class=noborder href="#http-request">http-request</a> "http://localhost:4242/<a class=noborder href="http://weitz.de/tbnl/#test">tbnl/test</a>/authorization.html")) +GET /tbnl/test/authorization.html HTTP/1.1 +Host: localhost:4242 +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 401 Authorization Required +Content-Length: 563 +Content-Type: text/html; charset=iso-8859-1 +Date: Sat, 26 Aug 2006 18:38:58 GMT +Server: <a class=noborder href="http://weitz.de/hunchentoot/">Hunchentoot</a> 0.1.5 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.10.0) +Connection: Close +WWW-Authenticate: Basic realm="TBNL" + +401 + +DRAKMA-USER 14 > (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 1 (<a class=noborder href="#http-request">http-request</a> "http://localhost:4242/<a class=noborder href="http://weitz.de/tbnl/#test">tbnl/test</a>/authorization.html" + :basic-authorization '("nanook" "igloo"))) +GET /tbnl/test/authorization.html HTTP/1.1 +Host: localhost:4242 +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Authorization: Basic bmFub29rOmlnbG9v +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Content-Length: 884 +Content-Type: text/html; charset=iso-8859-1 +Date: Sat, 26 Aug 2006 18:39:19 GMT +Server: <a class=noborder href="http://weitz.de/hunchentoot/">Hunchentoot</a> 0.1.5 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.10.0) +Connection: Close + +200 + +;; now we ask Drakma to return a stream and read from it directly +DRAKMA-USER 15 > (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/s_let_l.htm" class=noborder>let</a> ((stream (<a class=noborder href="#http-request">http-request</a> "<a href="http://www.jalat.com/blogs/lisp?id=3" class=noborder>http://www.jalat.com/blogs/lisp?id=3</a>" + :want-stream t))) + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/06_a.htm" class=noborder>loop</a> for i below 41 + for line = (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_lin.htm" class=noborder>read-line</a> stream) + when (> i 35) + do (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_stg.htm" class=noborder>write-line</a> line)) + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_close.htm" class=noborder>close</a> stream) + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/a_values.htm" class=noborder>values</a>)) +GET /blogs/lisp?id=3 HTTP/1.1 +Host: www.jalat.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close + +HTTP/1.1 200 OK +Content-Length: 21453 +Content-Type: text/html; charset=iso-8859-1 +Date: Sat, 26 Aug 2006 19:53:37 GMT +Server: <a href="http://weitz.de/hunchentoot/" class=noborder>Hunchentoot</a> 0.1.3 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.9.7) +Connection: Close + +Bill Clementson has <a +href="<a href="http://bc.tech.coop/blog/041111.html" class=noborder>http://bc.tech.coop/blog/041111.html</a>">written</a> about getting +<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> up and running with <a href="http://httpd.apache.org/" class=noborder>apache</a> and <a href="http://www.fractalconcept.com/asp/html/mod_lisp.html" class=noborder>mod_lisp</a>. In this example I'm +going to use <a href="<a href="http://weitz.de/hunchentoot/" class=noborder>http://weitz.de/hunchentoot/</a>">hunchentoot</a>, a +pure lisp web server by (again) Edi Weitz. + +<a class=noborder name="cont">;; let's test a POST request without content length and with chunked transfer encoding -</a> +;; we build the content in several steps using different types of data +;; (note: doesn't work anymore, probably due to server changes) +DRAKMA-USER 16 > (let ((temp-file (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_ensu_1.htm" class=noborder>ensure-directories-exist</a> #p"/tmp/quux.txt")) + (continuation (<a href="#http-request" class=noborder>http-request</a> "<a href="http://meme.b9.com/login.html" class=noborder>http://meme.b9.com/login.html</a>" + :method :post + :content :continuation))) + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_funcal.htm" class=noborder>funcall</a> continuation "username=" t) + (funcall continuation (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_list_.htm" class=noborder>list</a> (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_char_c.htm" class=noborder>char-code</a> #\n) (char-code #\a)) t) + (funcall continuation (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_lambda.htm" class=noborder>lambda</a> (stream) + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_cha.htm" class=noborder>write-char</a> #\n stream)) t) + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_w_open.htm" class=noborder>with-open-file</a> (out temp-file + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_stg.htm" class=noborder>write-string</a> "ook" out)) + (funcall continuation temp-file t) + (<a href="http://weitz.de/cl-ppcre/" class=noborder>ppcre</a>:<a href="http://weitz.de/cl-ppcre/#scan-to-strings" class=noborder>scan-to-strings</a> "(?i)[a-z ]+nanook[a-z .]+" + (funcall continuation "&password=igloo"))) +POST /login.html HTTP/1.1 +Host: meme.b9.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close +Content-Type: application/x-www-form-urlencoded +Transfer-Encoding: chunked + +HTTP/1.0 200 OK +Date: Sat, 02 Sep 2006 00:25:24 GMT +Connection: close +Server: AllegroServe/1.2.45 +Content-Type: text/html +Content-Length: 2922 +PRAGMA: no-cache +CACHE-CONTROL: no-cache +SET-COOKIE: meme=1834b91d26f9be983a0ed9ca; path=/ + +"The username nanook is not in our database." +#() + +;; finally, we send additional headers to ask for a <a href="http://www.rfc.net/rfc2616.html#s14.35" class=noborder>range</a> +DRAKMA-USER 17 > (<a href="http://weitz.de/cl-ppcre/" class=noborder>ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#regex-replace-all">regex-replace-all</a> + "<.*?>" + (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" class=noborder>format</a> nil "~A~A" + (<a class=noborder href="#http-request">http-request</a> "<a href="http://users.cableaz.com/~lantz/pages/hunchentoot.html" class=noborder>http://users.cableaz.com/~lantz/pages/hunchentoot.html</a>" + :additional-headers '(("<a href="http://www.rfc.net/rfc2616.html#s14.35" class=noborder>Range</a>" . "bytes=959-999"))) + (<a class=noborder href="#http-request">http-request</a> "<a href="http://users.cableaz.com/~lantz/pages/hunchentoot.html" class=noborder>http://users.cableaz.com/~lantz/pages/hunchentoot.html</a>" + :additional-headers '(("<a href="http://www.rfc.net/rfc2616.html#s14.35" class=noborder>Range</a>" . "bytes=1165-1201")))) + "") +GET /~lantz/pages/hunchentoot.html HTTP/1.1 +Host: users.cableaz.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close +Range: bytes=959-999 + +HTTP/1.1 206 Partial Content +Date: Sat, 26 Aug 2006 19:07:44 GMT +Server: Apache/2.0.16 (Unix) +Last-Modified: Sun, 24 Apr 2005 04:08:45 GMT +ETag: "35298d-2fea-d8f4cd40" +Accept-Ranges: bytes +Content-Length: 41 +Content-Range: bytes 959-999/12266 +Content-Type: text/html; charset=ISO-8859-1 +Connection: close + +GET /~lantz/pages/hunchentoot.html HTTP/1.1 +Host: users.cableaz.com +User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/) +Accept: */* +Connection: close +Range: bytes=1165-1201 + +HTTP/1.1 206 Partial Content +Date: Sat, 26 Aug 2006 19:07:45 GMT +Server: Apache/2.0.16 (Unix) +Last-Modified: Sun, 24 Apr 2005 04:08:45 GMT +ETag: "35298d-2fea-d8f4cd40" +Accept-Ranges: bytes +Content-Length: 37 +Content-Range: bytes 1165-1201/12266 +Content-Type: text/html; charset=ISO-8859-1 +Connection: close + +"<a href="http://weitz.de/drakma/" class=noborder>DRAKMA</a> (Queen of Cosmic Greed) +<a href="http://weitz.de/hunchentoot/" class=noborder>HUNCHENTOOT</a> (The Giant Spider)" +</pre> + +   <h3><a class=none name="download">Download and installation</a></h3> + +Drakma together with this documentation can be downloaded +from <a +href="http://weitz.de/files/drakma.tar.gz">http://weitz.de/files/drakma.tar.gz</a>. +The current version is 0.11.3. Drakma can be installed +via <a href="http://www.cliki.net/asdf">ASDF</a> and depends on the +open source +libraries <a href="http://www.cliki.net/cl-base64">CL-BASE64</a> (use +3.3.2 or higher to avoid an unneeded dependency +on <a +href="http://www.cliki.net/kmrcl">KMRCL</a>), <a +href="http://www.cliki.net/Puri">Puri</a>, and <a href="http://weitz.de/chunga/">Chunga</a>. If +you're not using LispWorks, you'll also +need <a +href="http://www.cliki.net/usocket">usocket</a> (0.3.2 or newer) +and (except for <a href="http://franz.com/products/allegrocl/">AllegroCL</a>) <a href="http://common-lisp.net/project/cl-plus-ssl/">CL+SSL</a>. +Try to use the newest versions of all these libraries - use the CVS +versions if in doubt. Installation +via <a href="http://www.cliki.net/asdf-install">asdf-install</a> +should also be possible, and +there's a port for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo +Linux</a> thanks to Matthew Kennedy. + +For <a +href="http://en.wikipedia.org/wiki/Secure_Sockets_Layer">SSL</a>, you +will need to +have <a +href="http://www.lispworks.com/documentation/lw50/LWUG/html/lwuser-344.htm">the +corresponding C libraries</a> as well. You'll usually have them +already unless you're on Windows. + +Luís Oliveira maintains a <a href="http://darcs.net/">darcs</a> +repository of Drakma +at <a +href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>. + +A <a href="http://www.selenic.com/mercurial/wiki/">Mercurial</a> +repository of older versions is available +at <a +href="http://arcanes.fr.eu.org/~pierre/2007/02/weitz/">http://arcanes.fr.eu.org/~pierre/2007/02/weitz/</a> +thanks to Pierre Thierry. + +   <h3><a name="mail" class=none>Support and mailing lists</a></h3> + +For questions, bug reports, feature requests, improvements, or patches +please use the <a +href="http://common-lisp.net/mailman/listinfo/drakma-devel">drakma-devel +mailing list</a>. If you want to be notified about future releases +subscribe to the <a +href="http://common-lisp.net/mailman/listinfo/drakma-announce">drakma-announce +mailing list</a>. These mailing lists were made available thanks to +the services of <a href="http://common-lisp.net/">common-lisp.net</a>. + +If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>. + + +   <h3><a class=none name="dictionary">The Drakma dictionary</a></h3> + +<h4><a name="request" class=none>The request</a></h4> + +The <a href="#http-request"><code>HTTP-REQUEST</code></a> function is +the heart of Drakma. It is used to send requests to web servers and +will either return the message body of the server's reply or (if the +user so wishes) a stream one can read from. The wealth of keyword +parameters might look a bit intimidating first, but you will rarely +need more than two or three of them - the default behaviour of Drakma +is (hopefully) designed to do The Right Thing[TM] in most cases. + +You can use +the <a href="#*header-stream*"><code>*HEADER-STREAM*</code></a> +variable to debug requests handled by Drakma in a way similar +to <a href="http://livehttpheaders.mozdev.org/">LiveHTTPHeaders</a>. + + + + <table border=0><tr><td colspan=4 valign=top>[Function]</td></tr><tr><td valign=top style="white-space:nowrap"><a class=none name='http-request'>http-request</a> </td><td valign=top><a class=none href="#uri">uri</a> </td><td valign=top><tt>&key</tt> </td><td><a class=none href="#protocol">protocol</a> <a class=none href="#method">method</a> <a class=none href="#force-ssl">force-ssl</a> <a class=none href="#parameters">parameters</a> <a class=none href="#form-data">form-data</a> <a class=none href="#content">content</a> <a class=none href="#content-length">content-length</a> <a class=none href="#content-type">content-type</a> <a class=none href="#cookie-jar-param">cookie-jar</a> <a class=none href="#basic-authorization">basic-authorization</a> <a class=none href="#user-agent">user-agent</a> <a class=none href="#accept">accept</a> <a class=none href="#proxy">proxy</a> <a class=none href="#proxy-basic-authorization">proxy-basic-authorization</a> <a class=none href="#additional-headers">additional-headers</a> <a class=none href="#redirect">redirect</a> <a class=none href="#redirect-methods">redirect-methods</a> <a class=none href="#auto-referer">auto-referer</a> <a class=none href="#keep-alive">keep-alive</a> <a class=none href="#close">close</a> <a class=none href="#external-format-out">external-format-out</a> <a class=none href="#external-format-in">external-format-in</a> <a class=none href="#force-binary">force-binary</a> <a class=none href="#want-stream">want-stream</a> <a class=none href="#stream">stream</a> <a class=none href="#connection-timeout">connection-timeout</a> <a class=none href="#read-timeout">read-timeout</a> <a class=none href="#write-timeout">write-timeout</a></td></tr><tr><td colspan=2></td><td colspan=2 valign=top> => body-or-stream, status-code, headers, uri, stream, <a class=none href="#must-close">must-close</a>, reason-phrase</td></tr></table> +<blockquote> + +Sends an <a href="http://www.rfc.net/rfc2616.html">HTTP</a> request to a web server and returns its reply. +<a class=none name="uri"><code>uri</code></a> is where the +request is sent to, and it is either a string denoting +a <a +href="http://en.wikipedia.org/wiki/Uniform_Resource_Identifier">uniform +resource identifier</a> or +a <a href="http://www.cliki.net/Puri"><code>PURI:URI</code></a> +object. The scheme of <code>uri</code> must be 'http' or +'https'. The function returns seven values - the body of the +reply (but see below), the status code as an integer, +an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> +of the headers sent by the server where for each element +the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> +(the name of the header) is a keyword and +the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> +(the value of the header) is a string, the URI the reply comes from +(which might be different from the URI the request was sent to in case +of <a href="#redirect">redirects</a>), the stream the reply was read +from, +a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generali…">generalized +boolean</a> which denotes whether the stream should be closed (and +which you can usually ignore), and finally the reason phrase from the +status line as a string. + +<a class=none name="protocol"><code>protocol</code></a> is the HTTP protocol which is going to be used in the +<a href="http://www.rfc.net/rfc2616.html#s5.1">request line</a>, it must be one of the keywords <code>:HTTP/1.0</code> or +<code>:HTTP/1.1</code> (the default). <a class=none +name="method"><code>method</code></a> is the method used in the +request line, +a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/t_kwd.htm">keyword</a> +(like <code>:GET</code> or <code>:HEAD</code>) denoting a +valid <a href="http://rfc.net/rfc2616.html">HTTP/1.1</a> +or <a href="http://www.webdav.org/">WebDAV</a> request method. +Additionally, you can also use the pseudo method <code>:OPTIONS*</code> which is like +<code>:OPTIONS</code> but means that an "<code>OPTIONS *</code>" +request line will be sent, i.e. the URI's path and query parts will be +ignored. + +If <a class=none +name="force-ssl"><code>force-ssl</code></a> is true, +<a href="http://en.wikipedia.org/wiki/Secure_Sockets_Layer">SSL</a> +will be <a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-24.htm">attached</a> to the socket stream which connects Drakma with the +web server. Usually, you don't have to provide this argument, as SSL +will be attached anyway if the scheme of <code>uri</code> is 'https'. + +<a class=none name="parameters"><code>parameters</code></a> is +an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> +of name/value pairs +(the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> +and +the <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> +each being a string) which denotes the parameters which are added to +the query part of the URI or (in the case of a POST request) comprise +the request body. (But +see <a href="#content"><code>content</code></a> below.) The +name/value pairs +are <a +href="http://www.blooberry.com/indexdot/html/topics/urlencoding.htm">URL-encoded</a> +using the external format <a class=none +name="external-format-out"><code>external-format-out</code></a> +before they are sent to the server, unless <a class=none +name="form-data"><code>form-data</code></a> is true in which +case the POST request body is sent +as <a +href="http://www.ietf.org/rfc/rfc2388.txt"><code>multipart/form-data</code></a> +using +<code>external-format-out</code>. The values of +the <code>parameters</code> alist can also be pathnames, unary +functions, open binary input streams, or lists where the first element +is of one of the former types. These values denote files which should +be sent as part of the request body, i.e. if such file designators are +present in <code>parameters</code>, the content type of the +request is always <code>multipart/form-data</code>. If the +value denoting a file is a list, the part of the list behind the first +element is treated as +a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#plist">plist</a> +which can be used to optionally specify a content type (the default is +"application/octet-stream") and/or a filename (the default is the +result of +applying <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_namest.htm"><code>FILE-NAMESTRING</code></a> +to the pathname) for the file. So, for example, a full file upload +request could look like this: +<pre> +(http-request "http://www.whatever.com/file_upload/" + :method :post + ;; the following line is only needed if the receiving server doesn't accept + ;; chunked transfer encoding (like for example Apache 1.x) + <a class=noborder href="#content-length2">:content-length</a> t + :parameters '(("file1" #p"/tmp/top_secret_stuff.doc" :content-type "application/msword" :filename "upload.doc") + ("file2" . #p"/tmp/portrait.jpg") + ("lname" . "Duck") ("fname" . "Donald"))) +</pre> + +<code>external-format-out</code> (the default is the value of <a href="#*drakma-default-external-format*"><code>*DRAKMA-DEFAULT-EXTERNAL-FORMAT*</code></a>) must be the name of a <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a> <a href="http://weitz.de/flexi-streams/#external-formats">external +format</a>. +<a class=none name="content"><code>content</code></a>, if not <code>NIL</code>, is +used as the request body - <code>parameters</code> is ignored +in this case. <code>content</code> can be a string, a +sequence of octets, a pathname, an open binary input stream, or a +<a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm">function +designator</a>. If <code>content</code> is a sequence, it will +be directly sent to the server (using <code>external-format-out</code> in the case of strings). If <code>content</code> is a +pathname, the binary contents of the corresponding file will be sent +to the server. If <code>content</code> is a stream, everything +that can be read from the stream +until <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/e_end_of.htm">EOF</a> +will be sent to the server. If <code>content</code> is a +function designator, the corresponding function will be called with +one argument, the stream to the server, to which it should send data. + +Finally, <code>content</code> can also be the +keyword <code>:CONTINUATION</code> in which +case <a href="#http-request"><code>HTTP-REQUEST</code></a> returns +only one value - a "continuation" function. This function has one +required argument and one optional argument. The first argument will +be interpreted like <code>content</code> above (but it cannot +be a keyword), i.e. it will be sent to the server according to its +type. If the second argument is true, the continuation function can +be called again to send more content, if it is <code>NIL</code>, the +continuation function returns +what <a href="#http-request"><code>HTTP-REQUEST</code></a> would have +returned. See <a href="#cont">above</a> for an +example on how to use a continuation function and different types of +content. + +If <code>content</code> is a sequence, Drakma will +use <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_length.htm"><code>LENGTH</code></a> +to determine its length and will use the result for the +'Content-Length' header sent to the server. You can overwrite this +with the <a class=none +name="content-length"><code>content-length</code></a> parameter +(a non-negative integer) which you can also use for the cases where +Drakma can't or won't determine the content length itself. You can +also explicitly provide a <code>content-length</code> argument +of <code>NIL</code> which will imply that no 'Content-Length' header +will be sent even if Drakma could compute the value. If no +'Content-Length' header is sent, Drakma will +use <a href="http://weitz.de/chunga/">chunked encoding</a> to send the +content body. Note that this will not work with some older web +servers. + +<a class=none name="content-length2">A non-<code>NIL</code> <code>content-length</code> argument</a> +means that Drakma must build the request body in RAM and +compute the content length even if it would have otherwise used +chunked encoding - for example in the case of file uploads. A special +case is the value <code>T</code> +for <code>content-length</code> which means that Drakma should +compute the content length after building the request body. + +<a class=none name="content-type"><code>content-type</code></a> is the +corresponding 'Content-Type' header to be sent and will be ignored +unless <code>content</code> is provided as well. + +Note that a +query already contained in <code>uri</code> will always be sent +with the request line anyway in addition to other parameters sent by +Drakma. + +<a class=none name="cookie-jar-param"><code>cookie-jar</code></a> is a <a href="#cookie-jar">cookie +jar</a> containing cookies which will potentially be sent to the +server (if the domain matches, if they haven't expired, etc.) - this +cookie jar will be modified according to the 'Set-Cookie' header(s) +sent back by the server. + +<a class=none name="basic-authorization"><code>basic-authorization</code></a>, if not <code>NIL</code>, +should be a list of two strings (username and password) which will be +sent to the server for basic +authorization. <a class=none name="user-agent"><code>user-agent</code></a>, if +not <code>NIL</code>, denotes which 'User-Agent' header will be sent +with the request. It can be one of the keywords <code>:DRAKMA</code> +(the +default), <code>:FIREFOX</code>, <code>:EXPLORER</code>, <code>:OPERA</code>, +or +<code>:SAFARI</code> which denote the current version of Drakma or, in +the latter four cases, a fixed string corresponding to a more or less +recent (as of August 2006) version of the corresponding browser. Or +it can be a string which is used +directly. <a class=none name="accept"><code>accept</code></a>, if not <code>NIL</code>, is the +'Accept' header sent - the default is <code>"*/*"</code>. + +If <a class=none name="proxy"><code>proxy</code></a> is not <code>NIL</code>, it should be a +string denoting +a <a href="http://en.wikipedia.org/wiki/Proxy_server">proxy server</a> +through which the request should be sent. Or it can be a list of two +values - a string denoting the proxy server and an integer denoting +the port to use (which will default to 80 otherwise). +<a class=none name="proxy-basic-authorization"><code>proxy-basic-authorization</code></a> is used like <code>basic-authorization</code>, but for +the proxy, and only if <code>proxy</code> is true. + +<a class=none name="additional-headers"><code>additional-headers</code></a> is a +name/value <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> +(like <code>parameters</code>) of additional HTTP headers which +should be sent with the request. + +If <a name="redirect" class=none><code>redirect</code></a> is +not <code>NIL</code>, it must be a non-negative integer +or <code>T</code>. If <code>redirect</code> is true, Drakma +will follow redirects (return codes 301, 302, 303, or 307) +unless <code>redirect</code> is <code>0</code>. +If <code>redirect</code> is an integer, it will be decreased +by <code>1</code> with each redirect. Drakma will only follow +redirects if <code>method</code> is a member of the list <a name="redirect-methods" class=none><code>redirect-methods</code></a> the +initial value of which is <code>(:GET :HEAD)</code>. +Furthermore, if <a name="auto-referer"><code>auto-referer</code></a> is true when following redirects, +Drakma will populate the 'Referer' (sic!) header with the URI that +triggered the redirection, overwriting an existing 'Referer' +header (in <a href="#additional-headers"><code>additional-headers</code></a>) if necessary. + +If <a name="keep-alive" class=none><code>keep-alive</code></a> is <code>T</code>, the server will +be asked to keep the connection alive, i.e. not to close it after the +reply has been sent. (Note that +this <a href="http://www.rfc.net/rfc2616.html#s8.1">not necessary</a> +if both the client and the server use HTTP 1.1.) +If <a class=none name="close"><code>close</code></a> is <code>T</code>, the server is +explicitly asked to close the connection after the reply has been +sent. <code>keep-alive</code> and <code>close</code> +are obviously mutually +exclusive. The default for <code>close</code> is <code>T</code>, the default for <code>keep-alive</code> is <code>NIL</code>. + +<a href="#http-request"><code>HTTP-REQUEST</code></a> will always +<a class=none name="close-stream">close the stream</a> to the server before it returns unless +<code>want-stream</code> is true or if the headers exchanged +between Drakma and the server determine that the connection will be +kept alive - for example if both client and server used the +HTTP 1.1 protocol and no +explicit <code>"Connection: close"</code> header was sent. In +these cases you will have to close the stream manually. + +If the message body sent by the server has a +text <a href="http://www.rfc.net/rfc2616.html#s14.17">content +type</a>, Drakma will try to return it as a Lisp string. +It'll first check if the 'Content-Type' header denotes an encoding +(charset) to be used, or otherwise it will use the <a class=none +name="external-format-in"><code>external-format-in</code></a> +(the default is the value +of <a href="#*drakma-default-external-format*"><code>*DRAKMA-DEFAULT-EXTERNAL-FORMAT*</code></a>) +argument. The body is decoded +using <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a>. If +FLEXI-STREAMS doesn't know the external format, the body is returned +as an array of octets. If the message body doesn't have a text +content type or if +<a class=none name="force-binary"><code>force-binary</code></a> +is true, the body is always returned as an array of octets. (But +see <a href="#*text-content-types*"><code>*TEXT-CONTENT-TYPES*</code></a> +and <a href="#*body-format-function*"><code>*BODY-FORMAT-FUNCTION*</code></a>.) + +If <a class=none +name="want-stream"><code>want-stream</code></a> is true, the +message body is not read and instead the (open) socket stream +is returned as the first return value. If the sixth return value +(<a class=none name="must-close"><code>must-close</code></a>) +of <a href="#http-request"><code>HTTP-REQUEST</code></a> is true, +Drakma deduced from the reply headers that the server will close the +stream on its side, so you can't re-use it - you'll have to close it +instead. Of course, no matter what the sixth return value is, it's +alway your responsibility to <a href="#close-stream">close the stream</a> once you're done with +it. The +stream returned is a <a href="http://weitz.de/flexi-streams/">flexi +stream</a> with a <a href="http://weitz.de/chunga/">chunked stream</a> +as its underlying stream. + +Drakma will usually +create <a +href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-35.htm">a +new socket connection</a> for each HTTP request. However, you can use +the <a class=none name="stream"><code>stream</code></a> argument to provide an open socket stream which should be +re-used instead. <code>stream</code> must be a stream returned by a previous invocation of +<a href="#http-request"><code>HTTP-REQUEST</code></a> where the sixth return value wasn't true. Obviously, it +must also be connected to the correct server and at the right position +(i.e. the message body, if any, must have been read). Drakma will +never attach SSL to a stream provided as the <code>stream</code> argument. + +<a class=none name="connection-timeout"><code>connection-timeout</code></a> is the time (in seconds) Drakma +will wait until it considers an attempt to connect to a server as a +failure. <a class=none name="read-timeout"><code>read-timeout</code></a> +and <a class=none name="write-timeout"><code>write-timeout</code></a> are the read and write timeouts +(in seconds) for the socket stream to the server. All three timeout +arguments can also be <code>NIL</code> (meaning no timeout), and they +don't apply if an existing stream is re-used. All timeout keyword +arguments are only available for +LispWorks, <code>write-timeout</code> is only available for +LispWorks 5.0 or higher. + +</blockquote> + + + + + + + + [Special variable] <a class=none name='*drakma-default-external-format*'>*drakma-default-external-format*</a> +<blockquote> + +The default value for the two external format keyword arguments of +<a href="#http-request"><code>HTTP-REQUEST</code></a>. The value of +this variable will be interpreted +by <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a>. The +initial value is the keyword <code>:LATIN-1</code>. (Note that Drakma +binds <a +href="http://weitz.de/flexi-streams/#*default-eol-style*"><code>*DEFAULT-EOL-STYLE*</code></a> +to <code>:LF</code>.) + +</blockquote> + + + + + + + [Special variable] <a class=none name='*text-content-types*'>*text-content-types*</a> +<blockquote> + +A list of conses which are used by the default value of <a href="#*body-format-function*"><code>*BODY-FORMAT-FUNCTION*</code></a> to decide +whether a 'Content-Type' header denotes text content. The car and cdr +of each cons should each be a string or <code>NIL</code>. A content type matches +one of these entries (and thus denotes text) if the type part is +<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stgeq_.htm"><code>STRING-EQUAL</code></a> +to the car or if the car is <code>NIL</code> and if the subtype part +is <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stgeq_.htm"><code>STRING-EQUAL</code></a> +to the cdr or if the cdr is <code>NIL</code>. + +The initial value of this variable is the list +<pre> +(("text" . nil)) +</pre> +which means that every content type that starts with "text/" is +regarded as text, no matter what the subtype is. + +</blockquote> + + + + + + [Special variable] <a class=none name='*body-format-function*'>*body-format-function*</a> +<blockquote> + +A function which determines whether the content body returned by the +server is text and should be treated as such or not. The function is +called after the request <a href="#headers">headers</a> have been read +and it must accept two arguments, <code>headers</code> +and <code>external-format-in</code>, where <code>headers</code> is like the +third return value of <a href="#http-request"><code>HTTP-REQUEST</code></a> while <code>external-format-in</code> is the +<a href="#http-request"><code>HTTP-REQUEST</code></a> argument of the +same name. It should return <code>NIL</code> if the body should be +regarded as binary content, or +a <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a> external +format (which will be used to read the body) otherwise. + +This function will only be called if +the <a href="#force-binary"><code>force-binary</code></a> +argument to <a href="#http-request"><code>HTTP-REQUEST</code></a> is <code>NIL</code>. + +The initial value of this variable is a function which uses +<a href="#*text-content-types*"><code>*TEXT-CONTENT-TYPES*</code></a> +to determine whether the body is text and then proceeds as described +in the <a href="#http-request"><code>HTTP-REQUEST</code></a> +documentation entry. + +</blockquote> + + + + + + [Special variable] <a class=none name='*header-stream*'>*header-stream*</a> +<blockquote> + +If this variable is not <code>NIL</code>, it should be bound to a +stream to which incoming and outgoing headers will be written for +debugging purposes. + +</blockquote> + + + +<h4><a name="cookies" class=none>Cookies</a></h4> + +<a href="#http-request"><code>HTTP-REQUEST</code></a> can deal +with <a href="http://en.wikipedia.org/wiki/HTTP_cookie">cookies</a> if +it gets a <a href="#cookie-jar">cookie jar</a>, a collection +of <a href="#cookie"><code>COOKIE</code></a> objects, as +its <a href="#cookie-jar-param"><code>cookie-jar</code></a> argument. Cookies sent by the web +server will be added to the cookie jar (or updated) if appropriate and +cookies already in the cookie jar will be sent to the server together +with the request. + +Drakma will never remove cookies from a cookie jar +automatically - you have to do it manually +using <a +href="#delete-old-cookies"><code>DELETE-OLD-COOKIES</code></a>. + + + + [Standard class] <a class=none name='cookie'>cookie</a> +<blockquote> + +Elements of this class +represent <a href="http://en.wikipedia.org/wiki/HTTP_cookie">HTTP +cookies</a>. If you need to create your own cookies, you should +use <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_ins.htm"><code>MAKE-INSTANCE</code></a> +with the +initargs <code>:NAME</code>, <code>:DOMAIN</code>, <code>:VALUE</code>, <code>:PATH</code>, <code>:EXPIRES</code>, +<code>:SECUREP</code>, and <code>:HTTP-ONLY-P</code> all of which are +optional except for the first two. The meaning of these initargs +and <a href="#cookie-name">the corresponding accessors</a> should be +pretty clear if one looks at +the <a href="http://wp.netscape.com/newsref/std/cookie_spec.html">original +cookie specification</a> (and +at <a href="http://msdn2.microsoft.com/en-us/library/ms533046.aspx">this +page</a> for the <code>HttpOnly</code> extension). + +<pre> +DRAKMA-USER 18 > (make-instance 'cookie :name "Foo" + :value "Bar" + :expires (+ (get-universal-time) 3600) + :domain ".weitz.de") +#<COOKIE Foo=Bar; expires=Sat, 26-08-2006 23:14:27 GMT; path=/; domain=.weitz.de> +</pre> + +</blockquote> + + + + + [Specialized accessors] <a name="cookie-name" class=none>cookie-name (cookie cookie) => name</a> + <a class=none><tt>(setf (</tt>cookie-name (cookie cookie)<tt>)</tt> name<tt>)</tt></a> + <a name="cookie-value" class=none>cookie-value (cookie cookie) => value</a> + <a class=none><tt>(setf (</tt>cookie-value (cookie cookie)<tt>)</tt> value<tt>)</tt></a> + <a name="cookie-domain" class=none>cookie-domain (cookie cookie) => domain</a> + <a class=none><tt>(setf (</tt>cookie-domain (cookie cookie)<tt>)</tt> domain<tt>)</tt></a> + <a name="cookie-path" class=none>cookie-path (cookie cookie) => path</a> + <a class=none><tt>(setf (</tt>cookie-path (cookie cookie)<tt>)</tt> path<tt>)</tt></a> + <a name="cookie-expires" class=none>cookie-expires (cookie cookie) => expiry</a> + <a class=none><tt>(setf (</tt>cookie-expires (cookie cookie)<tt>)</tt> expiry<tt>)</tt></a> + <a name="cookie-securep" class=none>cookie-securep (cookie cookie) => securep</a> + <a class=none><tt>(setf (</tt>cookie-securep (cookie cookie)<tt>)</tt> securep<tt>)</tt></a> + <a name="cookie-http-only-p" class=none>cookie-http-only-p (cookie cookie) => http-only-p</a> + <a class=none><tt>(setf (</tt>cookie-http-only-p (cookie cookie)<tt>)</tt> http-only-p<tt>)</tt></a> +<blockquote> + +These +are <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#accessor">accessors</a> +to get and set the corresponding slots of +a <a href="#cookie"><code>COOKIE</code></a> object. Note that <code>expiry</code> is a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/25_adb.htm">universal time</a> +and <code>securep</code> and <code>http-only-p</code> are <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generali…">generalized +booleans</a>. All other values are strings. + +</blockquote> + + + + [Standard class] <a class=none name='cookie-jar'>cookie-jar</a> +<blockquote> + +An object of this class encapsulates a collection (a list, actually) +of <a href="#cookie"><code>COOKIE</code></a> objects. You create a +new cookie jar with +<code>(MAKE-INSTANCE 'COOKIE-JAR)</code> +where you can optionally provide a list +of <a href="#cookie"><code>COOKIE</code></a> objects with +the <code>:COOKIES</code> initarg. The cookies in a cookie jar are +accessed +with <a +href="#cookie-jar-cookies"><code>COOKIE-JAR-COOKIES</code></a>. + +</blockquote> + + + + + + + [Specialized accessor] <a name="cookie-jar-cookies" class=none>cookie-jar-cookies (cookie-jar cookie-jar) => list</a> + <a class=none><tt>(setf (</tt>cookie-jar-cookies (cookie-jar cookie-jar)<tt>)</tt> list<tt>)</tt></a> +<blockquote> + +This <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#accessor">accessor</a> +is used to get and set the cookies comprised in a cookie +jar. <code>list</code> is a list +of <a href="#cookie"><code>COOKIE</code></a> objects. + +Note that <code>list</code> should not contain two cookies which are equal according to <a href="#cookie="><code>COOKIE=</code></a>. + +</blockquote> + + + + + + + [Function] <a class=none name='cookie='>cookie= cookie1 cookie2 => result</a> +<blockquote> + +Returns <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true">true</a> +if the cookies <code>cookie1</code> +and <code>cookie2</code> are equal. Two cookies are considered +to be equal if their <a href="#cookie-name">names</a> and <a href="#cookie-path">paths</a> are equal. + +</blockquote> + + + + + + + [Function] <a class=none name='delete-old-cookies'>delete-old-cookies cookie-jar => cookie-jar</a> +<blockquote> + +Removes all cookies from the <a href="#cookie-jar">cookie +jar</a> <code>cookie-jar</code> which have either expired or +which don't have an expiry date. + +</blockquote> + + + + + + + [Special variable] <a class=none name='*ignore-unparseable-cookie-dates-p*'>*ignore-unparseable-cookie-dates-p*</a> +<blockquote> + +Whether Drakma is allowed to treat <code>Expires</code> dates in +cookie headers as non-existent if it can't parse them. If the value +of this variable is <code>NIL</code> (which is the default), an error +will be signalled instead. + +Note that Drakma tries hard to parse every date representation its +author has so far seen in the wild. As everybody and their sister +seems to invent their own format, this feels like an uphill battle, +though. Nevertheless, if you're confronted with something Drakma +can't parse, report it to the <a href="#mail">mailing list</a> and set +this variable to a true value only as a temporary workaround. + +</blockquote> + + + +<h4><a name="headers" class=none>Headers</a></h4> + +This section assembles a couple of convenience functions which can be +used to access information returned as the third +value (<code>headers</code>) +of <a href="#http-request"><code>HTTP-REQUEST</code></a>. + +Note that if the header +sends <a href="http://www.rfc.net/rfc2616.html#s4.2">multiple headers +with the same name</a>, these are comprised into one entry by +<a href="#http-request"><code>HTTP-REQUEST</code></a> where the values +are separated by commas. + + + + [Function] <a class=none name='header-value'>header-value name headers => value</a> +<blockquote> + +If <code>headers</code> is an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of headers as returned by <a href="#http-request"><code>HTTP-REQUEST</code></a> +and <code>name</code> is a keyword naming a header, this function returns the +corresponding value of this header (or <code>NIL</code> if it's not in +<code>headers</code>). +<pre> +DRAKMA-USER 19 > (setq <a href="#*header-stream*" class=noborder>*header-stream*</a> nil) +NIL +DRAKMA-USER 20 > (header-value :server + (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 2 (<a class=noborder href="#http-request">http-request</a> "<a href="http://www.jalat.com/blogs/lisp?id=5" class=noborder>http://www.jalat.com/blogs/lisp?id=5</a>"))) +"<a href="http://weitz.de/" class=noborder>Hunchentoot</a> 0.1.3 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.9.7)" +</pre> + +</blockquote> + + + + + + [Function] <a class=none name='split-tokens'>split-tokens string => string-list</a> +<blockquote> + +Splits the string <code>string</code> into a list of substrings separated +by commas and optional whitespace. Empty substrings are +ignored. +<pre> +DRAKMA-USER 21 > (split-tokens "chunked, identity") +("chunked" "identity") +</pre> + +</blockquote> + + + + + + + [Function] <a class=none name='read-tokens-and-parameters'>read-tokens-and-parameters string <tt>&key</tt> value-required-p => list</a> +<blockquote> + +Reads a comma-separated list +of <a href="http://www.rfc.net/rfc2616.html#s2.2">tokens</a> from the +string <code>string</code>. Each token can be followed by an +optional, semicolon-separated list +of <a href="http://www.rfc.net/rfc2616.html#s3.6">attribute/value +pairs</a> where the attributes are tokens followed by +a <code>#\=</code> character and a token or +a <a href="http://www.rfc.net/rfc2616.html#s2.2">quoted string</a>. +Returned is a list where each element is either a string (for a simple +token) or +a <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cons">cons</a> +of a string (the token) and +an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> +(the attribute/value pairs). If <code>value-required-p</code> +is <code>NIL</code> (the default is <code>T</code>), the value part +(including the <code>#\=</code> character) of each attribute/value +pair is optional. + +An example of an HTTP header which uses a syntax which can be parsed +with this function is the 'Transfer-Encoding' header. +<pre> +DRAKMA-USER 21 > (read-tokens-and-parameters "iso-8859-5, unicode-1-1;q=0.8") +("iso-8859-5" ("unicode-1-1" ("q" . "0.8"))) +</pre> + +</blockquote> + + + + + + [Function] <a class=none name='parameter-present-p'>parameter-present-p name parameters => generalized-boolean</a> +<blockquote> + +If <code>parameters</code> is +an <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> +of parameters (i.e. of attribute/value pairs) as returned by, for +example, <a href="#read-tokens-and-parameters"><code>READ-TOKENS-AND-PARAMETERS</code></a> and <code>name</code> is a string naming a +parameter, this function returns the full parameter (name and value) - +or <code>NIL</code> if it's not in <code>parameters</code>. +<pre> +DRAKMA-USER 23 > (parameter-present-p "frob" '(("charset" . "latin-1") ("frob" . "quux"))) +("frob" . "quux") + +DRAKMA-USER 24 > (parameter-present-p "foo" '(("charset" . "latin-1") ("frob" . "quux"))) +NIL +</pre> +</blockquote> + + + + + + + [Function] <a class=none name='parameter-value'>parameter-value name parameters => value</a> +<blockquote> + +If <code>parameters</code> is an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of parameters (i.e. of attribute/value pairs) as returned by, for +example, <a href="#read-tokens-and-parameters"><code>READ-TOKENS-AND-PARAMETERS</code></a> and <code>name</code> is a string naming a +parameter, this function returns the value of this parameter - or +<code>NIL</code> if it's not in <code>parameters</code>. +<pre> +DRAKMA-USER 25 > (parameter-value "frob" '(("charset" . "latin-1") ("frob" . "quux"))) +"quux" + +DRAKMA-USER 26 > (parameter-value "foo" '(("charset" . "latin-1") ("frob" . "quux"))) +NIL +</pre> +</blockquote> + + + + + + [Function] <a class=none name='get-content-type'>get-content-type headers => type, subtype, parameters</a> +<blockquote> + +Reads and parses a 'Content-Type' header and returns it as +three values - the type, the subtype, and an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> (possibly +empty) of name/value pairs for the optional parameters. <code>headers</code> +is supposed to be an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of HTTP headers as returned by +<a href="#http-request"><code>HTTP-REQUEST</code></a>. Returns <code>NIL</code> if there is no 'Content-Type' header amongst +<code>headers</code>. +<pre> +DRAKMA-USER 27 > (get-content-type + (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 2 (<a href="#http-request" class=noborder>http-request</a> "<a href="http://weitz.de/" class=noborder>http://weitz.de/</a>"))) +"text" +"html" +(("charset" . "iso-8859-1")) +</pre> +</blockquote> + + + +   <h3><a class=none name="prob">Potential problems</a></h3> + +Some web servers (notably <a href="http://paulgraham.com/">Paul Graham</a>'s +<a +href="http://paulgraham.com/arc.html">Arc</a> <a +href="http://common-lisp.net/pipermail/drakma-devel/2007-April/000116.html">web +server</a> +and <a +href="http://common-lisp.net/pipermail/drakma-devel/2007-May/000135.html">some +very old ones</a>) use wrong line endings when sending the HTTP +headers. By default, Drakma won't be able to understand them, but +see <a +href="http://weitz.de/chunga/">Chunga</a>'s <a +href="http://weitz.de/chunga/#*accept-bogus-eols*"><code>*ACCEPT-BOGUS-EOLS*</code></a>. + + +   <h3><a class=none name="ack">Acknowledgements</a></h3> + +Initial versions of Drakma used code +from <a href="http://www.cliki.net/ACL-COMPAT">ACL-COMPAT</a>, +specifically the chunking code from Jochen Schmidt. (This has been replaced by <a href="http://weitz.de/chunga/">Chunga</a>.) +The API of +Drakma's <a href="#http-request"><code>HTTP-REQUEST</code></a> was +inspired by John +Foderaro's <a +href="http://opensource.franz.com/aserve/aserve-dist/doc/aserve.html#f-do-http-re…"><code>DO-HTTP-REQUEST</code></a>. +And greetings to Bob Hutchinson who +already <a +href="http://recursive.ca/hutch/index.php?p=278">anticipated this +library in 2005</a>... :) + + +This documentation was prepared with <a href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>. + + +$Header: /usr/local/cvsrep/drakma/doc/index.html,v 1.83 2008/01/14 18:51:40 edi Exp $ +<a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> + +</body> +</html> Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/drakma.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/drakma.asd Wed Feb 13 14:41:09 2008 @@ -0,0 +1,60 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/drakma/drakma.asd,v 1.46 2008/01/14 18:51:38 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +#+:lispworks +(unless (find-symbol "STREAM-WRITE-TIMEOUT" :stream) + (pushnew :lw-does-not-have-write-timeout *features*)) + +(defpackage :drakma-asd + (:use :cl :asdf)) + +(in-package :drakma-asd) + +(defvar *drakma-version-string* "0.11.3" + "Drakma's version number as a string.") + +;; we export its name so we can import it later +(export '*drakma-version-string*) + +(defsystem :drakma + :serial t + :version #.*drakma-version-string* + :components ((:file "packages") + (:file "specials") + (:file "util") + (:file "read") + (:file "cookies") + (:file "request")) + :depends-on (:puri + :cl-base64 + :chunga + #-:lispworks :usocket + #-(or :lispworks :allegro) :cl+ssl)) Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/packages.lisp Wed Feb 13 14:41:09 2008 @@ -0,0 +1,59 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/drakma/packages.lisp,v 1.22 2008/01/14 01:57:01 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :drakma + (:use :cl :puri :flexi-streams :chunga) + ;; the variable defined in the ASDF system definition + (:import-from :drakma-asd :*drakma-version-string*) + (:export :*body-format-function* + :*drakma-default-external-format* + :*header-stream* + :*ignore-unparseable-cookie-dates-p* + :*text-content-types* + :cookie + :cookie-domain + :cookie-expires + :cookie-http-only-p + :cookie-jar + :cookie-jar-cookies + :cookie-name + :cookie-path + :cookie-securep + :cookie-value + :cookie= + :delete-old-cookies + :get-content-type + :header-value + :http-request + :parameter-present-p + :parameter-value + :read-tokens-and-parameters + :split-tokens)) Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/read.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/read.lisp Wed Feb 13 14:41:09 2008 @@ -0,0 +1,127 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/drakma/read.lisp,v 1.15 2008/01/14 01:57:01 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :drakma) + +(defmacro ignore-eof (&body body) + "This macro is similar to IGNORE-ERRORS but it only ignores +conditions of type END-OF-FILE." + `(handler-case + (progn ,@body) + (end-of-file () nil))) + +(defun read-status-line (stream &optional log-stream) + "Reads one line from STREAM \(using Chunga's READ-LINE*) and +interprets it as a HTTP status line. Returns a list of two or +three values - the protocol \(HTTP version) as a keyword, the +status code as an integer, and optionally the reason phrase." + (let* ((*current-error-message* "While reading status line:") + (line (read-line* stream log-stream)) + (first-space-pos (or (position #\Space line :test #'char=) + (error "No space in status line ~S." line))) + (second-space-pos (position #\Space line + :test #'char= + :start (1+ first-space-pos)))) + (list (cond ((string-equal line "HTTP/1.0" :end1 first-space-pos) :http/1.0) + ((string-equal line "HTTP/1.1" :end1 first-space-pos) :http/1.1) + (t (error "Unknown protocol in ~S." line))) + (or (ignore-errors (parse-integer line + :start (1+ first-space-pos) + :end second-space-pos)) + (error "Status code in ~S is not an integer." line)) + (and second-space-pos (subseq line (1+ second-space-pos)))))) + +(defun get-content-type (headers) + "Reads and parses a `Content-Type' header and returns it as +three values - the type, the subtype, and an alist \(possibly +empty) of name/value pairs for the optional parameters. HEADERS +is supposed to be an alist of headers as returned by +HTTP-REQUEST. Returns NIL if there is no such header amongst +HEADERS." + (when-let (content-type (header-value :content-type headers)) + (with-input-from-string (stream content-type) + (let* ((*current-error-message* "Corrupted Content-Type header:") + (type (read-token stream)) + (subtype (and (assert-char stream #\/) + (read-token stream))) + (parameters (read-name-value-pairs stream))) + (values type subtype parameters))))) + +(defun read-token-and-parameters (stream) + "Reads and returns \(as a two-element list) from STREAM a token +and an optional list of parameters \(attribute/value pairs) +following the token." + (skip-whitespace stream) + (list (read-token stream) + (read-name-value-pairs stream))) + +(defun skip-more-commas (stream) + "Reads and consumes from STREAM any number of commas and +whitespace. Returns the following character or NIL in case of +END-OF-FILE." + (loop while (eql (ignore-eof (peek-char nil stream)) #\,) + do (read-char stream) (skip-whitespace stream)) + (skip-whitespace stream)) + +(defun read-tokens-and-parameters (string &key (value-required-p t)) + "Reads a comma-separated list of tokens from the string STRING. +Each token can be followed by an optional, semicolon-separated +list of attribute/value pairs where the attributes are tokens +followed by a #\\= character and a token or a quoted string. +Returned is a list where each element is either a string \(for a +simple token) or a cons of a string \(the token) and an alist +\(the attribute/value pairs). If VALUE-REQUIRED-P is NIL, the +value part \(including the #\\= character) of each attribute/value +pair is optional." + (with-input-from-string (stream string) + (loop with *current-error-message* = (format nil "While parsing ~S:" string) + for first = t then nil + for next = (and (skip-whitespace stream) + (or first (assert-char stream #\,)) + (skip-whitespace stream) + (skip-more-commas stream)) + for token = (and next (read-token stream)) + for parameters = (and token + (read-name-value-pairs stream + :value-required-p value-required-p)) + while token + collect (if parameters (cons token parameters) token)))) + +(defun split-tokens (string) + "Splits the string STRING into a list of substrings separated +by commas and optional whitespace. Empty substrings are +ignored." + (loop for old-position = -1 then position + for position = (and old-position + (position #\, string :test #'char= :start (1+ old-position))) + for substring = (and old-position + (trim-whitespace (subseq string (1+ old-position) position))) + while old-position + when (plusp (length substring)) + collect substring)) Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/request.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/request.lisp Wed Feb 13 14:41:09 2008 @@ -0,0 +1,666 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/drakma/request.lisp,v 1.54 2008/01/14 18:51:38 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :drakma) + +(defun determine-body-format (headers external-format-in) + "The default function used by Drakma to determine how the content +body is to be read. See the docstring of *BODY-FORMAT-FUNCTION* for +more info." + (handler-case + (let ((transfer-encodings (header-value :transfer-encoding headers)) + (content-encodings (header-value :content-encoding headers))) + (when transfer-encodings + (setq transfer-encodings (split-tokens transfer-encodings))) + (when content-encodings + (setq content-encodings (split-tokens content-encodings))) + (multiple-value-bind (type subtype params) + (get-content-type headers) + (when (and (text-content-type-p type subtype) + (null (set-difference transfer-encodings + '("chunked" "identity") + :test #'equalp)) + (null (set-difference content-encodings + '("identity") + :test #'equalp))) + (let* ((charset (parameter-value "charset" params)) + (name (cond (charset (as-keyword charset)) + (t external-format-in)))) + (make-external-format name :eol-style :lf))))) + (error (condition) + (warn "Problems determining charset \(falling back to binary):~%~A" + condition)))) + +(defun send-content (content stream &optional external-format-out) + "Sends CONTENT to the stream STREAM as part of the request body +depending on the type of CONTENT." + (when content + (cond ((stringp content) + (setf (flexi-stream-external-format stream) external-format-out) + (write-string content stream) + (setf (flexi-stream-external-format stream) +latin-1+)) + ((or (arrayp content) (listp content)) + (write-sequence content stream)) + ((and (streamp content) + (input-stream-p content) + (open-stream-p content) + (subtypep (stream-element-type content) 'octet)) + (let ((buf (make-array +buffer-size+ :element-type 'octet))) + (loop + (let ((pos (read-sequence buf content))) + (when (zerop pos) (return)) + (write-sequence buf stream :end pos))))) + ((pathnamep content) + (with-open-file (from content :element-type 'octet) + ;; calls itself with a stream now + (send-content from stream))) + ((or (functionp content) + (and (symbolp content) + (fboundp content))) + (funcall content stream)) + (t (error "Don't know how to send content ~S to server." content))))) + +(defun make-form-data-function (parameters boundary) + "Creates and returns a closure which can be used as an argument for +SEND-CONTENT to send PARAMETERS as a `multipart/form-data' request +body using the boundary BOUNDARY." + (lambda (stream) + (flet ((crlf () + "Sends carriage return and linefeed to STREAM." + (write-char #\Return stream) + (write-char #\Linefeed stream))) + (dolist (name/value parameters) + (destructuring-bind (name . value) + name/value + (when (or (pathnamep value) + (streamp value) + (functionp value)) + (setq value (list value))) + (format stream "--~A" boundary) + (crlf) + (format stream "Content-Disposition: form-data; name=\"~A\"" name) + (cond ((stringp value) + (crlf) (crlf) + (format stream "~A" value)) + ((listp value) + (let* ((file-source (first value)) + (filename (or (if (functionp file-source) "user-closure") + (if (streamp file-source) "user-stream") + (getf (rest value) :filename) + (file-namestring file-source))) + (content-type (or (getf (rest value) :content-type) + "application/octet-stream"))) + (format stream "; filename=\"~A\"" filename) + (crlf) + (format stream "Content-Type: ~A" content-type) + (crlf) (crlf) + ;; use SEND-CONTENT to send file as binary data + (send-content file-source stream))) + (t (error "Don't know what to do with ~S in multipart/form-data body." value))) + (crlf))) + (format stream "--~A--" boundary) + (crlf)))) + +(defun read-body (stream headers must-close textp) + "Reads the message body from the HTTP stream STREAM using the +information contained in HEADERS \(as produced by HTTP-REQUEST). If +TEXTP is true, the body is assumed to be of content type `text' and +will be returned as a string. Otherwise an array of octets \(or NIL +for an empty body) is returned. Returns the optional `trailer' HTTP +headers of the chunked stream \(if any) as a second value." + (let ((content-length (ignore-errors + (parse-integer (header-value :content-length headers)))) + (element-type (if textp + #+:lispworks 'lw:simple-char #-:lispworks 'character + 'octet)) + (chunkedp (chunked-stream-input-chunking-p (flexi-stream-stream stream)))) + (multiple-value-prog1 + (values (cond ((eql content-length 0) nil) + (content-length + (when chunkedp + ;; see RFC 2616, section 4.4 + (error "Got Content-Length header although input chunking is on.")) + (let ((result (make-array content-length + :element-type element-type + :fill-pointer t))) + (setf (fill-pointer result) + (read-sequence result stream)) + result)) + ((or chunkedp must-close) + ;; no content length, read until EOF (or end of chunking) + (let ((buffer (make-array +buffer-size+ + :element-type element-type)) + (result (make-array 0 + :element-type element-type + :adjustable t))) + (loop for index = 0 then (+ index pos) + for pos = (read-sequence buffer stream) + do (adjust-array result (+ index pos)) + (replace result buffer :start1 index :end2 pos) + while (= pos +buffer-size+)) + result))) + (chunked-input-stream-trailers stream))))) + +(defun http-request (uri &rest args + &key (protocol :http/1.1) + (method :get) + force-ssl + parameters + content + (content-type "application/x-www-form-urlencoded") + (content-length nil content-length-provided-p) + form-data + cookie-jar + basic-authorization + (user-agent :drakma) + (accept "*/*") + proxy + proxy-basic-authorization + additional-headers + (redirect 5) + (redirect-methods '(:get :head)) + auto-referer + keep-alive + (close t) + (external-format-out *drakma-default-external-format*) + (external-format-in *drakma-default-external-format*) + force-binary + want-stream + stream + #+:lispworks (connection-timeout 20) + #+:lispworks (read-timeout 20) + #+(and :lispworks (not :lw-does-not-have-write-timeout)) + (write-timeout 20 write-timeout-provided-p)) + "Sends an HTTP request to a web server and returns its reply. URI +is where the request is sent to, and it is either a string denoting a +uniform resource identifier or a PURI:URI object. The scheme of URI +must be `http' or `https'. The function returns SEVEN values - the +body of the reply \(but see below), the status code as an integer, an +alist of the headers sent by the server where for each element the car +\(the name of the header) is a keyword and the cdr \(the value of the +header) is a string, the URI the reply comes from \(which might be +different from the URI the request was sent to in case of redirects), +the stream the reply was read from, a generalized boolean which +denotes whether the stream should be closed \(and which you can +usually ignore), and finally the reason phrase from the status line as +a string. + +PROTOCOL is the HTTP protocol which is going to be used in the +request line, it must be one of the keywords :HTTP/1.0 or +:HTTP/1.1. METHOD is the method used in the request line, a +keyword \(like :GET or :HEAD) denoting a valid HTTP/1.1 or WebDAV +request method. Additionally, you can also use the pseudo +method :OPTIONS* which is like :OPTIONS but means that an +\"OPTIONS *\" request line will be sent, i.e. the URI's path and +query parts will be ignored. + +If FORCE-SSL is true, SSL will be attached to the socket stream +which connects Drakma with the web server. Usually, you don't +have to provide this argument, as SSL will be attached anyway if +the scheme of URI is `https'. + +PARAMETERS is an alist of name/value pairs \(the car and the cdr each +being a string) which denotes the parameters which are added to the +query part of the URL or \(in the case of a POST request) comprise the +body of the request. (But see CONTENT below.) The name/value pairs +are URL-encoded using the FLEXI-STREAMS external format +EXTERNAL-FORMAT-OUT before they are sent to the server unless +FORM-DATA is true in which case the POST request body is sent as +`multipart/form-data' using EXTERNAL-FORMAT-OUT. The values of the +PARAMETERS alist can also be pathnames, open binary input streams, +unary functions, or lists where the first element is of one of the +former types. These values denote files which should be sent as part +of the request body, i.e. if files are present in PARAMETERS, the +content type of the request is always `multipart/form-data'. If the +value is a list, the part of the list behind the first element is +treated as a plist which can be used to specify a content type and/or +a filename for the file, i.e. such a value could look like, e.g., +\(#p\"/tmp/my_file.doc\" :content-type \"application/msword\" +:filename \"upload.doc\"). + +CONTENT, if not NIL, is used as the request body - PARAMETERS is +ignored in this case. CONTENT can be a string, a sequence of +octets, a pathname, an open binary input stream, or a function +designator. If CONTENT is a sequence, it will be directly sent +to the server \(using EXTERNAL-FORMAT-OUT in the case of +strings). If CONTENT is a pathname, the binary contents of the +corresponding file will be sent to the server. If CONTENT is a +stream, everything that can be read from the stream until EOF +will be sent to the server. If CONTENT is a function designator, +the corresponding function will be called with one argument, the +stream to the server, to which it should send data. + +Finally, CONTENT can also be the keyword :CONTINUATION in which case +HTTP-REQUEST returns only one value - a `continuation' function. This +function has one required argument and one optional argument. The +first argument will be interpreted like CONTENT above \(but it cannot +be a keyword), i.e. it will be sent to the server according to its +type. If the second argument is true, the continuation function can +be called again to send more content, if it is NIL the continuation +function returns what HTTP-REQUEST would have returned. + +If CONTENT is a sequence, Drakma will use LENGTH to determine its +length and will use the result for the `Content-Length' header sent to +the server. You can overwrite this with the CONTENT-LENGTH parameter +\(a non-negative integer) which you can also use for the cases where +Drakma can't or won't determine the content length itself. You can +also explicitly provide a CONTENT-LENGTH argument of NIL which will +imply that no `Content-Length' header will be sent in any case. If no +`Content-Length' header is sent, Drakma will use chunked encoding to +send the content body. Note that this will not work with older web +servers. + +A non-NIL CONTENT-LENGTH argument means that Drakma /must/ build the +request body in RAM and compute the content length even if it would +have otherwise used chunked encoding, for example in the case of file +uploads. A special case is the value T for CONTENT-LENGTH which means +that Drakma should compute the content length after building the +request body. + +CONTENT-TYPE is the corresponding `Content-Type' header to be sent and +will be ignored unless CONTENT is provided as well. + +Note that a query already contained in URI will always be sent with +the request line anyway in addition to other parameters sent by +Drakma. + +COOKIE-JAR is a cookie jar containing cookies which will +potentially be sent to the server \(if the domain matches, if +they haven't expired, etc.) - this cookie jar will be modified +according to the `Set-Cookie' header\(s) sent back by the server. + +BASIC-AUTHORIZATION, if not NIL, should be a list of two strings +\(username and password) which will be sent to the server for +basic authorization. USER-AGENT, if not NIL, denotes which +`User-Agent' header will be sent with the request. It can be one +of the keywords :DRAKMA, :FIREFOX, :EXPLORER, :OPERA, or :SAFARI +which denote the current version of Drakma or, in the latter four +cases, a fixed string corresponding to a more or less recent \(as +of August 2006) version of the corresponding browser. Or it can +be a string which is used directly. ACCEPT, if not NIL, is the +`Accept' header sent. + +If PROXY is not NIL, it should be a string denoting a proxy +server through which the request should be sent. Or it can be a +list of two values - a string denoting the proxy server and an +integer denoting the port to use \(which will default to 80 +otherwise). PROXY-BASIC-AUTHORIZATION is used like +BASIC-AUTHORIZATION, but for the proxy, and only if PROXY is +true. + +ADDITIONAL-HEADERS is a name/value alist \(like PARAMETERS) of +additional HTTP headers which should be sent with the request. + +If REDIRECT is not NIL, it must be a non-negative integer or T. +If REDIRECT is true, Drakma will follow redirects \(return codes +301, 302, 303, or 307) unless REDIRECT is 0. If REDIRECT is an +integer, it will be decreased by 1 with each redirect. +Furthermore, if AUTO-REFERER is true when following redirects, +Drakma will populate the `Referer' header with the URI that +triggered the redirection, overwriting an existing `Referer' +header (in ADDITIONAL-HEADERS) if necessary. + +If KEEP-ALIVE is T, the server will be asked to keep the +connection alive, i.e. not to close it after the reply has been +sent. \(Note that this not necessary if both the client and the +server use HTTP 1.1.) If CLOSE is T, the server is explicitly +asked to close the connection after the reply has been sent. +KEEP-ALIVE and CLOSE are obviously mutually exclusive. + +If the message body sent by the server has a text content type, +Drakma will try to return it as a Lisp string. It'll first check +if the `Content-Type' header denotes an encoding to be used, or +otherwise it will use the EXTERNAL-FORMAT-IN argument. The body +is decoded using FLEXI-STREAMS. If FLEXI-STREAMS doesn't know +the external format, the body is returned as an array of octets. + +If the message body doesn't have a text content type or if +FORCE-BINARY is true, the body is always returned as an array of +octets. + +If WANT-STREAM is true, the message body is NOT read and instead the +\(open) socket stream is returned as the first return value. If the +sixth value of HTTP-REQUEST is true, the stream should be closed \(and +not be re-used) after the body has been read. The stream returned is +a flexi stream \(see http://weitz.de/flexi-streams/) with a chunked +stream \(see http://weitz.de/chunga/) as its underlying stream. If +you want to read binary data from this stream, read from the +underlying stream which you can get with FLEXI-STREAM-STREAM. + +Drakma will usually create a new socket connection for each HTTP +request. However, you can use the STREAM argument to provide an +open socket stream which should be re-used. STREAM MUST be a +stream returned by a previous invocation of HTTP-REQUEST where +the sixth return value wasn't true. Obviously, it must also be +connected to the correct server and at the right position +\(i.e. the message body, if any, must have been read). Drakma +will NEVER attach SSL to a stream provided as the STREAM +argument. + +CONNECTION-TIMEOUT is the time \(in seconds) Drakma will wait until it +considers an attempt to connect to a server as a failure. +READ-TIMEOUT and WRITE-TIMEOUT are the read and write timeouts \(in +seconds) for the socket stream to the server. All three timeout +arguments can also be NIL \(meaning no timeout), and they don't apply +if an existing stream is re-used. All timeout keyword arguments are +only available for LispWorks, WRITE-TIMEOUT is only available for +LispWorks 5.0 or higher." + (unless (member protocol '(:http/1.0 :http/1.1) :test #'eq) + (error "Don't know how to handle protocol ~S." protocol)) + (setq uri (cond ((uri-p uri) (copy-uri uri)) + (t (parse-uri uri)))) + (unless (member method +known-methods+ :test #'eq) + (error "Don't know how to handle method ~S." method)) + (unless (member (uri-scheme uri) '(:http :https) :test #'eq) + (error "Don't know how to handle scheme ~S." (uri-scheme uri))) + (when (and close keep-alive) + (error "CLOSE and KEEP-ALIVE must not be both true.")) + (when (and (eq content :continuation) content-length) + (error "CONTENT-LENGTH must be NIL if CONTENT is :CONTINUATION.")) + (when (and form-data (not (eq method :post))) + (error "FORM-DATA makes only sense with POST requests.")) + ;; convert PROXY argument to canonical form + (when proxy + (when (atom proxy) + (setq proxy (list proxy 80)))) + ;; make sure we don't get :CRLF on Windows + (let ((*default-eol-style* :lf) + (file-parameters-p (find-if-not #'stringp parameters :key #'cdr)) + parameters-used-p) + (when (and file-parameters-p (not (eq method :post))) + (error "Don't know how to handle parameters in ~S, as this is not a POST request." + parameters)) + (when (eq method :post) + ;; create content body for POST unless it was provided + (unless content + ;; mark PARAMETERS argument as used up, so we don't use it + ;; again below + (setq parameters-used-p t) + (cond ((or form-data file-parameters-p) + (let ((boundary (format nil "----------~A" (make-random-string)))) + (setq content (make-form-data-function parameters boundary) + content-type (format nil "multipart/form-data; boundary=~A" boundary))) + (unless (or file-parameters-p content-length-provided-p) + (setq content-length (or content-length t)))) + (t + (setq content (alist-to-url-encoded-string parameters external-format-out) + content-type "application/x-www-form-urlencoded"))))) + (let (http-stream must-close done) + (unwind-protect + (progn + (let ((host (or (and proxy (first proxy)) + (uri-host uri))) + (port (cond (proxy (second proxy)) + ((uri-port uri)) + (t (default-port uri)))) + (use-ssl (or force-ssl + (eq (uri-scheme uri) :https)))) + #+(and :lispworks5.0 :mswindows + (not :lw-does-not-have-write-timeout)) + (when use-ssl + (when (and write-timeout write-timeout-provided-p) + (warn "Disabling WRITE-TIMEOUT because it doesn't mix well with SSL.")) + (setq write-timeout nil)) + (setq http-stream (or stream + #+:lispworks + (comm:open-tcp-stream host port + :element-type 'octet + :timeout connection-timeout + :read-timeout read-timeout + #-:lw-does-not-have-write-timeout + #-:lw-does-not-have-write-timeout + :write-timeout write-timeout + :errorp t) + #-:lispworks + (usocket:socket-stream + (usocket:socket-connect host port :element-type 'octet)))) + (when (and use-ssl + ;; don't attach SSL to existing streams + (not stream)) + #+:lispworks + (comm:attach-ssl http-stream :ssl-side :client) + #-:lispworks + (setq http-stream + #+:allegro + (socket:make-ssl-client-stream http-stream) + #-:allegro + (let ((s http-stream)) + (cl+ssl:make-ssl-client-stream + (cl+ssl:stream-fd s) + :close-callback (lambda () (close s))))))) + (cond (stream + (setf (flexi-stream-element-type http-stream) + #+:lispworks 'lw:simple-char #-:lispworks 'character + (flexi-stream-external-format http-stream) +latin-1+)) + (t + (setq http-stream + (make-flexi-stream (make-chunked-stream http-stream) + :external-format +latin-1+)))) + (labels ((write-http-line (fmt &rest args) + (when *header-stream* + (format *header-stream* "~?~%" fmt args)) + (format http-stream "~?~C~C" fmt args #\Return #\Linefeed)) + (write-header (name value-fmt &rest value-args) + (write-http-line "~A: ~?" name value-fmt value-args))) + (when (and (not parameters-used-p) + parameters) + (setf (uri-query uri) + ;; append parameters to existing query of URI + (format nil "~@[~A~]~:*~:[~;&~]~A" + (uri-query uri) + (alist-to-url-encoded-string parameters external-format-out)))) + (when (eq method :options*) + ;; special pseudo-method + (setf method :options + (uri-path uri) "*" + (uri-query uri) nil)) + (write-http-line "~A ~A ~A" + (string-upcase method) + (cond (proxy (render-uri uri nil)) + (t (format nil "~A~@[?~A~]" + (or (uri-path uri) "/") + (uri-query uri)))) + (string-upcase protocol)) + (write-header "Host" "~A~@[:~A~]" (uri-host uri) (non-default-port uri)) + (when user-agent + (write-header "User-Agent" (user-agent-string user-agent))) + (when basic-authorization + (write-header "Authorization" "Basic ~A" + (base64:string-to-base64-string + (format nil "~A:~A" + (first basic-authorization) + (second basic-authorization))))) + (when (and proxy proxy-basic-authorization) + (write-header "Proxy-Authorization" "Basic ~A" + (base64:string-to-base64-string + (format nil "~A:~A" + (first proxy-basic-authorization) + (second proxy-basic-authorization))))) + (when accept + (write-header "Accept" "~A" accept)) + (when cookie-jar + ;; write all cookies in one fell swoop, so even Sun's + ;; web server has a change to get it + (when-let (cookies (loop for cookie in (cookie-jar-cookies cookie-jar) + when (send-cookie-p cookie uri force-ssl) + collect (cookie-name cookie) and + collect (cookie-value cookie))) + (write-header "Cookie" "~{~A=~A~^; ~}" cookies))) + (when keep-alive + (write-header "Connection" "Keep-Alive")) + (when close + (setq must-close close) + (write-header "Connection" "close")) + (loop for (name . value) in additional-headers + do (write-header name "~A" value)) + (when content + (when content-type + (write-header "Content-Type" "~A" content-type)) + (when (and content-length + (not (or (arrayp content) + (listp content) + (eq content :continuation)))) + ;; CONTENT-LENGTH forces us to compute request body + ;; in RAM + (setq content + (with-output-to-sequence (bin-out) + (let ((out (make-flexi-stream bin-out :external-format +latin-1+))) + (send-content content out))))) + (when (and (or (not content-length-provided-p) + (eq content-length t)) + (or (arrayp content) (listp content))) + (setq content-length (length content))) + (cond (content-length + (write-header "Content-Length" "~D" content-length)) + (t + (write-header "Transfer-Encoding" "chunked")))) + ;; end of request headers + (when *header-stream* + (terpri *header-stream*)) + (format http-stream "~C~C" #\Return #\Linefeed) + (force-output http-stream) + (when (and content (null content-length)) + (setf (chunked-stream-output-chunking-p + (flexi-stream-stream http-stream)) t)) + (labels ((finish-request (content &optional continuep) + (send-content content http-stream external-format-out) + (when continuep + (force-output http-stream) + (return-from finish-request)) + (setf (chunked-stream-output-chunking-p + (flexi-stream-stream http-stream)) nil) + (finish-output http-stream) + (multiple-value-bind (server-protocol status-code status-text) + ;; loop until status is NOT 100 + (loop for (server-protocol status-code status-text) + = (read-status-line http-stream *header-stream*) + when (= status-code 100) + ;; ignore headers sent until non-100 status is seen + do (read-http-headers http-stream *header-stream*) + until (/= status-code 100) + finally (return (values server-protocol status-code status-text))) + (let ((headers (read-http-headers http-stream *header-stream*)) + body external-format-body) + (let ((connections (header-value :connection headers))) + (when connections + (setq connections (split-tokens connections))) + (when (or (member "close" connections :test #'string-equal) + (not (or (and (eq protocol :http/1.1) + (eq server-protocol :http/1.1)) + (member "Keep-Alive" connections + :test #'string-equal)))) + (setq must-close t))) + (when cookie-jar + (update-cookies (get-cookies headers uri) cookie-jar)) + (when (and redirect + (member status-code +redirect-codes+) + (member method redirect-methods)) + (unless (or (eq redirect t) + (and (integerp redirect) + (plusp redirect))) + (cerror "Continue anyway." + "Status code was ~A, but ~ +~:[REDIRECT is ~S~;redirection limit has been exceeded~]." + status-code (integerp redirect) redirect)) + (when auto-referer + (setq additional-headers (set-referer uri additional-headers))) + (let* ((location (header-value :location headers)) + (new-uri (merge-uris (cond ((or (null location) + (zerop (length location))) + (warn "Empty `Location' header, assuming \"/\".") + "/") + (t location)) + uri)) + ;; can we re-use the stream? + (old-server-p (and (string= (uri-host new-uri) + (uri-host uri)) + (eql (uri-port new-uri) + (uri-port uri)) + (eq (uri-scheme new-uri) + (uri-scheme uri))))) + (unless old-server-p + (setq must-close t + want-stream nil)) + ;; try to re-use the stream, but only + ;; if the user hasn't opted for a + ;; connection which is always secure + (let ((re-use-stream (and old-server-p + (not must-close) + (not force-ssl)))) + ;; close stream if we can't re-use it + (unless re-use-stream + (ignore-errors (close http-stream))) + (setq done t) + (return-from http-request + (apply #'http-request new-uri + :redirect (cond ((integerp redirect) (1- redirect)) + (t redirect)) + :stream (and re-use-stream http-stream) + :additional-headers additional-headers + args))))) + (let ((transfer-encodings (header-value :transfer-encoding headers))) + (when transfer-encodings + (setq transfer-encodings (split-tokens transfer-encodings))) + (when (member "chunked" transfer-encodings :test #'equalp) + (setf (chunked-stream-input-chunking-p + (flexi-stream-stream http-stream)) t))) + (when (setq external-format-body + (and (not force-binary) + (funcall *body-format-function* + headers external-format-in))) + (setf (flexi-stream-external-format http-stream) + external-format-body)) + (when force-binary + (setf (flexi-stream-element-type http-stream) 'octet)) + (unless (or want-stream (eq method :head)) + (let (trailers) + (multiple-value-setq (body trailers) + (read-body http-stream headers must-close external-format-body)) + (when trailers + (warn "Adding trailers from chunked encoding to HTTP headers.") + (setq headers (nconc headers trailers))))) + (setq done t) + (values (cond (want-stream http-stream) + (t body)) + status-code + headers + uri + http-stream + must-close + status-text))))) + (when (eq content :continuation) + (return-from http-request #'finish-request)) + (finish-request content)))) + ;; the cleanup form of the UNWIND-PROTECT above + (when (and http-stream + (or (not done) + (and must-close + (not want-stream))) + (not (eq content :continuation))) + (ignore-errors (close http-stream))))))) Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/specials.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/specials.lisp Wed Feb 13 14:41:09 2008 @@ -0,0 +1,208 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/drakma/specials.lisp,v 1.19 2008/01/14 01:57:02 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :drakma) + +(defmacro define-constant (name value &optional doc) + "A version of DEFCONSTANT for, cough, /strict/ CL implementations." + ;; See <http://www.sbcl.org/manual/Defining-Constants.html> + `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) + ,@(when doc (list doc)))) + +(define-constant +latin-1+ (make-external-format :latin-1 :eol-style :lf) + "Default external format when reading headers.") + +(define-constant +redirect-codes+ '(301 302 303 307) + "A list of all HTTP return codes that redirect us to another URI.") + +(define-constant +known-methods+ '(:copy + :delete + :delete + :get + :head + :lock + :mkcol + :move + :options + :options* + :post + :propfind + :proppatch + :put + :trace + :unlock) + "The HTTP methods \(including WebDAV methods) Drakma knows.") + +(defconstant +buffer-size+ 8192) + +(defvar *drakma-default-external-format* ':latin-1 + "The default value for the external format keyword arguments of +HTTP-REQUEST.") + +(defvar *header-stream* nil + "If this variable is not NIL, it should be bound to a stream to +which incoming and outgoing headers will be written for debugging +purposes.") + +(defvar *ignore-unparseable-cookie-dates-p* nil + "Whether Drakma is allowed to treat `Expires' dates in cookie +headers as non-existent if it can't parse them. If the value of this +variable is NIL \(which is the default), an error will be signalled +instead.") + +(defvar *text-content-types* '(("text" . nil)) + "A list of conses which are used by DETERMINE-BODY-FORMAT to decide +whether a `Content-Type' header denotes text content. The car and cdr +of each cons should each be a string or NIL. A content type matches +one of these entries \(and thus denotes text) if the type part is +STRING-EQUAL to the car or if the car is NIL and if the subtype part +is STRING-EQUAL to the cdr or if the cdr is NIL.") + +(defvar *body-format-function* 'determine-body-format + "A function which determines whether the content body returned by +the server is text and should be treated as such or not. The function +is called after the request headers have been read and it must accept +two arguments, HEADERS and EXTERNAL-FORMAT-IN where HEADERS is like +the third return value of HTTP-REQUEST while EXTERNAL-FORMAT-IN is the +HTTP-REQUEST argument of the same name. It should return NIL if the +body should be regarded as binary content, or a FLEXI-STREAMS external +format \(which will be used to read the body) otherwise. + +This function will only be called if the FORCE-BINARY argument to +HTTP-REQUEST was NIL.") + +(defvar *time-zone-map* + ;; list taken from + ;; <http://www.timeanddate.com/library/abbreviations/timezones/> + '(("A" . -1) + ("ACDT" . -10.5) + ("ACST" . -9.5) + ("ADT" . 3) + ("AEDT" . -11) + ("AEST" . -10) + ("AKDT" . 8) + ("AKST" . 9) + ("AST" . 4) + ("AWDT" . -9) + ("AWST" . -8) + ("B" . -2) + ("BST" . -1) + ("C" . -3) + ("CDT" . 5) + ("CEDT" . -2) + ("CEST" . -2) + ("CET" . -1) + ("CST" . -10.5) + ("CST" . -9.5) + ("CST" . 6) + ("CXT" . -7) + ("D" . -4) + ("E" . -5) + ("EDT" . 4) + ("EEDT" . -3) + ("EEST" . -3) + ("EET" . -2) + ("EST" . -11) + ("EST" . -10) + ("EST" . 5) + ("F" . -6) + ("G" . -7) + ("GMT" . 0) + ("H" . -8) + ("HAA" . 3) + ("HAC" . 5) + ("HADT" . 9) + ("HAE" . 4) + ("HAP" . 7) + ("HAR" . 6) + ("HAST" . 10) + ("HAT" . 2.5) + ("HAY" . 8) + ("HNA" . 4) + ("HNC" . 6) + ("HNE" . 5) + ("HNP" . 8) + ("HNR" . 7) + ("HNT" . 3.5) + ("HNY" . 9) + ("I" . -9) + ("IST" . -1) + ("K" . -10) + ("L" . -11) + ("M" . -12) + ("MDT" . 6) + ("MESZ" . -2) + ("MEZ" . -1) + ("MST" . 7) + ("N" . 1) + ("NDT" . 2.5) + ("NFT" . -11.5) + ("NST" . 3.5) + ("O" . 2) + ("P" . 3) + ("PDT" . 7) + ("PST" . 8) + ("Q" . 4) + ("R" . 5) + ("S" . 6) + ("T" . 7) + ("U" . 8) + ("UTC" . 0) + ("V" . 9) + ("W" . 10) + ("WEDT" . -1) + ("WEST" . -1) + ("WET" . 0) + ("WST" . -9) + ("WST" . -8) + ("X" . 11) + ("Y" . 12) + ("Z" . 0)) + "An alist which maps time zone abbreviations to Common Lisp +timezones.") + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see <http://common-lisp.net/project/hyperdoc/> +;; and <http://www.cliki.net/hyperdoc> +;; also used by LW-ADD-ONS + +(defvar *hyperdoc-base-uri* "http://weitz.de/drakma/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :drakma + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) + Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/util.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/drakma-0.11.3/util.lisp Wed Feb 13 14:41:09 2008 @@ -0,0 +1,287 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/drakma/util.lisp,v 1.35 2008/01/14 01:57:02 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :drakma) + +#+:lispworks +(require "comm") + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'lw:when-let)) + +#-:lispworks +(defmacro when-let ((var expr) &body body) + "Evaluates EXPR, binds it to VAR, and executes BODY if VAR has +a true value." + `(let ((,var ,expr)) + (when ,var + ,@body))) + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'lw:with-unique-names)) + +#-:lispworks +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + ,@body)) + +(defun ends-with-p (seq suffix &key (test #'char-equal)) + "Returns true if the sequence SEQ ends with the sequence +SUFFIX. Individual elements are compared with TEST." + (let ((mismatch (mismatch seq suffix :from-end t :test test))) + (or (null mismatch) + (= mismatch (- (length seq) (length suffix)))))) + +(defun starts-with-p (seq prefix &key (test #'char-equal)) + "Returns true if the sequence SEQ starts with the sequence +PREFIX whereby the elements are compared using TEST." + (let ((mismatch (mismatch seq prefix :test test))) + (or (null mismatch) + (= mismatch (length prefix))))) + +(defun url-encode (string external-format) + "Returns a URL-encoded version of the string STRING using the +LispWorks external format EXTERNAL-FORMAT." + (with-output-to-string (out) + (loop for octet across (string-to-octets (or string "") + :external-format external-format) + for char = (code-char octet) + do (cond ((or (char<= #\0 char #\9) + (char<= #\a char #\z) + (char<= #\A char #\Z) + (find char "$-_.!*'()," :test #'char=)) + (write-char char out)) + ((char= char #\Space) + (write-char #\+ out)) + (t (format out "%~2,'0x" (char-code char))))))) + +(defun alist-to-url-encoded-string (alist external-format) + "ALIST is supposed to be an alist of name/value pairs where both +names and values are strings. This function returns a string where +this list is represented as for the content type +`application/x-www-form-urlencoded', i.e. the values are URL-encoded +using the external format EXTERNAL-FORMAT, the pairs are joined with a +#\\& character, and each name is separated from its value with a #\\= +character." + (with-output-to-string (out) + (loop for first = t then nil + for (name . value) in alist + unless first do (write-char #\& out) + do (format out "~A=~A" + (url-encode name external-format) + (url-encode value external-format))))) + +(defun default-port (uri) + "Returns the default port number for the \(PURI) URI URI. +Works only with the http and https schemes." + (ecase (uri-scheme uri) + (:http 80) + (:https 443))) + +(defun non-default-port (uri) + "If the \(PURI) URI specifies an explicit port number which is +different from the default port its scheme, this port number is +returned, otherwise NIL." + (when-let (port (uri-port uri)) + (when (/= port (default-port uri)) + port))) + +(defun user-agent-string (token) + "Returns a corresponding user agent string if TOKEN is one of +the keywords :DRAKMA, :FIREFOX, :EXPLORER, :OPERA, or :SAFARI. +Returns TOKEN itself otherwise." + (case token + (:drakma + (format nil "Drakma/~A (~A~@[ ~A~]; ~A;~@[ ~A;~] http://weitz.de/drakma/)" + *drakma-version-string* + (or (lisp-implementation-type) "Common Lisp") + (or (lisp-implementation-version) "") + (or #-:clisp (software-type) + #+(or :win32 :mswindows) "Windows" + #-(or :win32 :mswindows) "Unix") + (or #-:clisp (software-version)))) + (:firefox + "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.6) Gecko/20060728 Firefox/1.5.0.6") + (:explorer + "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)") + (:opera + "Opera/9.01 (Windows NT 5.1; U; en)") + (:safari + "Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en) AppleWebKit/418.8 (KHTML, like Gecko) Safari/419.3") + (otherwise token))) + +(defun header-value (name headers) + "If HEADERS is an alist of headers as returned by HTTP-REQUEST +and NAME is a keyword naming a header, this function returns the +corresponding value of this header \(or NIL if it's not in +HEADERS)." + (cdr (assoc name headers :test #'eq))) + +(defun parameter-present-p (name parameters) + "If PARAMETERS is an alist of parameters as returned by, for +example, READ-TOKENS-AND-PARAMETERS and NAME is a string naming a +parameter, this function returns the full parameter \(name and +value) - or NIL if it's not in PARAMETERS." + (assoc name parameters :test #'string-equal)) + +(defun parameter-value (name parameters) + "If PARAMETERS is an alist of parameters as returned by, for +example, READ-TOKENS-AND-PARAMETERS and NAME is a string naming a +parameter, this function returns the value of this parameter - or +NIL if it's not in PARAMETERS." + (cdr (parameter-present-p name parameters))) + +(defun make-random-string (&optional (length 50)) + "Generates and returns a random string length LENGTH. The +string will consist solely of decimal digits and ASCII letters." + (with-output-to-string (s) + (dotimes (i length) + (write-char (ecase (random 5) + ((0 1) (code-char (+ #.(char-code #\a) (random 26)))) + ((2 3) (code-char (+ #.(char-code #\A) (random 26)))) + ((4) (code-char (+ #.(char-code #\0) (random 10))))) + s)))) + +(defun split-string (string &optional (separators " ,-")) + "Splits STRING into a list of substrings \(which is returned) +separated by the characters in the sequence SEPARATORS. Empty +substrings aren't collected." + (flet ((make-collector () + (make-array 0 + :adjustable t + :fill-pointer t + :element-type #+:lispworks 'lw:simple-char + #-:lispworks 'character))) + (loop with collector = (make-collector) + for char across string + for counter downfrom (1- (length string)) + when (find char separators :test #'char=) + when (plusp (length collector)) + collect collector + and do (setq collector (make-collector)) end + else + do (vector-push-extend char collector) + and when (zerop counter) + collect collector))) + +(defun safe-parse-integer (string) + "Like PARSE-INTEGER, but returns NIL instead of signalling an error." + (ignore-errors (parse-integer string))) + +(defun interpret-as-month (string) + "Tries to interpret STRING as a string denoting a month and returns +the corresponding number of the month. Accepts three-letter +abbreviations like \"Feb\" and full month names likes \"February\". +Finally, the function also accepts strings representing integers from +one to twelve." + (or (when-let (pos (position (subseq string 0 (min 3 (length string))) + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :test #'string=)) + (1+ pos)) + (when-let (num (safe-parse-integer string)) + (when (<= 1 num 12) + num)))) + +(defun interpret-as-time-zone (string) + "Tries to interpret STRING as a time zone abbreviation which can +either be something like \"PST\" or \"GMT\" with an offset like +\"GMT-02:00\"." + (when-let (zone (cdr (assoc string *time-zone-map* :test #'string=))) + (return-from interpret-as-time-zone zone)) + (unless (and (= (length string) 9) + (starts-with-p string "GMT") + (find (char string 3) "+-" :test #'char=) + (char= (char string 6) #\:) + (every (lambda (pos) + (digit-char-p (char string pos))) + '(4 5 7 8))) + (error "Can't interpret ~S as a time zone." string)) + (let ((hours (parse-integer string :start 4 :end 6)) + (minutes (parse-integer string :start 7 :end 9))) + (* (if (char= (char string 3) #\+) -1 1) + (+ hours (/ minutes 60))))) + +(defun set-referer (referer-uri &optional alist) + "Returns a fresh copy of the HTTP header list ALIST with the +`Referer' header set to REFERER-URI. If REFERER-URI is NIL, the +result will be a list of headers without a `Referer' header." + (let ((alist-sans-referer (remove "Referer" alist :key #'car :test #'string=))) + (cond (referer-uri (acons "Referer" referer-uri alist-sans-referer)) + (t alist-sans-referer)))) + +(defun text-content-type-p (type subtype) + "Returns a true value iff the combination of TYPE and SUBTYPE +matches an entry of *TEXT-CONTENT-TYPES*. See docstring of +*TEXT-CONTENT-TYPES* for more info." + (loop for (candidate-type . candidate-subtype) in *text-content-types* + thereis (and (or (null candidate-type) + (string-equal type candidate-type)) + (or (null candidate-subtype) + (string-equal subtype candidate-subtype))))) + +(defun as-keyword (string) + "Converts the string STRING to a keyword where all characters are +uppercase or lowercase, taking into account the current readtable +case." + (intern (funcall + (if (eq (readtable-case *readtable*) :upcase) + #'string-upcase + #'string-downcase) + string) + :keyword)) +

1 0

[bknr-cvs] r2486 - in branches/trunk-reorg/thirdparty/slime: . contrib contrib/CVS
by hhubner＠common-lisp.net 13 Feb '08

13 Feb '08

Author: hhubner Date: Wed Feb 13 14:40:19 2008 New Revision: 2486 Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el branches/trunk-reorg/thirdparty/slime/slime.el branches/trunk-reorg/thirdparty/slime/swank-backend.lisp branches/trunk-reorg/thirdparty/slime/swank-loader.lisp branches/trunk-reorg/thirdparty/slime/swank.asd branches/trunk-reorg/thirdparty/slime/swank.lisp Log: update and add marcos patch to allow for repeated loading of the swank system Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries Wed Feb 13 14:40:19 2008 @@ -4,34 +4,34 @@ /slime-asdf.el/1.3/Thu Oct 11 14:10:25 2007// /slime-autodoc.el/1.7/Thu Feb 7 07:59:35 2008// /slime-banner.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007// /slime-editing-commands.el/1.6/Thu Feb 7 07:59:35 2008// /slime-fuzzy.el/1.6/Thu Feb 7 07:59:35 2008// /slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007// -/slime-indentation.el/1.1/Sun Feb 3 18:45:14 2008// -/slime-motd.el/1.1/Sun Feb 3 18:39:23 2008// /slime-parse.el/1.10/Thu Feb 7 07:59:35 2008// /slime-presentation-streams.el/1.2/Thu Oct 11 14:10:25 2007// /slime-presentations.el/1.12/Thu Feb 7 07:59:35 2008// /slime-references.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-scheme.el/1.1/Thu Feb 7 08:07:31 2008// /slime-scratch.el/1.4/Thu Oct 11 14:10:25 2007// /slime-tramp.el/1.2/Thu Oct 11 14:10:25 2007// /slime-typeout-frame.el/1.6/Thu Feb 7 07:59:35 2008// -/slime-xref-browser.el/1.1/Thu Oct 11 14:10:25 2007// /swank-arglists.lisp/1.20/Thu Feb 7 08:07:31 2008// /swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007// /swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007// /swank-fuzzy.lisp/1.7/Thu Feb 7 07:59:35 2008// -/swank-goo.goo/1.1/Thu Feb 7 08:07:32 2008// -/swank-indentation.lisp/1.1/Sun Feb 3 18:45:14 2008// -/swank-kawa.scm/1.1/Thu Feb 7 08:07:32 2008// /swank-listener-hooks.lisp/1.1/Thu Oct 11 14:10:25 2007// -/swank-motd.lisp/1.1/Sun Feb 3 18:39:23 2008// /swank-presentation-streams.lisp/1.5/Thu Feb 7 08:07:32 2008// /swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007// -/ChangeLog/1.89/Mon Feb 11 14:20:11 2008// /slime-fancy-inspector.el/1.3/Mon Feb 11 14:20:11 2008// /slime-fancy.el/1.5/Mon Feb 11 14:20:11 2008// /swank-fancy-inspector.lisp/1.11/Mon Feb 11 14:20:11 2008// +/ChangeLog/1.91/Wed Feb 13 19:38:01 2008// +/slime-c-p-c.el/1.9/Wed Feb 13 19:38:01 2008// +/slime-indentation.el/1.1/Wed Feb 13 19:38:02 2008// +/slime-motd.el/1.1/Wed Feb 13 19:38:02 2008// +/slime-scheme.el/1.1/Wed Feb 13 19:38:02 2008// +/slime-xref-browser.el/1.2/Wed Feb 13 19:38:02 2008// +/swank-goo.goo/1.1/Wed Feb 13 19:38:03 2008// +/swank-indentation.lisp/1.1/Wed Feb 13 19:38:03 2008// +/swank-kawa.scm/1.1/Wed Feb 13 19:38:03 2008// +/swank-motd.lisp/1.1/Wed Feb 13 19:38:03 2008// D Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog Wed Feb 13 14:40:19 2008 @@ -1,3 +1,16 @@ +2008-02-13 Helmut Eller <heller(a)common-lisp.net> + + * slime-c-p-c.el (slime-c-p-c-init): Use slime-require instead of + a connected-hook. + +2008-02-13 Helmut Eller <heller(a)common-lisp.net> + + Track tree-widget change: :dynarg is now called :expander. + + * slime-xref-browser.el (slime-expand-class-node) + (slime-browse-classes, slime-expand-xrefs, slime-browse-xrefs): + :dynargs is obsolete, it is now called :expander. + 2008-02-10 Helmut Eller <heller(a)common-lisp.net> Fix some bugs introduced by the recent reorganization. @@ -10,7 +23,7 @@ * slime-fancy.el: slime-fancy-inspector-init no longer exists, so don't call it. Once loaded, it's also no longer possible to turn the fancy inspector off. - + 2008-02-04 Marco Baringer <mb(a)bese.it> * swank-presentation-streams.lisp (presenting-object-1): Add Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el Wed Feb 13 14:40:19 2008 @@ -13,7 +13,7 @@ ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "<directory-of-this-file>") -;; (add-hook 'slime-load-hook (lambda () (require 'slime-c-p-c))) +;; (slime-setup '(slime-c-p-c ... possibly other packages ...)) ;; @@ -177,6 +177,7 @@ (defvar slime-c-p-c-init-undo-stack nil) (defun slime-c-p-c-init () + (slime-require :swank-arglists) ;; save current state for unload (push `(progn @@ -188,13 +189,9 @@ ',(lookup-key slime-repl-mode-map "\C-c\C-s"))) slime-c-p-c-init-undo-stack) (setq slime-complete-symbol-function 'slime-complete-symbol*) - (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect) (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form) (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)) -(defun slime-c-p-c-on-connect () - (slime-eval-async '(swank:swank-require :swank-arglists))) - (defun slime-c-p-c-unload () (while slime-c-p-c-init-undo-stack (eval (pop slime-c-p-c-init-undo-stack)))) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el Wed Feb 13 14:40:19 2008 @@ -8,7 +8,7 @@ ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "<directory-of-this-file>") -;; (add-hook 'slime-load-hook (lambda () (require 'slime-xref-browser))) +;; (slime-setup '(slime-xref-browser ... possibly other packages ...)) ;; @@ -19,7 +19,7 @@ (let ((name (widget-get widget :tag))) (loop for kid in (slime-eval `(swank:mop :subclasses ,name)) collect `(tree-widget :tag ,kid - :dynargs slime-expand-class-node + :expander slime-expand-class-node :has-children t))))) (defun slime-browse-classes (name) @@ -29,7 +29,7 @@ "*slime class browser*" (slime-current-package) "Class Browser" (lambda () (widget-create 'tree-widget :tag name - :dynargs 'slime-expand-class-node + :expander 'slime-expand-class-node :has-echildren t)))) (defvar slime-browser-map nil @@ -84,7 +84,7 @@ collect `(tree-widget :tag ,label :xref-type ,type :xref-dspec ,dspec - :dynargs slime-expand-xrefs + :expander slime-expand-xrefs :has-children t))))) (defun slime-browse-xrefs (name type) @@ -99,6 +99,6 @@ "*slime xref browser*" (slime-current-package) "Xref Browser" (lambda () (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name - :dynargs 'slime-expand-xrefs :has-echildren t)))) + :expander 'slime-expand-xrefs :has-echildren t)))) -(provide 'slime-xref-browser) \ No newline at end of file +(provide 'slime-xref-browser) Modified: branches/trunk-reorg/thirdparty/slime/slime.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/slime.el (original) +++ branches/trunk-reorg/thirdparty/slime/slime.el Wed Feb 13 14:40:19 2008 @@ -1432,6 +1432,7 @@ (format "%S\n\n" `(progn (load ,(expand-file-name loader) :verbose t) + (funcall (read-from-string "swank-loader:load-swank")) (funcall (read-from-string "swank:start-server") ,port-filename :coding-system ,encoding))))) Modified: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp Wed Feb 13 14:40:19 2008 @@ -10,7 +10,11 @@ ;;; separately for each Lisp. Each is declared as a generic function ;;; for which swank-<implementation>.lisp provides methods. -(defpackage :swank-backend +;(cl:eval-when (:compile-toplevel :load-toplevel :execute) +; (cl:when (cl:find-package :swank-backend) +; (cl:delete-package :swank-backend))) + +(cl:defpackage :swank-backend (:use :common-lisp) (:export #:sldb-condition #:original-condition @@ -39,7 +43,11 @@ #:with-struct )) -(defpackage :swank-mop +(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:when (cl:find-package :swank-mop) + (cl:delete-package :swank-mop))) + +(cl:defpackage :swank-mop (:use) (:export ;; classes Modified: branches/trunk-reorg/thirdparty/slime/swank-loader.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-loader.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-loader.lisp Wed Feb 13 14:40:19 2008 @@ -18,11 +18,11 @@ ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/") ;; (load ".../swank-loader.lisp") -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (find-package :swank) - (delete-package :swank) - (delete-package :swank-io-package) - (delete-package :swank-backend))) +;(cl:eval-when (:compile-toplevel :load-toplevel :execute) +; (cl:when (cl:find-package :swank) +; (cl:delete-package :swank-loader) +; (cl:delete-package :swank) +; (cl:delete-package :swank-backend))) (cl:defpackage :swank-loader (:use :cl) @@ -139,7 +139,7 @@ (ignore-errors (delete-file binary-pathname))) (abort)) -(defun compile-files-if-needed-serially (files fasl-directory load) +(defun compile-files-if-needed-serially (files fasl-directory &key load force) "Compile each file in FILES if the source is newer than its corresponding binary, or the file preceding it was recompiled." @@ -149,7 +149,8 @@ fasl-directory))) (handler-case (progn - (when (or needs-recompile + (when (or force + needs-recompile (not (probe-file binary-pathname)) (file-newer-p source-pathname binary-pathname)) ;; need a to recompile source-pathname, so we'll @@ -220,18 +221,17 @@ (source-directory *source-directory*) (fasl-directory *fasl-directory*) (contrib-fasl-directory - (append-dir fasl-directory "contrib"))) + (append-dir fasl-directory "contrib")) + (force nil)) (compile-files-if-needed-serially (swank-source-files source-directory) - fasl-directory t) + fasl-directory :load t :force force) (compile-files-if-needed-serially (contrib-source-files source-directory) - contrib-fasl-directory nil)) - -(load-swank) + contrib-fasl-directory :load nil :force force) -(setq swank::*swank-wire-protocol-version* (slime-version-string)) -(setq swank::*load-path* - (append swank::*load-path* (list (contrib-src-dir *source-directory*)))) -(swank-backend::warn-unimplemented-interfaces) -(load-site-init-file *source-directory*) -(load-user-init-file) -(swank:run-after-init-hook) + (setf (symbol-value (read-from-string "swank::*swank-wire-protocol-version*")) (slime-version-string)) + (push (contrib-src-dir *source-directory*) + (symbol-value (read-from-string "swank::*load-path*"))) + (funcall (read-from-string "swank-backend::warn-unimplemented-interfaces")) + (load-site-init-file *source-directory*) + (load-user-init-file) + (funcall (read-from-string "swank:run-after-init-hook"))) Modified: branches/trunk-reorg/thirdparty/slime/swank.asd ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.asd (original) +++ branches/trunk-reorg/thirdparty/slime/swank.asd Wed Feb 13 14:40:19 2008 @@ -24,25 +24,32 @@ (in-package :swank-loader) -(defclass cl-script-file (asdf:source-file) ()) +(defclass swank-loader-file (asdf:source-file) ()) -(defmethod asdf:perform ((o asdf:compile-op) (f cl-script-file)) - t) -(defmethod asdf:perform ((o asdf:load-op) (f cl-script-file)) - (mapcar #'load (asdf:input-files o f))) -(defmethod asdf:output-files ((o asdf:compile-op) (f cl-script-file)) - nil) -(defmethod asdf:input-files ((o asdf:load-op) (c cl-script-file)) - (list (asdf:component-pathname c))) -(defmethod asdf:operation-done-p ((o asdf:compile-op) (c cl-script-file)) - t) -(defmethod asdf:source-file-type ((c cl-script-file) (s asdf:module)) +;; asdf:compile-op does nothing for swank. + +(defmethod asdf:perform ((o asdf:compile-op) (f swank-loader-file)) t) + +(defmethod asdf:operation-done-p ((o asdf:compile-op) (f swank-loader-file)) t) + +(defmethod asdf:output-files ((o asdf:compile-op) (f swank-loader-file)) '()) + +;; asdf:load-op acutally loads it + +(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file)) + (if (find-package :swank) + (warn "Attempting to load re-load swank into this image. Ignoring request.") + (progn + (load (merge-pathnames (asdf:component-pathname f))) + (funcall (read-from-string "swank-loader:load-swank") + :source-directory (asdf:component-pathname (asdf:find-system :swank)))))) + +(defmethod asdf:operation-done-p ((o asdf:load-op) (f swank-loader-file)) + (find-package :swank)) + +(defmethod asdf:source-file-type ((c swank-loader-file) (s asdf:module)) "lisp") (asdf:defsystem :swank - :default-component-class cl-script-file + :default-component-class swank-loader-file :components ((:file "swank-loader"))) - -(defparameter *source-directory* - (asdf:component-pathname (asdf:find-system :swank))) - Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank.lisp Wed Feb 13 14:40:19 2008 @@ -12,7 +12,11 @@ ;;; them separately for each Lisp implementation. These extensions are ;;; available to us here via the `SWANK-BACKEND' package. -(defpackage :swank +;(cl:eval-when (:compile-toplevel :load-toplevel :execute) +; (cl:when (cl:find-package :swank) +; (cl:delete-package :swank))) + +(cl:defpackage :swank (:use :cl :swank-backend) (:export #:startup-multiprocessing #:start-server

1 0

[bknr-cvs] r2485 - branches/trunk-reorg/bknr/web/src/web
by hhubner＠common-lisp.net 13 Feb '08

13 Feb '08

Author: hhubner Date: Wed Feb 13 05:15:12 2008 New Revision: 2485 Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Log: Fix templater so that top-level element can be user-defined again. Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Wed Feb 13 05:15:12 2008 @@ -147,8 +147,9 @@ (let ((*tag-children* children)) (apply (find-tag-function expander name ns) (append (loop for (key name) in attrs + unless (consp key) ; ignore attributes with namespace collect (make-keyword-from-string key) - collect (expand-variables name #'get-template-var)))))) + and collect (expand-variables name #'get-template-var)))))) (t (sax:start-element *html-sink* nil nil name (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs)) @@ -164,7 +165,7 @@ (sax:start-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel) (cxml-xmls::compute-attributes/lnames toplevel t)) (let ((*template-expander* expander)) - (mapc (curry #'emit-template-node expander) (node-children toplevel))) + (emit-template-node expander toplevel)) (sax:end-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel))) (defun find-template (dir components)

1 0

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

12 Feb '08

Author: ksprotte Date: Tue Feb 12 11:58:31 2008 New Revision: 2484 Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp branches/trunk-reorg/projects/bos/m2/mail-generator.lisp branches/trunk-reorg/projects/bos/m2/utils.lisp branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp branches/trunk-reorg/projects/bos/web/map-handlers.lisp branches/trunk-reorg/projects/bos/web/news-handlers.lisp branches/trunk-reorg/projects/bos/web/news-tags.lisp branches/trunk-reorg/projects/bos/web/poi-handlers.lisp branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp branches/trunk-reorg/projects/bos/web/startup.lisp branches/trunk-reorg/projects/bos/web/tags.lisp branches/trunk-reorg/projects/bos/web/web-utils.lisp branches/trunk-reorg/projects/bos/web/webserver.lisp Log: more changes for bos trunk-reorg Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/m2.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/m2.lisp Tue Feb 12 11:58:31 2008 @@ -446,12 +446,10 @@ (incf retval (length (contract-m2s contract)))) retval)) -;; trunk-reorg adaption -;; (defun string-safe (string) -;; (if string -;; (escape-nl (with-output-to-string (s) -;; (net.html.generator::emit-safe s string))) -;; "")) +(defun string-safe (string) + (if string + (escape-nl (arnesi:escape-as-html string)) + "")) (defun make-m2-javascript (sponsor) "Erzeugt das Quadratmeter-Javascript für die angegebenen Contracts" Modified: branches/trunk-reorg/projects/bos/m2/mail-generator.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/mail-generator.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/mail-generator.lisp Tue Feb 12 11:58:31 2008 @@ -275,7 +275,7 @@ email country language)) - (make-contract-xml-part (store-object-id contract) (all-request-params req)) + (make-contract-xml-part (store-object-id contract) (all-request-params)) (make-vcard-part (store-object-id contract) (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) :note (format nil "Paid-by: Back office @@ -293,7 +293,7 @@ :email email))))) (mail-contract-data contract "Manually entered sponsor" parts)))) -(defun mail-manual-sponsor-data (req) +(defun mail-manual-sponsor-data () (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (sponsor-id (store-object-id (contract-sponsor contract))) @@ -327,7 +327,7 @@ (if want-print "yes" "no") (if donationcert-yearly "yes" "no") *website-url* contract-id email)) - (make-contract-xml-part contract-id (all-request-params req)) + (make-contract-xml-part contract-id (all-request-params)) (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id :note (format nil "Paid-by: Manual money transfer Contract ID: ~A @@ -362,7 +362,7 @@ (remhash contract-id *worldpay-params-hash*)) (error "cannot find WorldPay callback params for contract ~A~%" contract-id))) -(defun mail-worldpay-sponsor-data (req) +(defun mail-worldpay-sponsor-data () (with-query-params (contract-id) (let* ((contract (store-object-with-id (parse-integer contract-id))) (params (get-worldpay-params contract-id)) Modified: branches/trunk-reorg/projects/bos/m2/utils.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/utils.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/utils.lisp Tue Feb 12 11:58:31 2008 @@ -5,4 +5,8 @@ (defun escape-nl (string) (if string (regex-replace-all #?r"[\n\r]+" string #?" ") - "")) \ No newline at end of file + "")) + +(defun random-elt (choices) + (when choices + (elt choices (random (length choices))))) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp Tue Feb 12 11:58:31 2008 @@ -145,7 +145,7 @@ x y (uriencode-string "Choose lower right point of allocation area") (uriencode-string (format nil "~A?left=~A&top=~A&" - (uri-path (hunchentoot:request-uri)) + (hunchentoot:request-uri) x y))))) (t (with-bos-cms-page (:title "Create allocation area") @@ -166,7 +166,7 @@ (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" start-x start-y (uriencode-string "Choose upper left point of allocation area") - (uriencode-string (format nil "~A?" (uri-path (hunchentoot:request-uri)))))))) + (uriencode-string (format nil "~A?" (hunchentoot:request-uri))))))) (defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car)))) Modified: branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp Tue Feb 12 11:58:31 2008 @@ -41,15 +41,15 @@ (defmethod handle ((handler map-browser-handler)) (with-query-params (chosen-url) (when chosen-url - (setf (session-variable :chosen-url) chosen-url))) + (setf (hunchentoot:session-value :chosen-url) chosen-url))) (with-query-params (view-x view-y) (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler) (with-query-params (action) (when (equal action "save") - (if (session-variable :chosen-url) + (if (hunchentoot:session-value :chosen-url) (redirect (format nil "~Ax=~D&y=~D" - (session-variable :chosen-url) + (hunchentoot:session-value :chosen-url) point-x point-y)) (with-bos-cms-page (:title "Map Point Chooser") @@ -130,7 +130,7 @@ ((:div :id "cursor" :style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible") ((:img :src "/images/map-cursor.png"))))))) - (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) + (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) (t (with-bos-cms-page (:title "Map Point Chooser") (html Modified: branches/trunk-reorg/projects/bos/web/map-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/map-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/map-handlers.lisp Tue Feb 12 11:58:31 2008 @@ -2,7 +2,7 @@ (enable-interpol-syntax) -(defun map-navigator (req x y base-url &key formcheck) +(defun map-navigator (x y base-url &key formcheck) (labels ((pfeil-image (name) (html ((:img :border "0" :width "16" :height "16" :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name))))) (td-link-to (x y name &optional (link-format (concatenate 'string base-url "~D/~D"))) @@ -69,27 +69,27 @@ operation-strings)) ;; trunk-reorg adaption -;; (defmethod handle-object ((handler image-tile-handler) tile) -;; ;; xxx parse url another time - the parse result of -;; ;; object-handler-get-object should really be kept in the request -;; (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler) -;; (declare (ignore x y)) -;; (let ((changed-time (image-tile-changed-time tile)) -;; (ims (header-slot-value req :if-modified-since))) -;; (format t "Warning: not setting last-modified of *ent* to changed-time") -;; #+(or) -;; (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) -;; (if (or (not ims) -;; (> changed-time (date-to-universal-time ims))) -;; (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) -;; (emit-image-to-browser image :png -;; :date changed-time -;; :max-age 60) -;; (cl-gd:destroy-image image)) -;; (with-http-response (*ent*) -;; (with-http-body () -;; ; do nothing -;; )))))) +(defmethod handle-object ((handler image-tile-handler) tile) + ;; xxx parse url another time - the parse result of + ;; object-handler-get-object should really be kept in the request + (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler) + (declare (ignore x y)) + (let ((changed-time (image-tile-changed-time tile)) + (ims (hunchentoot:header-in :if-modified-since))) + (format t "Warning: not setting last-modified of *ent* to changed-time") + #+(or) + (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) + (if (or (not ims) + (> changed-time (date-to-universal-time ims))) + (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) + (emit-image-to-browser image :png + :date changed-time + :max-age 60) + (cl-gd:destroy-image image)) + (with-http-response () + (with-http-body () + ;; do nothing + )))))) (defclass enlarge-tile-handler (image-tile-handler) ()) @@ -107,22 +107,21 @@ x y (tile-active-layers-from-request-params tile))) -;; trunk-reorg adaption -;; (defmethod handle-object ((handler enlarge-tile-handler) tile) -;; (let ((ismap-coords (decode-ismap-query-string req)) -;; (tile-x (tile-nw-x tile)) -;; (tile-y (tile-nw-y tile))) -;; (if ismap-coords -;; (let* ((x (+ (floor (first ismap-coords) 4) tile-x)) -;; (y (+ (floor (second ismap-coords) 4) tile-y)) -;; (m2 (get-m2 x y)) -;; (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) -;; (if contract-id -;; (redirect #?"/contract/$(contract-id)") -;; (with-bos-cms-page (:title "Not sold") -;; (html (:h2 "this square meter has not been sold yet"))))) -;; (with-bos-cms-page (:title "Browsing tile") -;; (:a ((:a :href (uri-path (hunchentoot:request-uri))) -;; ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req))))) -;; (map-navigator req tile-x tile-y "/enlarge-overview/"))))) +(defmethod handle-object ((handler enlarge-tile-handler) tile) + (let ((ismap-coords (decode-ismap-query-string)) + (tile-x (tile-nw-x tile)) + (tile-y (tile-nw-y tile))) + (if ismap-coords + (let* ((x (+ (floor (first ismap-coords) 4) tile-x)) + (y (+ (floor (second ismap-coords) 4) tile-y)) + (m2 (get-m2 x y)) + (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) + (if contract-id + (redirect #?"/contract/$(contract-id)") + (with-bos-cms-page (:title "Not sold") + (html (:h2 "this square meter has not been sold yet"))))) + (with-bos-cms-page (:title "Browsing tile") + (:a ((:a :href (hunchentoot:request-uri)) + ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y))))) + (map-navigator tile-x tile-y "/enlarge-overview/"))))) Modified: branches/trunk-reorg/projects/bos/web/news-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/news-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/news-handlers.lisp Tue Feb 12 11:58:31 2008 @@ -10,7 +10,7 @@ ()) (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil))) - (let ((language (session-variable :language))) + (let ((language (hunchentoot:session-value :language))) (with-bos-cms-page (:title "Edit news items") (content-language-chooser) (:h2 "Create new item") @@ -33,7 +33,7 @@ (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))))) (defmethod handle-object-form ((handler edit-news-handler) action news-item) - (let ((language (session-variable :language))) + (let ((language (hunchentoot:session-value :language))) (with-bos-cms-page (:title "Edit news item") (content-language-chooser) ((:script :type "text/javascript") @@ -49,7 +49,7 @@ (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the news item?")))))))) (defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item) - (let ((language (session-variable :language))) + (let ((language (hunchentoot:session-value :language))) (with-query-params (title text) (update-news-item news-item language :title title :text text) (with-bos-cms-page (:title "News item updated") Modified: branches/trunk-reorg/projects/bos/web/news-tags.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/news-tags.lisp (original) +++ branches/trunk-reorg/projects/bos/web/news-tags.lisp Tue Feb 12 11:58:31 2008 @@ -7,17 +7,17 @@ do (html (:princ-safe line) :br))) (define-bknr-tag news-headlines (&key archive) - (let ((language (session-variable :language))) + (let ((language (hunchentoot:session-value :language))) (let* ((now (get-universal-time)) - (news-items (subseq - (sort (if archive - (all-news-items language) - (remove-if #'(lambda (news-item) - (> (- now (news-item-time news-item)) *maximum-news-item-age*)) - (all-news-items language))) - #'> - :key #'news-item-time) - 0 (unless archive 3)))) + (news-items (if archive + (all-news-items language) + (let ((items (sort (remove-if + #'(lambda (news-item) + (> (- now (news-item-time news-item)) *maximum-news-item-age*)) + (all-news-items language)) + #'> + :key #'news-item-time))) + (subseq items 0 (min (length items) 3)))))) (labels ((show-news-entry (news-item) (html ((:a :href (format nil "javascript:window_news('news/~a')" (store-object-id news-item)) :class "more") @@ -25,16 +25,16 @@ :br (:princ-safe (news-item-title news-item language))))))) (loop for news-item in news-items - for index from 1 - do (if archive - (html (show-news-entry news-item) - :br :br) - (html ((:div :id (format nil "newsbox~a" index)) - (show-news-entry news-item))))))))) + for index from 1 + do (if archive + (html (show-news-entry news-item) + :br :br) + (html ((:div :id (format nil "newsbox~a" index)) + (show-news-entry news-item))))))))) (define-bknr-tag news-item () (let ((news-item (find-store-object (parse-integer (nth-value 1 (parse-url (get-template-var :request)))))) - (language (session-variable :language))) + (language (hunchentoot:session-value :language))) (html ((:h1 :class "extra") (:princ-safe (format-date-time (news-item-time news-item) :show-time nil)) ", " Modified: branches/trunk-reorg/projects/bos/web/poi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/poi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/poi-handlers.lisp Tue Feb 12 11:58:31 2008 @@ -18,7 +18,7 @@ (html (:h2 "Bad technical name") "Please use only alphanumerical characters, - and _ for technical POI names"))) (t - (redirect (edit-object-url (make-poi (session-variable :language) name))))))) + (redirect (edit-object-url (make-poi (hunchentoot:session-value :language) name))))))) (defclass edit-poi-handler (editor-only-handler edit-object-handler) () @@ -34,7 +34,7 @@ do (html (:li (cmslink (edit-object-url poi) (:princ-safe (poi-name poi)) " - " - (:princ-safe (slot-string poi 'title (session-variable :language))))))))) + (:princ-safe (slot-string poi 'title (hunchentoot:session-value :language))))))))) (html (:h2 "No POIs created yet"))) ((:form :method "post" :action "/make-poi") "Make new POI named " @@ -52,7 +52,7 @@ (defmethod handle-object-form ((handler edit-poi-handler) action (poi poi)) (with-query-params (language shift shift-by) - (unless language (setq language (session-variable :language))) + (unless language (setq language (hunchentoot:session-value :language))) (when shift ;; change image order (setq shift (find-store-object (parse-integer shift))) @@ -65,7 +65,7 @@ (setf (nth old-position new-images) (nth (+ shift-by old-position) new-images)) (setf (nth (+ shift-by old-position) new-images) tmp) (change-slot-values poi 'bos.m2::images new-images))) - (setf (session-variable :language) language) + (setf (hunchentoot:session-value :language) language) (with-bos-cms-page (:title "Edit POI") (content-language-chooser) (unless (poi-complete poi language) @@ -95,11 +95,11 @@ (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi))))) (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" (first (poi-area poi)) (second (poi-area poi)) - (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri))))) + (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri)))) "[relocate]")) (t (cmslink (format nil "map-browser/?chosen-url=~A" - (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri))))) + (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri)))) "[choose]"))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) @@ -169,7 +169,7 @@ (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :save)) (poi poi)) (with-query-params (published title subtitle description language x y icon movie) - (unless language (setq language (session-variable :language))) + (unless language (setq language (hunchentoot:session-value :language))) (let ((args (list :title title :published published :subtitle subtitle @@ -301,7 +301,7 @@ (defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) (with-query-params (language poi) - (unless language (setq language (session-variable :language))) + (unless language (setq language (hunchentoot:session-value :language))) (with-bos-cms-page (:title "Edit POI Image") (html (cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI") @@ -331,7 +331,7 @@ (defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) (with-query-params (title subtitle description language) - (unless language (setq language (session-variable :language))) + (unless language (setq language (hunchentoot:session-value :language))) (update-poi-image poi-image language :title title :subtitle subtitle @@ -366,7 +366,7 @@ (with-http-body () (let ((*standard-output* *html-stream*)) (princ "<script language=\"JavaScript\">") (terpri) - (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri) + (princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) (terpri) (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) (princ "</script>") (terpri))))) 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 Tue Feb 12 11:58:31 2008 @@ -192,7 +192,7 @@ (html (:p "Changed contract status to \"paid\"")))) (unless changed (html (:p "No changes have been made"))) - (html (cmslink (uri-path (hunchentoot:request-uri)) + (html (cmslink (hunchentoot:request-uri) "Return to sponsor profile"))))) (defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor) Modified: branches/trunk-reorg/projects/bos/web/startup.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/startup.lisp (original) +++ branches/trunk-reorg/projects/bos/web/startup.lisp Tue Feb 12 11:58:31 2008 @@ -36,12 +36,15 @@ (defun reinit (&key debug) (format t "~&; Publishing BOS handlers.~%") - (unpublish :all t) + (unpublish) (bos.web::publish-website :website-directory *website-directory* :vhosts *vhosts* :website-url *website-url* :worldpay-test-mode *worldpay-test-mode*) - (format t "~&; Starting aserve~@[ in debug mode~].~%" debug) + (format t "~&; Starting hunchentoot~@[ in debug mode~].~%" debug) (force-output) (setq hunchentoot:*catch-errors-p* (not debug)) - (hunchentoot:start-server :port *port*)) + (when *webserver* + (hunchentoot:stop-server *webserver*)) + (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) + (setq *webserver* (hunchentoot:start-server :port *port*))) 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 Tue Feb 12 11:58:31 2008 @@ -41,7 +41,7 @@ (let ((contract (find-store-object (parse-integer (get-template-var :contract-id))))) (when (equal want-print "no") (contract-set-download-only-p contract t)) - (contract-issue-cert contract name :address address :language (session-variable :language)) + (contract-issue-cert contract name :address address :language (hunchentoot:session-value :language)) (mail-worldpay-sponsor-data (get-template-var :request)) (bknr.web::redirect-request :target (if gift "index" (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" @@ -78,7 +78,7 @@ (manual-transfer (or (scan #?r"rweisen" action) (scan #?r"rweisung" action) (scan #?r"verf" action))) - (language (session-variable :language)) + (language (hunchentoot:session-value :language)) (sponsor (make-sponsor :language language)) (contract (make-contract sponsor numsqm :download-only download-only @@ -120,8 +120,7 @@ (bknr.web::redirect-request :target "allocation-areas-exhausted")))) (define-bknr-tag mail-transfer () - (with-query-params ((get-template-var :request) - country + (with-query-params (country contract-id name vorname strasse plz ort) (let* ((contract (store-object-with-id (parse-integer contract-id))) @@ -134,7 +133,7 @@ vorname name strasse plz ort) - :language (session-variable :language)) + :language (hunchentoot:session-value :language)) (mail-manual-sponsor-data (get-template-var :request))))) (define-bknr-tag when-certificate (&key children) Modified: branches/trunk-reorg/projects/bos/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/web-utils.lisp (original) +++ branches/trunk-reorg/projects/bos/web/web-utils.lisp Tue Feb 12 11:58:31 2008 @@ -42,9 +42,9 @@ (cadr (assoc language-short-name (website-languages) :test #'equal))) (defun current-website-language () - (unless (session-variable :language) - (setf (session-variable :language) *default-language*)) - (session-variable :language)) + (unless (hunchentoot:session-value :language) + (setf (hunchentoot:session-value :language) *default-language*)) + (hunchentoot:session-value :language)) (defun content-language-chooser () (html @@ -52,9 +52,9 @@ "Content languages: " (loop for (language-symbol language-name) in (website-languages) do (labels ((show-language-link () - (html (cmslink (format nil "~A?language=~A" (uri-path (hunchentoot:request-uri)) language-symbol) + (html (cmslink (format nil "~A?language=~A" (hunchentoot:request-uri) language-symbol) (:princ-safe language-name))))) - (if (equal (session-variable :language) language-symbol) + (if (equal (hunchentoot:session-value :language) language-symbol) (html "[" (show-language-link) "]") (html (show-language-link))) (html " ")))))) Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/webserver.lisp (original) +++ branches/trunk-reorg/projects/bos/web/webserver.lisp Tue Feb 12 11:58:31 2008 @@ -46,8 +46,8 @@ (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info"))))))) ((and (not (scan "/" template-name)) (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml") - (template-handler-destination handler))))) - (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request) + (bknr.web::template-expander-destination handler))))) + (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language) *default-language*) (if (equal "" template-name) "index" template-name))))) @@ -78,7 +78,7 @@ "Determine the language prefered by the user, as determined by the Accept-Language header present in the HTTP request. Header decoding is done according to RFC2616, considering individual language preference weights." - (let ((accept-language (header-slot-value req :accept-language))) + (let ((accept-language (hunchentoot:header-in :accept-language))) (dolist (language (mapcar #'car (sort (mapcar #'(lambda (language-spec-string) (if (find #\; language-spec-string) @@ -102,7 +102,7 @@ (defmethod handle ((handler index-handler)) (redirect (format nil "/~A/index" (or (find-browser-prefered-language) *default-language*)) - :permanently *response-moved-permanently*)) + :permanently t)) (defclass infosystem-handler (page-handler) ()) @@ -112,7 +112,7 @@ (with-query-params (logout) (when logout (bknr.web::drop-session *session*))) - (let ((language (session-variable :language))) + (let ((language (hunchentoot:session-value :language))) (redirect #?"/infosystem/$(language)/satellitenkarte.htm"))) (defclass certificate-handler (object-handler) @@ -172,7 +172,7 @@ ;; (defmethod authorize :after ((authorizer bos-authorizer) ;; (req http-request) ;; (ent net.aserve::entity)) -;; (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri))) +;; (let ((new-language (or (language-from-url (hunchentoot:request-uri)) ;; (query-param "language"))) ;; (current-language (gethash :language (bknr-session-variables *session*)))) ;; (when (or (not current-language) @@ -180,9 +180,13 @@ ;; (not (equal new-language current-language)))) ;; (setf (gethash :language (bknr-session-variables *session*)) ;; (or new-language -;; (find-browser-prefered-language req) +;; (find-browser-prefered-language) ;; *default-language*))))) +;;; TODOreorg +(defun publish-directory (&key prefix destination) + (push (hunchentoot:create-folder-dispatcher-and-handler prefix destination) hunchentoot:*dispatch-table*)) + (defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild)) (setf *website-directory* website-directory) @@ -231,8 +235,8 @@ ("/index" index-handler) ("/" worldpay-template-handler :destination ,(namestring (merge-pathnames #p"templates/" website-directory)) - :command-packages ((:bos . :bos.web) - (:bknr . :bknr.web)))) + :command-packages (("http://headcraft.de/bos" . :bos.web) + ("http://bknr.net" . :bknr.web)))) :modules '(user images stats) :navigation '(("sponsor" . "edit-sponsor/") ("statistics" . "statistics/") @@ -256,4 +260,4 @@ (publish-directory :prefix "/infosystem/" :destination (namestring (merge-pathnames "infosystem/" website-directory))) (publish-directory :prefix "/certificates/" - :destination (namestring *cert-download-directory*))) + :destination (namestring *cert-download-directory*))) \ No newline at end of file

1 0

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

12 Feb '08

Author: ksprotte Date: Tue Feb 12 11:56:56 2008 New Revision: 2483 Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp Log: (script-name) from hunchentoot returns a string and must be parsed here into an uri 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 Tue Feb 12 11:56:56 2008 @@ -233,7 +233,7 @@ (if (not (authorized-p handler)) (progn (setf (session-value :login-redirect-uri) - (redirect-uri (script-name))) + (redirect-uri (parse-uri (script-name)))) (redirect (website-make-path *website* "login"))) (if *catch-errors-p* (handle handler)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs