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