Update test case for latest hunchentoot.

Add garbage collection for old unfinished transactions. limit the number of unfinished transaction per ip
standin000 · Dec 20, 2009 · 7f96523 · 7f96523
1 parent 12acc78
commit 7f96523
Show file tree

Hide file tree

Showing 4 changed files with 61 additions and 27 deletions.
diff --git a/cl-paypal-test.lisp b/cl-paypal-test.lisp
@@ -1,7 +1,8 @@
-(setf hunchentoot:*show-lisp-errors-p* t
-      hunchentoot:*show-lisp-backtraces-p* t)
 
-(require :cl-paypal)
+(eval-when (:compile-toplevel)
+ (require :cl-paypal))
+
+(setf hunchentoot:*show-lisp-errors-p* t)
 
 (defgeneric dispatch-request (request-type request)
   (:documentation "dispatch incoming http request"))
@@ -14,46 +15,47 @@
   (let ((request-type-var (gensym)))
     `(defmethod dispatch-request ((,request-type-var (eql ,type)) ,request)
        (declare (ignore ,request-type-var))
-       (lambda () ,@body))))
+                                        ; (lambda () ,@body))))
+       ,@body)))
 
 (define-handler :checkout (request)
   (hunchentoot:redirect 
-   (cl-paypal:make-express-checkout-url 10)
-   ))
+   (cl-paypal:make-express-checkout-url 1 (hunchentoot:remote-addr request))))
 
 (define-handler :stop (request)
   (throw 'stop-server nil))
 
 
 (define-handler :return-paypal (request)
   (cl-paypal:get-and-do-express-checkout
-   (lambda () (print "Paypal Express Checkout OK"))
-   (lambda () (print "Paypal Express Checkout NG"))
-   )
-  )
+   (lambda (&key amount currencycode token result) 
+     (format t "Paypal Express Checkout OK~%Amount is ~A~%
+              Currencycod is ~A~%Token is~A~%Result is ~A"
+             amount currencycode token result))
+   (lambda () (print "Paypal Express Checkout NG"))))
 
 (define-handler :cancel-paypal (request)
   "Cancelled")
 
 (defun dispatch-request% (request)
-  (let* ((type-string (cl-ppcre:scan-to-strings "[^/]+" (hunchentoot:script-name request)))
-         (request-type (and type-string (find-symbol (string-upcase type-string) :keyword))))
+  (let* ((type-string 
+          (cl-ppcre:scan-to-strings "[^/]+" (hunchentoot:script-name request)))
+         (request-type 
+          (and type-string (find-symbol (string-upcase type-string) :keyword))))
     (dispatch-request request-type request)))
 
 ;; send-user "wangyi_1228286489_per@yeah.net" 
 ;; send-user's password "228286734"
 
-(defun test-express-checkout (&key (response-port 8080) (response-host "127.0.0.1"))
+(defun test-express-checkout (&key (response-port 8080) (response-host "192.168.1.24"))
   (cl-paypal:init "https://api-3t.sandbox.paypal.com/nvp" 
 		"hans.huebner_api1.gmail.com"
 		"62QFQPLEMM6P3M25"
 		"AFcWxV21C7fd0v3bYYYRCpSSRl31Ac-RAs1SuG20a1IoPMJ0WKbx0fdG"
 		(format nil "http://~A:~A/return-paypal" response-host response-port)
 		(format nil "http://~A:~A/cancel-paypal" response-host response-port)
 		:useraction "commit"
-		:currencycode "EUR"
-		)
+		:currencycode "EUR")
   (catch 'stop-server
-    (hunchentoot:start-server :port response-port
-                       :dispatch-table 
-		       (list #'dispatch-request%))))
+    (hunchentoot:start (make-instance 'hunchentoot:acceptor :port response-port
+                                      :REQUEST-DISPATCHER  #'dispatch-request%))))
diff --git a/cl-paypal.lisp b/cl-paypal.lisp
@@ -70,13 +70,29 @@
 ;; also limit number of unfinished txns per ip to avoid
 ;; attackers filling up our heap.
 (defvar *active-transactions* (make-hash-table :test #'equalp))
+(defvar *transaction-ips* nil)
 
-(defun register-transaction (token amount currencycode)
+(defun register-transaction (token amount currencycode ip)
   (when (gethash token *active-transactions*)
     (error "Attempt to register already existing transaction with token ~S." token))
-  (setf (gethash token *active-transactions*) (cons amount currencycode)))
+     ;; Garbage collection
+  (if (>= (hash-table-count *active-transactions*) *paypal-max-active-transactions*)
+      (with-hash-table-iterator (next-entry *active-transactions*)
+        (loop (multiple-value-bind (more key value) (next-entry)
+             (unless more (return nil))
+             (when (> (- (get-universal-time) (fourth value))
+                    (* 60 *paypal-max-token-live-period*))
+                 (unregister-transaction key))))))
+  (if (>= (count ip *transaction-ips* :test #'equal) *paypal-max-transaction-per-ip*)
+      (error "Attempt to make more than ~A transactions per IP" *paypal-max-transaction-per-ip*)
+      (push ip *transaction-ips*))
+  (setf (gethash token *active-transactions*) 
+        (list amount currencycode ip (get-universal-time))))
 
 (defun unregister-transaction (token)
+  (setf *transaction-ips*
+   (remove (third (gethash token *active-transactions*)) 
+           *transaction-ips* :test #'equal :count 1))
   (remhash token *active-transactions*))
 
 (defun find-transaction (token &optional (errorp t))
@@ -86,6 +102,7 @@
     result))
 
 (defun make-express-checkout-url (amount 
+                                  ip
 				  &key
 				  (return-url *paypal-return-url*)
 				  (cancel-url *paypal-cancel-url*)
@@ -103,7 +120,7 @@
                                :cancelurl cancel-url
                                :paymentaction "Sale")
                       :token)))
-    (register-transaction token amt currencycode)
+    (register-transaction token amt currencycode ip)
     (format nil "https://~A/webscr?cmd=_express-checkout&token=~A&useraction=~A"
             hostname
 	    (hunchentoot:url-encode token)
@@ -114,7 +131,8 @@
     (let* ((token (hunchentoot:get-parameter "token"))
            (txn (find-transaction token nil)))
       (if txn
-        (destructuring-bind (amount . currencycode) txn
+        (destructuring-bind (amount currencycode ip time) txn
+          (declare (ignore ip time))
           (let* ((response (request "GetExpressCheckoutDetails" :token token))
                  (payerid (getf response :payerid))
                  (result (request "DoExpressCheckoutPayment"
@@ -127,7 +145,8 @@
                  (success-p (string-equal "Success" (getf result :ack))))
             (when success-p
               (unregister-transaction token))
-            (funcall (if success-p success failure)
-              :amount amount :currencycode currencycode :token token :result result)))
+            (if success-p 
+                (funcall success :amount amount :currencycode currencycode :token token :result result) 
+                (funcall failure))))
         (funcall failure)))))
 
diff --git a/config.lisp b/config.lisp
@@ -22,6 +22,17 @@
 (defvar *paypal-currencycode* nil
   "currency for paypal express checkout")
 
+(defvar *paypal-max-active-transactions* 20
+  "invoke garbage collection when it is reached.")
+
+(defvar *paypal-max-token-live-period* 10
+  "the max value of live period for token in minute")
+
+(defvar *paypal-max-transaction-per-ip* 5
+  "max number of simultaneous transaction per ip")
+
+
+
 (defun init (paypal-api-url paypal-user paypal-password paypal-signature
 	     paypal-return-url paypal-cancel-url &key (useraction "continue") (currencycode "USD"))
   (setf *paypal-api-url* paypal-api-url
@@ -31,6 +42,5 @@
 	*paypal-return-url* paypal-return-url
 	*paypal-cancel-url* paypal-cancel-url
 	*paypal-useraction* useraction
-	*paypal-currencycode* currencycode
-	))
+	*paypal-currencycode* currencycode))
 
diff --git a/package.lisp b/package.lisp
@@ -11,5 +11,8 @@
    #:request-error
    #:http-request-error
    #:response-error
-   #:transaction-already-confirmed-error))
+   #:transaction-already-confirmed-error
+   #:*paypal-max-active-transactions*
+   #:*paypal-max-token-live-period*
+   #:*paypal-max-transaction-per-ip*))