/examples/service-provider/handlers.lisp
http://github.com/skypher/cl-oauth · Lisp · 82 lines · 58 code · 16 blank · 8 comment · 1 complexity · c778947a4f646ae2629fdd1f5a50e95d MD5 · raw file
- (asdf:oos 'asdf:load-op 'cl-who)
- (in-package :oauth)
- ;;; TODO honor webapp uri prefix for weblocks applications.
- (defvar *handlers* (make-hash-table :test #'eq))
- (defun list-handlers ()
- (loop for name being the hash-keys of *handlers*
- collect name))
- (defvar *debug-on-error* nil)
- (defmacro define-handler ((name &key (prefix "/") (http-error-handler #'default-error-handler)) &body body)
- "Remove dispatchers associated with the symbol NAME from the dispatch
- table, then add a newly created prefix dispatcher to the dispatch table.
- The URI prefix is built from NAME by lowercasing its symbol name
- and prepending PREFIX.
-
- NAME is defined as a global function using the scheme NAME-HANDLER
- to enable easy tracing."
- (let* ((handler-name (intern (concatenate 'string (symbol-name name) "-HANDLER")))
- (uri-prefix (concatenate 'string prefix (string-downcase (symbol-name name)))))
- (with-unique-names (old-dispatcher dispatcher)
- (multiple-value-bind (body declarations) (alexandria:parse-body body)
- `(let ((,old-dispatcher (gethash ',name *handlers*))
- (,dispatcher (create-prefix-dispatcher ,uri-prefix ',handler-name)))
- (defun ,handler-name ()
- ,@declarations
- (handler-bind ((http-error ,http-error-handler)
- (error (lambda (c)
- (if *debug-on-error*
- (invoke-debugger c)
- (format t "error: ~A~%" c)))))
- ,@body))
- (setf *dispatch-table* (cons ,dispatcher (remove ,old-dispatcher *dispatch-table*))
- (gethash ',name *handlers*) ,dispatcher))))))
- (define-handler (register-consumer)
- "Register a new consumer."
- (cl-who:escape-string (princ-to-string (register-token (make-consumer-token)))))
- (define-handler (get-request-token)
- "Hand out request tokens."
- (let ((request-token (validate-request-token-request)))
- (request-token-response request-token)))
- (define-handler (get-user-authorization)
- "Let the user authorize the access token. [6.2.1]."
- (protocol-assert (eq (request-method) :get)) ; [6.2.1]
- (let ((request-token (get-supplied-request-token)))
- (when t ; XXX obtain user permission here
- (setf (request-token-authorized-p request-token) t)
- ;; now notify the Consumer that the request token has been authorized.
- (let ((callback-uri (request-token-callback-uri request-token)))
- (cond
- ((eq *protocol-version* :1.0)
- ;; callback uri is optional in 1.0; you might want to employ
- ;; some other means to construct it.
- (hunchentoot:abort-request-handler "Authorization complete."))
- (t
- (protocol-assert callback-uri)
- (hunchentoot:redirect (princ-to-string (finalize-callback-uri request-token)))))))
- ;; only reached when authorization failed
- ;; NOTE: optionally notify the Consumer if the user refused authorization.
- ))
- (define-handler (get-access-token)
- "Get an access token from a previously issued and authorized request token."
- (let ((access-token (validate-access-token-request)))
- (princ-to-string access-token)))
- (define-handler (protected-resource)
- (validate-access-token)
- "All your base are belong to us.")
- ;; TODO: automatically define a handler that shows a page documenting
- ;; the location of the other handlers. See section 4.2.