Author: hhubner Date: 2006-10-14 03:51:44 -0400 (Sat, 14 Oct 2006) New Revision: 1989 Added: branches/xml-class-rework/projects/bos/payment-website/images/statistics/ branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp Removed: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp branches/xml-class-rework/projects/bos/statistics/ branches/xml-class-rework/projects/bos/statistics/Makefile branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp Log: XML statistics generation and batch SVG rendering. Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -387,3 +387,6 @@ (make-contract sponsor (random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30))) :paidp t)))) + + + \ No newline at end of file Property changes on: branches/xml-class-rework/projects/bos/payment-website/images/statistics ___________________________________________________________________ Name: svn:ignore + * Property changes on: branches/xml-class-rework/projects/bos/statistics ___________________________________________________________________ Name: svn:ignore - contracts-by-week.xml *.svg + contracts-by-week.xsl contracts-by-week.xml *.svg Modified: branches/xml-class-rework/projects/bos/statistics/Makefile =================================================================== --- branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 07:51:44 UTC (rev 1989) @@ -1,7 +1,8 @@ BASE_URL = http://192.168.254.132:8080/reports-xml YEAR = 2005 -LOGIN = +LOGIN = +OUTPUT_DIR = ../payment-website/images/statistics GRAPHICS = contracts-by-week.svg @@ -18,5 +19,5 @@ .xsl.svg: xsltproc -o $*.xml $*.xsl '$(BASE_URL)/$*/$(YEAR)$(LOGIN)' - xsltproc -o $*-$(YEAR).svg buildSVGLineChart.xsl $*.xml + xsltproc -o $(OUTPUT_DIR)/$*-$(YEAR).svg buildSVGLineChart.xsl $*.xml rm $*.xml \ No newline at end of file Modified: branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 07:51:44 UTC (rev 1989) @@ -21,7 +21,7 @@ <xsl:variable name="minx"> <xsl:value-of select="minx"/> </xsl:variable> - <svg width="1200" height="1200" onload="getSVGDoc(evt)" onzoom="ZoomControl()"> + <svg width="800" height="600" onload="getSVGDoc(evt)" onzoom="ZoomControl()"> <defs> <g id="star" transform="scale(0.21)"> <polyline points="48,16,16,96,96,48,0,48,80,96"> Modified: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl 2006-10-14 07:51:44 UTC (rev 1989) @@ -17,17 +17,26 @@ <set title="Contracts" marker-type="triangle" color="green"> <xsl:for-each select="week"> <measure> - <xvalue><xsl:value-of select="substring(@key, 6)"/></xvalue> + <xvalue><xsl:value-of select="@week-first-yday"/></xvalue> <yvalue><xsl:value-of select="@contracts"/></yvalue> </measure> </xsl:for-each> </set> </sets> <minx>1</minx> - <maxx>52</maxx> + <maxx>365</maxx> <miny>0</miny> <maxy><xsl:value-of select="$max_contracts"/></maxy> <title>Contracts by week for year <xsl:value-of select="$year"/></title> + <xvalues> + <xsl:for-each select="month"> + <xvalue> + <value><xsl:value-of select="@start-yday"/></value> + <label><xsl:value-of select="@name"/></label> + <gridline>true</gridline> + </xvalue> + </xsl:for-each> + </xvalues> <yvalues> <loop:for name="i" from="20" to="$max_contracts" step="20"> <yvalue> Deleted: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl 2006-10-14 07:51:44 UTC (rev 1989) @@ -1,49 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<!-- - - File generated by translating loops into recursive template calls. - XSLT Loop Compiler, Version 1.0 - GPL (c) O. Becker - - --> -<xsl:stylesheet xmlns:loop="http://informatik.hu-berlin.de/loop" xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> - <xsl:output method="xml"/> - - <xsl:template match="/response"> - <xsl:variable name="year"> - <xsl:value-of select="substring(/response/week[1]/@key, 1, 4)"/> - </xsl:variable> - <xsl:variable name="max_contracts"> - <xsl:for-each select="week"> - <xsl:sort select="@contracts" data-type="number" order="descending"/> - <xsl:if test="position()=1"><xsl:value-of select="@contracts"/></xsl:if> - </xsl:for-each> - </xsl:variable> - <graphData> - <sets> - <set title="Contracts" marker-type="triangle" color="green"> - <xsl:for-each select="week"> - <measure> - <xvalue><xsl:value-of select="substring(@key, 6)"/></xvalue> - <yvalue><xsl:value-of select="@contracts"/></yvalue> - </measure> - </xsl:for-each> - </set> - </sets> - <minx>1</minx> - <maxx>52</maxx> - <miny>0</miny> - <maxy><xsl:value-of select="$max_contracts"/></maxy> - <title>Contracts by week for year <xsl:value-of select="$year"/></title> - <yvalues> - <xsl:call-template name="for-loop-id4477040"><xsl:with-param name="i" select="20"/><xsl:with-param name="toid4477040" select="$max_contracts"/><xsl:with-param name="stepid4477040" select="20"/><xsl:with-param name="year" select="$year"/><xsl:with-param name="max_contracts" select="$max_contracts"/></xsl:call-template> - </yvalues> - </graphData> - </xsl:template> -<xsl:template name="for-loop-id4477040"><xsl:param name="i"/><xsl:param name="toid4477040"/><xsl:param name="stepid4477040"/><xsl:param name="year"/><xsl:param name="max_contracts"/> - <yvalue> - <value><xsl:value-of select="$i"/></value> - <label><xsl:value-of select="$i"/></label> - <gridline>true</gridline> - </yvalue> - <xsl:if test="$i+$stepid4477040 <= $toid4477040"><xsl:call-template name="for-loop-id4477040"><xsl:with-param name="i" select="$i + $stepid4477040"/><xsl:with-param name="toid4477040" select="$toid4477040"/><xsl:with-param name="stepid4477040" select="$stepid4477040"/><xsl:with-param name="year" select="$year"/><xsl:with-param name="max_contracts" select="$max_contracts"/></xsl:call-template></xsl:if></xsl:template></xsl:stylesheet> Modified: branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -2,6 +2,7 @@ (defpackage :worldpay-test (:use :cl + :date-calc :extensions :cl-user :cl-interpol @@ -11,7 +12,7 @@ :xhtml-generator :cxml :puri - :mime + #+(or) :mime :acl-compat.socket :acl-compat.mp :bknr.web Added: branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -0,0 +1,99 @@ + +(in-package :worldpay-test) + +(enable-interpol-syntax) + +(defclass reports-xml-handler (prefix-handler) + ()) + +(defvar *report-generators* (make-hash-table)) +(defvar *contracts-to-process*) +(defvar *year*) +(defvar *month-names* '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + +(defmacro defreport (name arguments &body body) + `(setf (gethash ',name *report-generators*) (lambda (,@arguments) ,@body))) + +(defun contract-year (contract) + (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + year)) + +(defmethod handle ((handler reports-xml-handler) req) + (with-xml-response req + (destructuring-bind (name *year* &rest arguments) (decoded-handler-path handler req) + (setf *year* (parse-integer *year*)) + (let ((*contracts-to-process* (sort (remove-if (lambda (contract) + (or (not (contract-paidp contract)) + (and *year* + (not (eql *year* (contract-year contract)))))) + (class-instances 'contract)) + #'< :key #'contract-date))) + (setf name (intern (string-upcase name) :worldpay-test)) + (apply (or (gethash name *report-generators*) + (error "invalid report name ~A" name)) + arguments))))) + + +(defreport all-contracts () + (dolist (contract *contracts-to-process*) + (with-element "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)))))) + +(defun week-of-contract (contract) + "Return Week key (YYYY-WW) for given contract." + (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + (multiple-value-bind (week-no week-year) + (week-of-year year month date) + (when (and (> week-no 50) + (eql month 1)) + ;; If the date falls within the last week of the previous + ;; year, we put it into the first week of the current year in + ;; order to simplify graphics drawing. + (setf week-no 1)) + (format nil "~A-~A" week-year week-no)))) + +(defun week-first-yday (contract) + "Return the day-of year of the first day of the contract's date" + (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + (max 0 (- (day-of-year year month date) (day-of-week year month date))))) + +(defreport contracts-by-week () + (dolist (week-contracts (group-on *contracts-to-process* + :test #'equal + :key #'week-of-contract)) + (with-element "week" + (attribute "week-first-yday" (week-first-yday (first (cdr week-contracts)))) + (attribute "key" (first week-contracts)) + (attribute "contracts" (length (cdr week-contracts))) + (attribute "sqms" (apply #'+ (mapcar (lambda (contract) (length (contract-m2s contract))) (cdr week-contracts)))))) + (dotimes (month 12) + (with-element "month" + (attribute "number" month) + (attribute "name" (nth month *month-names*)) + (attribute "start-yday" (1- (day-of-year *year* (1+ month) 1)))))) + +(defreport contract-sizes () + (let ((contract-sizes (make-hash-table :test #'equal)) + (thresholds '(1 10 30 100 10000000))) + (dolist (threshold thresholds) + (setf (gethash threshold contract-sizes) 0)) + (dolist (contract *contracts-to-process*) + (dolist (threshold thresholds) + (when (<= (length (contract-m2s contract)) threshold) + (incf (gethash threshold contract-sizes)) + (return)))) + (dolist (threshold thresholds) + (with-element "contracts" + (attribute "threshold" threshold) + (attribute "count" (gethash threshold contract-sizes)))))) + +(defreport contract-countries () + (dolist (country-contracts (sort (group-on *contracts-to-process* + :test #'equal + :key (lambda (contract) (sponsor-country (contract-sponsor contract)))) + #'> :key (lambda (entry) (length (cdr entry))))) + (with-element "country" + (attribute "code" (car country-contracts)) + (attribute "contracts" (length (cdr country-contracts)))))) \ No newline at end of file Added: branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -0,0 +1,21 @@ +(in-package :worldpay-test) + +(defmethod rss-item-channel ((item news-item)) + "news") + +(defmethod rss-item-published ((item news-item)) + (format t "Language: ~A~%" (current-website-language)) + t) + +(defmethod rss-item-title ((item news-item)) + (news-item-title item (current-website-language))) + +(defmethod rss-item-description ((item news-item)) + (news-item-text item (current-website-language))) + +(defmethod rss-item-link ((item news-item)) + (format nil "http://createrainforest.org/~A/news-extern/~A" (current-website-language) (store-object-id item))) + +(defmethod rss-item-guid ((item news-item)) + (format nil "http://createrainforest.org/~A/news-extern/~A" (current-website-language) (store-object-id item))) + Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-10-14 07:51:44 UTC (rev 1989) @@ -28,6 +28,7 @@ (:file "poi-handlers" :depends-on ("web-utils")) (:file "boi-handlers" :depends-on ("web-utils")) (:file "contract-handlers" :depends-on ("web-utils")) + (:file "reports-xml-handler" :depends-on ("boi-handlers")) (:file "sponsor-handlers" :depends-on ("web-utils")) (:file "news-handlers" :depends-on ("web-utils")) (:file "allocation-area-handlers" :depends-on ("web-utils")) Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -185,6 +185,7 @@ ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) ("/contract" contract-handler) + ("/reports-xml" reports-xml-handler) ("/complete-transfer" complete-transfer-handler) ("/edit-news" edit-news-handler) ("/make-poi" make-poi-handler)