/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

  1. (asdf:oos 'asdf:load-op 'cl-who)
  2. (in-package :oauth)
  3. ;;; TODO honor webapp uri prefix for weblocks applications.
  4. (defvar *handlers* (make-hash-table :test #'eq))
  5. (defun list-handlers ()
  6. (loop for name being the hash-keys of *handlers*
  7. collect name))
  8. (defvar *debug-on-error* nil)
  9. (defmacro define-handler ((name &key (prefix "/") (http-error-handler #'default-error-handler)) &body body)
  10. "Remove dispatchers associated with the symbol NAME from the dispatch
  11. table, then add a newly created prefix dispatcher to the dispatch table.
  12. The URI prefix is built from NAME by lowercasing its symbol name
  13. and prepending PREFIX.
  14. NAME is defined as a global function using the scheme NAME-HANDLER
  15. to enable easy tracing."
  16. (let* ((handler-name (intern (concatenate 'string (symbol-name name) "-HANDLER")))
  17. (uri-prefix (concatenate 'string prefix (string-downcase (symbol-name name)))))
  18. (with-unique-names (old-dispatcher dispatcher)
  19. (multiple-value-bind (body declarations) (alexandria:parse-body body)
  20. `(let ((,old-dispatcher (gethash ',name *handlers*))
  21. (,dispatcher (create-prefix-dispatcher ,uri-prefix ',handler-name)))
  22. (defun ,handler-name ()
  23. ,@declarations
  24. (handler-bind ((http-error ,http-error-handler)
  25. (error (lambda (c)
  26. (if *debug-on-error*
  27. (invoke-debugger c)
  28. (format t "error: ~A~%" c)))))
  29. ,@body))
  30. (setf *dispatch-table* (cons ,dispatcher (remove ,old-dispatcher *dispatch-table*))
  31. (gethash ',name *handlers*) ,dispatcher))))))
  32. (define-handler (register-consumer)
  33. "Register a new consumer."
  34. (cl-who:escape-string (princ-to-string (register-token (make-consumer-token)))))
  35. (define-handler (get-request-token)
  36. "Hand out request tokens."
  37. (let ((request-token (validate-request-token-request)))
  38. (request-token-response request-token)))
  39. (define-handler (get-user-authorization)
  40. "Let the user authorize the access token. [6.2.1]."
  41. (protocol-assert (eq (request-method) :get)) ; [6.2.1]
  42. (let ((request-token (get-supplied-request-token)))
  43. (when t ; XXX obtain user permission here
  44. (setf (request-token-authorized-p request-token) t)
  45. ;; now notify the Consumer that the request token has been authorized.
  46. (let ((callback-uri (request-token-callback-uri request-token)))
  47. (cond
  48. ((eq *protocol-version* :1.0)
  49. ;; callback uri is optional in 1.0; you might want to employ
  50. ;; some other means to construct it.
  51. (hunchentoot:abort-request-handler "Authorization complete."))
  52. (t
  53. (protocol-assert callback-uri)
  54. (hunchentoot:redirect (princ-to-string (finalize-callback-uri request-token)))))))
  55. ;; only reached when authorization failed
  56. ;; NOTE: optionally notify the Consumer if the user refused authorization.
  57. ))
  58. (define-handler (get-access-token)
  59. "Get an access token from a previously issued and authorized request token."
  60. (let ((access-token (validate-access-token-request)))
  61. (princ-to-string access-token)))
  62. (define-handler (protected-resource)
  63. (validate-access-token)
  64. "All your base are belong to us.")
  65. ;; TODO: automatically define a handler that shows a page documenting
  66. ;; the location of the other handlers. See section 4.2.