[bknr-cvs] hans changed trunk/projects/quickhoney/src/pa

[BKNR Commits]

Revision: 3664
Author: hans
URL: http://bknr.net/trac/changeset/3664

Further testing with PayPal EC API

U   trunk/projects/quickhoney/src/packages.lisp
U   trunk/projects/quickhoney/src/paypal-test.lisp
U   trunk/projects/quickhoney/src/paypal.lisp

Modified: trunk/projects/quickhoney/src/packages.lisp
===================================================================
--- trunk/projects/quickhoney/src/packages.lisp	2008-07-28 14:39:46 UTC (rev 3663)
+++ trunk/projects/quickhoney/src/packages.lisp	2008-07-28 14:44:00 UTC (rev 3664)
@@ -56,7 +56,11 @@
 (defpackage :paypal
   (:use :cl)
   (:export #:request
-           #:make-express-checkout-url))
+           #:make-express-checkout-url
+           #:paypal-error
+           #:request-error
+           #:http-request-error
+           #:response-error))
 
 (defpackage :paypal-test
   (:use :cl))
\ No newline at end of file

Modified: trunk/projects/quickhoney/src/paypal-test.lisp
===================================================================
--- trunk/projects/quickhoney/src/paypal-test.lisp	2008-07-28 14:39:46 UTC (rev 3663)
+++ trunk/projects/quickhoney/src/paypal-test.lisp	2008-07-28 14:44:00 UTC (rev 3664)
@@ -1,5 +1,4 @@
 (in-package :paypal-test)
-
 (defgeneric dispatch-request (request-type request)
   (:documentation "dispatch incoming http request"))
 
@@ -18,14 +17,25 @@
 
 (define-handler :checkout (request)
   (tbnl:redirect (paypal:make-express-checkout-url 10 :eur
-                                                   :returnurl (format nil "http://~A:~A/return-paypal" response-host response-port)
-                                                   :cancelurl (format nil "http://~A:~A/cancel-paypal" response-host response-port))))
+                                                   (format nil "http://~A:~A/return-paypal" *response-host* *response-port*)
+                                                   (format nil "http://~A:~A/cancel-paypal" *response-host* *response-port*))))
 
 (define-handler :stop (request)
   (throw 'stop-server nil))
 
 (define-handler :return-paypal (request)
-  "Returned from paypal")
+  (with-output-to-string (*standard-output*)
+    (let* ((token (tbnl:get-parameter "token"))
+           (response (paypal:request "GetExpressCheckoutDetails" :token token))
+           (payerid (getf response :payerid))
+           (amt (getf response :amt))
+           (currencycode (getf response :currencycode)))
+      (print (paypal:request "DoExpressCheckoutPayment"
+                             :token token
+                             :payerid payerid
+                             :amt amt
+                             :currencycode currencycode
+                             :paymentaction "Sale")))))
 
 (define-handler :cancel-paypal (request)
   "Cancelled")

Modified: trunk/projects/quickhoney/src/paypal.lisp
===================================================================
--- trunk/projects/quickhoney/src/paypal.lisp	2008-07-28 14:39:46 UTC (rev 3663)
+++ trunk/projects/quickhoney/src/paypal.lisp	2008-07-28 14:44:00 UTC (rev 3664)
@@ -2,20 +2,27 @@
 
 (defparameter *paypal-url* "https://api-3t.sandbox.paypal.com/nvp"
   "NVP URL of the Paypal server")
-(defparameter *paypal-user* "sdk-three_api1.sdk.com"
+(defparameter *paypal-user* "hans.huebner_api1.gmail.com"
   "Username to use to authenticate at the Paypal server")
-(defparameter *paypal-password* "QFZCWN5HZM8VBG7Q"
+(defparameter *paypal-password* "62QFQPLEMM6P3M25"
   "Password to use to authenticate at the Paypal server")
-(defparameter *paypal-signature* "A-IzJhZZjhg29XQ2qnhapuwxIDzyAZQ92FRP5dqBzVesOkzbdUONzmOU"
+(defparameter *paypal-signature* "AFcWxV21C7fd0v3bYYYRCpSSRl31Ac-RAs1SuG20a1IoPMJ0WKbx0fdG"
   "Signature to use to authenticate at the Paypal server")
 
-(define-condition request-error (error)
+(define-condition paypal-error (error)
+  ())
+
+(define-condition request-error (paypal-error)
   ((response :initarg :response)))
 
-(define-condition http-request-error (error)
+(define-condition http-request-error (paypal-error)
   ((http-status :initarg :http-status)
    (response-string :initarg :response-string)))
 
+(define-condition response-error (paypal-error)
+  ((response :initarg :response)
+   (invalid-parameter :initarg :invalid-parameter)))
+
 (defun decode-response (response)
   "Decode a paypal response string, which is URL encoded and follow
   list encoding rules.  Returns the parameters as a plist."
@@ -28,9 +35,9 @@
                      (index (parse-integer (aref registers 1)))
                      (previous-value (gethash parameter hash)))
                 (unless (= (length previous-value) index)
-                  (error "unexpected list value ~A in Paypal response ~S" parameter-string response))
-                (setf (gethash parameter hash) (append previous-value (list (hunchentoot:url-decode value)))))
-              (setf (gethash (intern parameter-string :keyword) hash) (hunchentoot:url-decode value))))))
+                  (error 'response-error :invalid-parameter parameter-string :response response))
+                (setf (gethash parameter hash) (append previous-value (list (hunchentoot:url-decode value :utf-8)))))
+              (setf (gethash (intern parameter-string :keyword) hash) (hunchentoot:url-decode value :utf-8))))))
     (loop for key being the hash-keys of hash
          collect key
          collect (gethash key hash))))
@@ -49,7 +56,9 @@
                                                      (cons "SIGNATURE" *paypal-signature*))
                                                (loop for (param value) on args by #'cddr
                                                   collect (cons (symbol-name param)
-                                                                (if (stringp value) value (princ-to-string value))))))
+                                                                (if (stringp value)
+                                                                    value
+                                                                    (princ-to-string value))))))
     (unless (= 200 http-status)
       (error 'http-request-error :http-status http-status :response-string response-string))
     (let ((response (decode-response response-string)))