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

[BKNR Commits]

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

Add beginnings of a Paypal payment module

U   trunk/projects/quickhoney/src/packages.lisp
A   trunk/projects/quickhoney/src/paypal.lisp
U   trunk/projects/quickhoney/src/quickhoney.asd

Modified: trunk/projects/quickhoney/src/packages.lisp
===================================================================
--- trunk/projects/quickhoney/src/packages.lisp	2008-07-26 12:19:43 UTC (rev 3647)
+++ trunk/projects/quickhoney/src/packages.lisp	2008-07-26 22:06:02 UTC (rev 3648)
@@ -52,3 +52,6 @@
 	:quickhoney.config)
   (:shadowing-import-from :cl-interpol #:quote-meta-chars)
   (:export #:client-selectbox))
+
+(defpackage :paypal
+  (:use :cl))
\ No newline at end of file

Added: trunk/projects/quickhoney/src/paypal.lisp
===================================================================
--- trunk/projects/quickhoney/src/paypal.lisp	                        (rev 0)
+++ trunk/projects/quickhoney/src/paypal.lisp	2008-07-26 22:06:02 UTC (rev 3648)
@@ -0,0 +1,77 @@
+(in-package :paypal)
+
+(defparameter *paypal-url* "https://api-3t.sandbox.paypal.com/nvp"
+  "NVP URL of the Paypal server")
+(defparameter *paypal-user* "sdk-three_api1.sdk.com"
+  "Username to use to authenticate at the Paypal server")
+(defparameter *paypal-password* "QFZCWN5HZM8VBG7Q"
+  "Password to use to authenticate at the Paypal server")
+(defparameter *paypal-signature* "A-IzJhZZjhg29XQ2qnhapuwxIDzyAZQ92FRP5dqBzVesOkzbdUONzmOU"
+  "Signature to use to authenticate at the Paypal server")
+
+(define-condition request-error (error)
+  ((response :initarg :response)))
+
+(define-condition http-request-error (error)
+  ((http-status :initarg :http-status)
+   (response-string :initarg :response-string)))
+
+(defun decode-response (response)
+  "Decode a paypal response string, which is URL encoded and follow
+  list encoding rules.  Returns the parameters as a plist."
+  (let ((hash (make-hash-table)))
+    (dolist (entry (cl-ppcre:split "&" response))
+      (destructuring-bind (parameter-string value) (cl-ppcre:split "=" entry :limit 2)
+        (multiple-value-bind (match registers) (cl-ppcre:scan-to-strings "^L_(.*?)([0-9]+)$" parameter-string)
+          (if match
+              (let* ((parameter (intern (aref registers 0) :keyword))
+                     (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))))))
+    (loop for key being the hash-keys of hash
+         collect key
+         collect (gethash key hash))))
+
+(defun request (method &rest args &key &allow-other-keys)
+  "Perform a request to the Paypal NVP API.  METHOD is the method to
+  use, additional keyword arguments are passed as parameters to the
+  API.  Returns "
+  (multiple-value-bind (response-string http-status)
+      (drakma:http-request *paypal-url*
+                           :method :post
+                           :parameters (append (list (cons "METHOD" method)
+                                                     (cons "VERSION" "52.0")
+                                                     (cons "USER" *paypal-user*)
+                                                     (cons "PWD" *paypal-password*)
+                                                     (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))))))
+    (unless (= 200 http-status)
+      (error 'http-request-error :http-status http-status :response-string response-string))
+    (let ((response (decode-response response-string)))
+      (unless (string-equal "Success" (getf response :ack))
+        (error 'request-error :response response))
+      response)))
+
+(defun test-express-checkout ()
+  (let* ((amt "50.00")
+         (currencycode "EUR")
+         (returnurl "http://test.createrainforest.org/return-paypal")
+         (cancelurl "http://test.createrainforest.org/cancel-paypal")
+         (token (getf (request "SetExpressCheckout"
+                              :amt amt
+                              :currencycode currencycode
+                              :returnurl returnurl
+                              :cancelurl cancelurl
+                              :paymentaction "Sale")
+                     :token)))
+    (format *trace-output* "url: https://www.sandbox.paypal.com/webscr?cmd=_express-checkout&token=~A~
+                                 &AMT=~A&CURRENCYCODE=~A&RETURNURL=~A&CANCELURL=~A"
+            (hunchentoot:url-encode token)
+            amt currencycode
+            (hunchentoot:url-encode returnurl)
+            (hunchentoot:url-encode cancelurl))))
\ No newline at end of file

Modified: trunk/projects/quickhoney/src/quickhoney.asd
===================================================================
--- trunk/projects/quickhoney/src/quickhoney.asd	2008-07-26 12:19:43 UTC (rev 3647)
+++ trunk/projects/quickhoney/src/quickhoney.asd	2008-07-26 22:06:02 UTC (rev 3648)
@@ -20,6 +20,7 @@
 	       :cl-ppcre
 	       :cxml
 	       :cl-mime
+               :drakma
 	       :bknr.web
 	       :bknr.datastore
 	       :bknr.modules