March 2010 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] hans changed deployed/bos/projects/bos/payment-website/templates/da/bestellung.xml
by BKNR Commits 31 Mar '10

31 Mar '10

Revision: 4523 Author: hans URL: http://bknr.net/trac/changeset/4523 BOS Daenemark nimmt keine Ueberweisungen mehr an. U deployed/bos/projects/bos/payment-website/templates/da/bestellung.xml Modified: deployed/bos/projects/bos/payment-website/templates/da/bestellung.xml =================================================================== --- deployed/bos/projects/bos/payment-website/templates/da/bestellung.xml 2010-03-30 13:22:17 UTC (rev 4522) +++ deployed/bos/projects/bos/payment-website/templates/da/bestellung.xml 2010-03-31 13:41:11 UTC (rev 4523) @@ -130,8 +130,7 @@ betaling med kredit kort. Bemærk, at onlinebetaling med kreditkort går via BOS Tyskland. Du kan derfor ikke få fradrag på sin selvangivelse, når du betaler - med kreditkort. For at opnå skattefradrag, skal du - betale via bankoverførsel. + med kreditkort. </span> <!-- Ich möchte den administrativen Aufwand und Kosten für BOS verringern und @@ -145,7 +144,7 @@ <tr> <td colspan="3"> <span class="help_text"> - [Information DanKort]<br></br>Vi kan tilbyde betaling med internationale kreditkort men desværre endnu ikke betaling med DanKort. Hvis du ikke er i besiddelse af et internationalt kreditkort (MasterCard, Visa o.l.), kan du overføre via din bank. + [Information DanKort]<br></br>Vi kan tilbyde betaling med internationale kreditkort men desværre endnu ikke betaling med DanKort. </span> </td> </tr> @@ -165,8 +164,6 @@ <tr> <td align="right" colspan="3"> <input type="submit" class="form_big_bold" name="action" value="Doner online" onclick="return check_online();" /> - <input type="submit" class="form_big" name="action" value="bankoverførsel" onclick="return check_ueberweisung();" /> - </td> </tr> </table>

1 0

[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
by BKNR Commits 30 Mar '10

30 Mar '10

Revision: 4522 Author: edi URL: http://bknr.net/trac/changeset/4522 Safeguard measures against XSS attacks (J.P. Larocque) U trunk/thirdparty/hunchentoot/CHANGELOG U trunk/thirdparty/hunchentoot/headers.lisp U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/CHANGELOG =================================================================== --- trunk/thirdparty/hunchentoot/CHANGELOG 2010-03-23 12:57:15 UTC (rev 4521) +++ trunk/thirdparty/hunchentoot/CHANGELOG 2010-03-30 13:22:17 UTC (rev 4522) @@ -1,3 +1,4 @@ +Safeguard measures against XSS attacks (J.P. Larocque) Prevent potential leak when closing stream (Matt Lamari, Martin Simmons) Change some occurrences of HANDLER-CASE* to HANDLER-CASE (Hans Hübner, Allan Dee) Modified: trunk/thirdparty/hunchentoot/headers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/headers.lisp 2010-03-23 12:57:15 UTC (rev 4521) +++ trunk/thirdparty/hunchentoot/headers.lisp 2010-03-30 13:22:17 UTC (rev 4522) @@ -157,15 +157,15 @@ ((#.+http-internal-server-error+) content) ((#.+http-moved-temporarily+ #.+http-moved-permanently+) (format nil "The document has moved <a href='~A'>here</a>" - (header-out :location))) + (escape-for-html (header-out :location)))) ((#.+http-authorization-required+) "The server could not verify that you are authorized to access the document requested. Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't understand how to supply the credentials required.") ((#.+http-forbidden+) (format nil "You don't have permission to access ~A on this server." - (script-name request))) + (escape-for-html (script-name request)))) ((#.+http-not-found+) (format nil "The requested URL ~A was not found on this server." - (script-name request))) + (escape-for-html (script-name request)))) ((#.+http-bad-request+) "Your browser sent a request that this server could not understand.") (otherwise "")) Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2010-03-23 12:57:15 UTC (rev 4521) +++ trunk/thirdparty/hunchentoot/util.lisp 2010-03-30 13:22:17 UTC (rev 4522) @@ -302,7 +302,7 @@ +implementation-link+ (escape-for-html (lisp-implementation-type)) (escape-for-html (lisp-implementation-version)) - (or (host *request*) (acceptor-address *acceptor*)) + (escape-for-html (or (host *request*) (acceptor-address *acceptor*))) (scan ":\\d+$" (or (host *request*) "")) (acceptor-port *acceptor*)))

1 0

[bknr-cvs] hans changed deployed/bos/projects/bos/
by BKNR Commits 23 Mar '10

23 Mar '10

Revision: 4521 Author: hans URL: http://bknr.net/trac/changeset/4521 Format tweaks in sponsor list. U deployed/bos/projects/bos/payment-website/static/contracts.xsl U deployed/bos/projects/bos/web/reports-xml-handler.lisp Modified: deployed/bos/projects/bos/payment-website/static/contracts.xsl =================================================================== --- deployed/bos/projects/bos/payment-website/static/contracts.xsl 2010-03-23 10:54:57 UTC (rev 4520) +++ deployed/bos/projects/bos/payment-website/static/contracts.xsl 2010-03-23 12:57:15 UTC (rev 4521) @@ -10,7 +10,7 @@ <body> <table border="1"> <thead> - <tr><th>Name</th><th>ID</th><th>Country</th><th>Coordinate (x/y)</th><th>qm</th></tr> + <tr><th>Name</th><th>ID</th><th>Country</th><th>Coordinate</th><th>qm</th></tr> </thead> <tbody> <xsl:apply-templates/> @@ -23,10 +23,10 @@ <xsl:template match="contract"> <tr> <td><xsl:value-of select="@sponsor-name" /></td> - <td><xsl:value-of select="@sponsor-id" /></td> - <td><xsl:value-of select="@country" /></td> - <td><xsl:value-of select="@utm-x" />/<xsl:value-of select="@utm-y" /></td> - <td><xsl:value-of select="@sqm-count" /></td> + <td align="right"><xsl:value-of select="@sponsor-id" /></td> + <td align="right"><xsl:value-of select="@country" /></td> + <td align="right"><xsl:value-of select="@coords" /></td> + <td align="right"><xsl:value-of select="@sqm-count" /></td> </tr> </xsl:template> </xsl:stylesheet> Modified: deployed/bos/projects/bos/web/reports-xml-handler.lisp =================================================================== --- deployed/bos/projects/bos/web/reports-xml-handler.lisp 2010-03-23 10:54:57 UTC (rev 4520) +++ deployed/bos/projects/bos/web/reports-xml-handler.lisp 2010-03-23 12:57:15 UTC (rev 4521) @@ -53,9 +53,8 @@ (attribute "country" (sponsor-country sponsor)) (attribute "sqm-count" (length (contract-m2s contract))) (when include-coords - (let ((m2 (first (contract-m2s contract)))) - (attribute "utm-x" (m2-x m2)) - (attribute "utm-y" (m2-y m2)))))))) + (destructuring-bind (lon lat) (m2-lon-lat (first (contract-m2s contract))) + (attribute "coords" (with-output-to-string (s) (geometry:format-lon-lat s lon lat))))))))) (defreport all-contracts () (all-contracts/internal))

1 0

[bknr-cvs] hans changed deployed/bos/projects/bos/
by BKNR Commits 23 Mar '10

23 Mar '10

Revision: 4520 Author: hans URL: http://bknr.net/trac/changeset/4520 Make /reports-xml/all-contracts-m2s into a HTML table by default, requested by the SL team in Indonesia. A deployed/bos/projects/bos/payment-website/static/contracts.xsl U deployed/bos/projects/bos/web/reports-xml-handler.lisp Added: deployed/bos/projects/bos/payment-website/static/contracts.xsl =================================================================== --- deployed/bos/projects/bos/payment-website/static/contracts.xsl (rev 0) +++ deployed/bos/projects/bos/payment-website/static/contracts.xsl 2010-03-23 10:54:57 UTC (rev 4520) @@ -0,0 +1,34 @@ +<?xml version="1.0" encoding="utf-8"?> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + version="1.0"> + <xsl:output method="html"/> + + <xsl:template match="/"> + <html xmlns="http://www.w3.org/1999/xhtml"> + <head> + <title>Samboja Lestari Donor List</title></head> + <body> + <table border="1"> + <thead> + <tr><th>Name</th><th>ID</th><th>Country</th><th>Coordinate (x/y)</th><th>qm</th></tr> + </thead> + <tbody> + <xsl:apply-templates/> + </tbody> + </table> + </body> + </html> + </xsl:template> + + <xsl:template match="contract"> + <tr> + <td><xsl:value-of select="@sponsor-name" /></td> + <td><xsl:value-of select="@sponsor-id" /></td> + <td><xsl:value-of select="@country" /></td> + <td><xsl:value-of select="@utm-x" />/<xsl:value-of select="@utm-y" /></td> + <td><xsl:value-of select="@sqm-count" /></td> + </tr> + </xsl:template> +</xsl:stylesheet> + + Modified: deployed/bos/projects/bos/web/reports-xml-handler.lisp =================================================================== --- deployed/bos/projects/bos/web/reports-xml-handler.lisp 2010-03-09 16:47:23 UTC (rev 4519) +++ deployed/bos/projects/bos/web/reports-xml-handler.lisp 2010-03-23 10:54:57 UTC (rev 4520) @@ -41,17 +41,19 @@ (defun all-contracts/internal (&key include-coords) (dolist (contract *contracts-to-process*) - (with-element "contract" - (attribute "id" (store-object-id contract)) - (attribute "sponsor-id" (store-object-id (contract-sponsor contract))) - (attribute "universal-time" (contract-date contract)) - (attribute "paid" (contract-paidp contract)) - (attribute "date-time" (format-date-time (contract-date contract) :xml-style t)) - (attribute "country" (sponsor-country (contract-sponsor contract))) - (attribute "sqm-count" (length (contract-m2s contract))) - (when include-coords - (dolist (m2 (contract-m2s contract)) - (with-element "m2" + (let ((sponsor (contract-sponsor contract))) + (with-element "contract" + (attribute "id" (store-object-id contract)) + (attribute "sponsor-id" (store-object-id sponsor)) + (when (user-full-name sponsor) + (attribute "sponsor-name" (user-full-name sponsor))) + (attribute "universal-time" (contract-date contract)) + (attribute "paid" (contract-paidp contract)) + (attribute "date-time" (format-date-time (contract-date contract) :xml-style t)) + (attribute "country" (sponsor-country sponsor)) + (attribute "sqm-count" (length (contract-m2s contract))) + (when include-coords + (let ((m2 (first (contract-m2s contract)))) (attribute "utm-x" (m2-x m2)) (attribute "utm-y" (m2-y m2)))))))) @@ -59,6 +61,7 @@ (all-contracts/internal)) (defreport all-contracts-m2s () + (sax:processing-instruction cxml::*sink* "xml-stylesheet" "href=\"/static/contracts.xsl\" type=\"text/xsl\"") (all-contracts/internal :include-coords t)) (defun week-of-contract (contract)

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
by BKNR Commits 09 Mar '10

09 Mar '10

Revision: 4519 Author: hans URL: http://bknr.net/trac/changeset/4519 Documentation update and typo fix from Andrey Moskvitin. U trunk/thirdparty/hunchentoot/conditions.lisp U trunk/thirdparty/hunchentoot/doc/index.xml Modified: trunk/thirdparty/hunchentoot/conditions.lisp =================================================================== --- trunk/thirdparty/hunchentoot/conditions.lisp 2010-03-07 09:16:10 UTC (rev 4518) +++ trunk/thirdparty/hunchentoot/conditions.lisp 2010-03-09 16:47:23 UTC (rev 4519) @@ -104,10 +104,10 @@ "Used to enable debug mode" (setf *catch-errors-p* nil)) -(defun debug-mode-off (&optional (kill-debuging-threads t)) +(defun debug-mode-off (&optional (kill-debugging-threads t)) "Used to turn off debug mode" (setf *catch-errors-p* t) - (when kill-debuging-threads + (when kill-debugging-threads (kill-all-debugging-threads))) (defun after-close-swank-connection (connection) @@ -129,8 +129,8 @@ "The default method invokes the debugger with CONDITION if *CATCH-ERRORS-P* is NIL." (unless (or *catch-errors-p* - (< *max-debugging-threads* - (length *debugging-threads*))) + (<= *max-debugging-threads* + (length *debugging-threads*))) (let ((thread (bt:current-thread))) (with-lock-held (*debugging-threads-lock*) (push thread *debugging-threads*)) Modified: trunk/thirdparty/hunchentoot/doc/index.xml =================================================================== --- trunk/thirdparty/hunchentoot/doc/index.xml 2010-03-07 09:16:10 UTC (rev 4518) +++ trunk/thirdparty/hunchentoot/doc/index.xml 2010-03-09 16:47:23 UTC (rev 4519) @@ -152,6 +152,12 @@ <a href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>. </p> + <p> + Andrey Moskvitin maintains a <a href="http://git-scm.com/">git</a> + repository of Hunchentoot at + <a href="http://github.com/archimag/hunchentoot">http://github.com/archimag/hunchentoot</a>. + </p> + <clix:subchapter name="proxy" title="Hunchentoot behind a proxy"> If you're feeling unsecure about exposing Hunchentoot to the wild, @@ -2646,6 +2652,45 @@ </clix:description> </clix:special-variable> + <clix:function name='debug-mode-on'> + <clix:description> +Enable debug mode: sets the value of <clix:ref>*CATCH-ERRORS-P*</clix:ref> to <code>NIL</code>. + </clix:description> + </clix:function> + + <clix:function name='debug-mode-off'> + <clix:lambda-list><clix:lkw>optional</clix:lkw> kill-debugging-threads + </clix:lambda-list> + <clix:description> +Disable debug mode: sets the value +of <clix:ref>*CATCH-ERRORS-P*</clix:ref> to <code>T</code>. If the +value of <clix:arg>kill-debugging-threads</clix:arg> +is <code>T</code>, which is the default, all threads that are sent to +the debugger by <clix:ref>MAYBE-INVOKE-DEBUGGER</clix:ref> will be +terminated. If +a <a href="http://common-lisp.net/project/slime/">swank</a> server is +present, <code>(debug-mode-off t)</code> will be automatically be +called after the connection to the swank server is established: this +provides some protection when debug mode has accidentially been +enabled in a production environment. + </clix:description> + </clix:function> + + <clix:special-variable name='*max-debugging-threads*'> + <clix:description> +This variable determines the maximum number of threads that are sent +to +the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_d.htm#debugger">debugger</a> +by <clix:ref>MAYBE-INVOKE-DEBUGGER</clix:ref>. The default for this +parameter is 5. Once this limit is +reached, <clix:ref>MAYBE-INVOKE-DEBUGGER</clix:ref> does not invoke +the debugger for new threads that signal an error. This behavior can +be helpful for safer debugging a production environment. +See <clix:ref>MAYBE-INVOKE-DEBUGGER</clix:ref> if you want to +fine-tune this behaviour. + </clix:description> + </clix:special-variable> + <clix:function generic='true' name='maybe-invoke-debugger'> <clix:lambda-list>condition </clix:lambda-list> @@ -2660,7 +2705,9 @@ method <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_invoke.htm">invokes the debugger</a> with <clix:arg>condition</clix:arg> if -<clix:ref>*CATCH-ERRORS-P*</clix:ref> is <code>NIL</code>. +<clix:ref>*CATCH-ERRORS-P*</clix:ref> is <code>NIL</code> and the number of active <a +href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_d.htm#debugger">debuggers</a> +is less than <clix:ref>*MAX-DEBUGGING-THREADS*</clix:ref>. </clix:description> </clix:function>

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
by BKNR Commits 07 Mar '10

07 Mar '10

Revision: 4518 Author: hans URL: http://bknr.net/trac/changeset/4518 Debugging improved, patch supplied by Andrey Moskvitin. Introduces a new parameter: (defparameter *max-debugging-threads* 5 "Maximum number of simultaneous active calls invoke-debuger") This can be used to limit the number of debuggers that can be opened at once. U trunk/thirdparty/hunchentoot/conditions.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/specials.lisp Modified: trunk/thirdparty/hunchentoot/conditions.lisp =================================================================== --- trunk/thirdparty/hunchentoot/conditions.lisp 2010-02-26 11:39:21 UTC (rev 4517) +++ trunk/thirdparty/hunchentoot/conditions.lisp 2010-03-07 09:16:10 UTC (rev 4518) @@ -90,15 +90,55 @@ "Used to signal an error if an operation named NAME is not implemented." (error 'operation-not-implemented :operation name)) +(defun kill-all-debugging-threads () + "Used for destroy all debugging threads" + (with-lock-held (*debugging-threads-lock*) + (dolist (thread *debugging-threads*) + (when (ignore-errors + (bt:destroy-thread thread) + t) + (setf *debugging-threads* + (remove thread *debugging-threads*)))))) + +(defun debug-mode-on () + "Used to enable debug mode" + (setf *catch-errors-p* nil)) + +(defun debug-mode-off (&optional (kill-debuging-threads t)) + "Used to turn off debug mode" + (setf *catch-errors-p* t) + (when kill-debuging-threads + (kill-all-debugging-threads))) + +(defun after-close-swank-connection (connection) + "Turns off debug mode and destroy debugging threads after closing the connection with the swank-server" + (declare (ignore connection)) + (debug-mode-off t)) + +(when (find-package :swank) + (ignore-errors + (eval `(,(find-symbol (string '#:add-hook) :swank) + ,(find-symbol (string '#:*connection-closed-hook*) :swank) + 'after-close-swank-connection)))) + (defgeneric maybe-invoke-debugger (condition) (:documentation "This generic function is called whenever a condition CONDITION is signaled in Hunchentoot. You might want to specialize it on specific condition classes for debugging purposes.") (:method (condition) - "The default method invokes the debugger with CONDITION if + "The default method invokes the debugger with CONDITION if *CATCH-ERRORS-P* is NIL." - (unless *catch-errors-p* - (invoke-debugger condition)))) + (unless (or *catch-errors-p* + (< *max-debugging-threads* + (length *debugging-threads*))) + (let ((thread (bt:current-thread))) + (with-lock-held (*debugging-threads-lock*) + (push thread *debugging-threads*)) + (unwind-protect + (invoke-debugger condition) + (with-lock-held (*debugging-threads-lock*) + (setf *debugging-threads* + (remove thread *debugging-threads*)))))))) (defmacro with-debugger (&body body) "Executes BODY and invokes the debugger if an error is signaled and Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2010-02-26 11:39:21 UTC (rev 4517) +++ trunk/thirdparty/hunchentoot/packages.lisp 2010-03-07 09:16:10 UTC (rev 4518) @@ -62,6 +62,7 @@ "*LOG-LISP-BACKTRACES-P*" "*LOG-LISP-ERRORS-P*" "*LOG-LISP-WARNINGS-P*" + "*MAX-DEBUGGING-THREADS*" "*MESSAGE-LOG-PATHNAME*" "*METHODS-FOR-POST-PARAMETERS*" "*REPLY*" @@ -264,5 +265,7 @@ "URL-DECODE" "URL-ENCODE" "USER-AGENT" - "WITHIN-REQUEST-P")) + "WITHIN-REQUEST-P" + "DEBUG-MODE-ON" + "DEBUG-MODE-OFF")) Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2010-02-26 11:39:21 UTC (rev 4517) +++ trunk/thirdparty/hunchentoot/specials.lisp 2010-03-07 09:16:10 UTC (rev 4518) @@ -236,6 +236,16 @@ "Whether Hunchentoot should catch and log errors \(or rather invoke the debugger).") +(defparameter *max-debugging-threads* 5 + "Maximum number of simultaneous active calls invoke-debuger") + +(defvar *debugging-threads* nil + "List debugged threads") + +(defvar *debugging-threads-lock* (make-lock "debugging threads lock") + "A global lock to prevent two threads from modifying *debugging-threads* at +the same time") + (defvar-unbound *acceptor* "The current ACCEPTOR object while in the context of a request.")

1 0