/examples/service-provider/handlers.lisp

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