PageRenderTime 127ms CodeModel.GetById 61ms app.highlight 37ms RepoModel.GetById 23ms app.codeStats 0ms

/src/core/consumer.lisp

http://github.com/skypher/cl-oauth
Lisp | 327 lines | 301 code | 22 blank | 4 comment | 2 complexity | 49bc5fbfb852d140e1ae1555829ba1f1 MD5 | raw file
  1(in-package :oauth)
  2
  3(defun uri-with-additional-query-part (uri query-part)
  4  "Given a URI string or PURI uri, adds the string QUERY-PART to the end of the URI.  If
  5it has query params already they are added onto it."
  6  (let* ((puri (puri:uri uri))
  7	 (existing-query-part (puri:uri-query puri)))
  8    (setf (puri:uri-query puri)
  9	  (if (and existing-query-part query-part)
 10	      (concatenate 'string existing-query-part "&" query-part)
 11	      (or existing-query-part query-part)))
 12    (puri:render-uri puri nil)))
 13
 14(defun build-auth-string (parameters)
 15  (format nil "OAuth ~{~A=~S~^, ~}"
 16          (alexandria:flatten (mapcar
 17                                (lambda (x y) (list x y))
 18                                (mapcar (compose #'url-encode #'car) parameters)
 19                                (mapcar (compose #'url-encode #'cdr) parameters)))))
 20
 21(defun http-request
 22    (uri &key (auth-location :header) (method :get) auth-parameters parameters additional-headers drakma-args)
 23  (apply #'drakma:http-request
 24         uri
 25         :method method
 26         :parameters (if (eq auth-location :parameters)
 27                         (append parameters auth-parameters)
 28                         parameters)
 29         :additional-headers (if (eq auth-location :header)
 30                                 (cons `("Authorization" . ,(build-auth-string auth-parameters))
 31                                       additional-headers)
 32                                 additional-headers)
 33         drakma-args))
 34
 35;;; SBCL 1.1.6 on OS X does not generate proper random values with (random most-positive-fixnum).
 36(defun generate-nonce (&optional (size 30))
 37  (with-open-file (in "/dev/urandom" :direction :input :element-type '(unsigned-byte 8))
 38    (with-output-to-string (out)
 39      (loop :repeat size
 40         :do (write (read-byte in) :stream out :pretty nil :base 36)))))
 41
 42(defun generate-auth-parameters
 43    (consumer signature-method timestamp version &optional token)
 44  (let ((parameters `(("oauth_consumer_key" . ,(token-key consumer))
 45                      ("oauth_signature_method" . ,(string signature-method))
 46                      ("oauth_timestamp" . ,(princ-to-string timestamp))
 47                      #+unix ("oauth_nonce" . ,(generate-nonce))
 48                      #-unix ("oauth_nonce" . ,(princ-to-string
 49                                                (random most-positive-fixnum)))
 50                      ("oauth_version" . ,(princ-to-string version)))))
 51    (if token
 52        (cons `("oauth_token" . ,(url-decode (token-key token))) parameters)
 53        parameters)))
 54
 55(defun obtain-request-token (uri consumer-token
 56                             &key (version :1.0) user-parameters drakma-args
 57                                  (timestamp (get-unix-time))
 58                                  (auth-location :header)
 59                                  (request-method :post)
 60                                  callback-uri
 61                                  additional-headers
 62                                  (signature-method :hmac-sha1)
 63                                  (include-user-parameters-in-signature-p t))
 64  "Additional parameters will be stored in the USER-DATA slot of the token."
 65  ;; TODO: support 1.0a too
 66  (let* ((callback-uri (or callback-uri "oob"))
 67         (auth-parameters (cons `("oauth_callback" . ,callback-uri)
 68                                (generate-auth-parameters consumer-token
 69                                                          signature-method
 70                                                          timestamp
 71                                                          version)))
 72         (sbs (signature-base-string :uri uri :request-method request-method
 73                                     :parameters (sort-parameters (copy-alist (if include-user-parameters-in-signature-p
 74                                                                                  (append user-parameters auth-parameters)
 75                                                                                  auth-parameters)))))
 76         (key (hmac-key (token-secret consumer-token)))
 77         (signature (encode-signature (hmac-sha1 sbs key) nil))
 78         (signed-parameters (cons `("oauth_signature" . ,signature) auth-parameters)))
 79    (multiple-value-bind (body status)
 80        (http-request uri
 81                      :method request-method
 82                      :auth-location auth-location
 83                      :auth-parameters signed-parameters
 84                      :parameters user-parameters
 85                      :additional-headers additional-headers
 86                      :drakma-args drakma-args)
 87      (if (eql status 200)
 88          (let* ((response (query-string->alist (typecase body
 89                                                  (string body)
 90                                                  (t (map 'string #'code-char body)))))
 91                 (key (cdr (assoc "oauth_token" response :test #'equal)))
 92                 (secret (cdr (assoc "oauth_token_secret" response :test #'equal)))
 93                 (user-data (set-difference response '("oauth_token" "oauth_token_secret")
 94                                            :test (lambda (e1 e2)
 95                                                    (equal (car e1) e2)))))
 96            (assert key)
 97            (assert secret)
 98            (make-request-token :consumer consumer-token :key key :secret secret ;; TODO url-decode
 99                                :callback-uri (puri:uri callback-uri) :user-data user-data))
100          (error "Server returned status ~D: ~A" status body))))) 
101
102
103(defun make-authorization-uri (uri request-token &key callback-uri user-parameters)
104  "Return the service provider's authorization URI. Use the resulting PURI
105for a redirect. [6.2.1] in 1.0." ; TODO 1.0a section number
106  ;; TODO: does 1.0 support oob callbacks?
107  (when (and request-token (request-token-authorized-p request-token))
108    (error "Request token ~A already authorized" request-token))
109  (let* ((parameters (append user-parameters
110                             (when request-token
111                               (list (cons "oauth_token" (token-key request-token))))
112                             (when callback-uri
113                               (list (cons "oauth_callback" callback-uri)))))
114         (puri (puri:copy-uri (puri:parse-uri uri))))
115    (setf (puri:uri-query puri)
116          (if (puri:uri-query puri)
117              (concatenate 'string
118                           (puri:uri-query puri)
119                           (alist->query-string parameters))
120              (alist->query-string parameters :include-leading-ampersand nil)))
121    puri))
122
123
124(defun authorize-request-token-from-request (request-token-lookup-fn)
125  "Authorize a request token. Must be running in request context.
126
127REQUEST-TOKEN-LOOKUP-FN will be called with the request token key
128and must return a valid unauthorized request token or NIL.
129
130Returns the authorized token or NIL if the token couldn't be found."
131  (let* ((parameters (get-parameters))
132         (token-key (cdr (assoc "oauth_token" parameters :test #'equal)))
133         (verification-code (cdr (assoc "oauth_verifier" parameters :test #'equal))))
134    (unless token-key
135      (error "No token key passed"))
136    (let ((token (funcall request-token-lookup-fn token-key))
137          (user-parameters (remove-oauth-parameters parameters)))
138      (cond
139        (token
140         (authorize-request-token token)
141         (setf (request-token-verification-code token) verification-code)
142         (setf (token-user-data token) user-parameters)
143         token)
144        (t
145         (error "Cannot find request token with key ~A ~
146                (never requested or already authorized)" token-key))))))
147
148
149(defun authorize-request-token (request-token)
150  "Authorize a request token explicitly.  Returns the authorized token."
151  ;; TODO test
152  (setf (request-token-authorized-p request-token) t)
153  request-token)
154
155(defun obtain-access-token (uri request-or-access-token &key
156                            (consumer-token (token-consumer request-or-access-token))
157                            (request-method :post)
158                            (auth-location :header)
159                            (version :1.0)
160                            (timestamp (get-unix-time))
161                            xauth-username xauth-password
162                            drakma-args
163			    (signature-method :hmac-sha1))
164  "Additional parameters will be stored in the USER-DATA slot of the
165token. POST is recommended as request method. [6.3.1]" ; TODO 1.0a section number
166  (let ((refresh-p (typep request-or-access-token 'access-token)))
167    (when (and request-or-access-token
168               (not refresh-p))
169      (assert (request-token-authorized-p request-or-access-token)))
170    (let* ((parameters (append
171                        (generate-auth-parameters consumer-token
172                                                  signature-method
173                                                  timestamp
174                                                  version
175                                                  request-or-access-token)
176                        (cond
177                          (refresh-p
178                           `(("oauth_session_handle" . ,(access-token-session-handle
179                                                         request-or-access-token))))
180                          ((null request-or-access-token)
181                           `(("x_auth_mode" . "client_auth")
182                             ("x_auth_username" . ,xauth-username)
183                             ("x_auth_password" . ,xauth-password)))
184                          (t
185                           (awhen (request-token-verification-code request-or-access-token)
186                             `(("oauth_verifier" . ,it)))))))
187           (sbs (signature-base-string :uri uri :request-method request-method
188                                       :parameters (sort-parameters (copy-alist parameters))))
189           (key (hmac-key (token-secret consumer-token)
190                          (when request-or-access-token
191                            (url-decode (token-secret request-or-access-token)))))
192           (signature (encode-signature (hmac-sha1 sbs key) nil))
193           (signed-parameters (cons `("oauth_signature" . ,signature) parameters)))
194      (multiple-value-bind (body status)
195          (http-request uri
196                        :method request-method
197                        :auth-location auth-location
198                        :auth-parameters signed-parameters
199                        :drakma-args drakma-args)
200        (if (eql status 200)
201            (let ((response (query-string->alist (if (stringp body)
202                                                     body
203                                                     (babel:octets-to-string body)))))
204              (flet ((field (name)
205                       (cdr (assoc name response :test #'equal))))
206                (let ((key (field "oauth_token"))
207                      (secret (field "oauth_token_secret"))
208                      (session-handle (field "oauth_session_handle"))
209                      (expires (awhen (field "oauth_expires_in")
210                                 (parse-integer it)))
211                      (authorization-expires (awhen (field "oauth_authorization_expires_in")
212                                               (parse-integer it)))
213                      (user-data (remove-oauth-parameters response)))
214                  (assert key)
215                  (assert secret)
216                  (make-access-token :consumer consumer-token
217                                     :key (url-decode key)
218                                     :secret (url-decode secret)
219                                     :session-handle session-handle
220                                     :expires (awhen expires
221                                                (+ (get-universal-time) it))
222                                     :authorization-expires (awhen authorization-expires
223                                                              (+ (get-universal-time) it))
224                                     :origin-uri uri
225                                     :user-data user-data))))
226            (error "Couldn't obtain access token: server returned status ~D" status))))))
227
228(defun refresh-access-token (access-token)
229  (obtain-access-token (access-token-origin-uri access-token) access-token))
230
231(defun maybe-refresh-access-token (access-token &optional on-refresh)
232  (if (access-token-expired-p access-token)
233    (let ((new-token (refresh-access-token access-token)))
234      (when on-refresh
235        (funcall on-refresh new-token))
236      new-token)
237    access-token))
238
239(defun get-problem-report-from-headers (headers)
240  (let ((authenticate-header (drakma:header-value :www-authenticate headers)))
241    (when (and authenticate-header (>= (length authenticate-header) 5))
242      (let ((type (subseq authenticate-header 0 5)))
243        (when (and (equalp type "OAuth") 
244		   (> (length authenticate-header) 5))
245          (let ((parameters (mapcar (lambda (token)
246                                      (destructuring-bind (name value)
247                                          (split-sequence #\= token)
248                                        (cons name (string-trim '(#\") value))))
249                                    (drakma:split-tokens
250                                      (subseq authenticate-header 6)))))
251            parameters))))))
252
253(defun get-problem-report (headers body)
254  (declare (ignore body)) ; TODO
255  (let ((from-headers (get-problem-report-from-headers headers)))
256    from-headers))
257
258(defun access-protected-resource (uri access-token
259                                  &rest kwargs
260                                  &key
261                                    (consumer-token (token-consumer access-token))
262                                    on-refresh
263                                    (timestamp (get-unix-time))
264                                    user-parameters
265                                    additional-headers
266                                    (version :1.0)
267                                    drakma-args
268                                    (auth-location :header)
269                                    (request-method :get)
270                                    (signature-method :hmac-sha1)
271                                    (include-user-parameters-in-signature-p t))
272  "Access the protected resource at URI using ACCESS-TOKEN.
273
274If the token contains OAuth Session information it will be checked for
275validity before the request is made. Should the server notify us that
276it has prematurely expired the token will be refresh as well and the
277request sent again using the new token. ON-REFRESH will be called
278whenever the access token is renewed."
279  (setf access-token (maybe-refresh-access-token access-token on-refresh))
280  (multiple-value-bind (normalized-uri query-string-parameters) (normalize-uri uri)
281    (let* ((auth-parameters (generate-auth-parameters consumer-token
282                                                      signature-method
283                                                      timestamp
284                                                      version
285                                                      access-token))
286           (sbs (signature-base-string :uri normalized-uri
287                                       :request-method request-method
288                                       :parameters (sort-parameters (copy-alist (if include-user-parameters-in-signature-p
289                                                                                    (append query-string-parameters user-parameters auth-parameters)
290                                                                                    auth-parameters)))))
291           (key (hmac-key (token-secret consumer-token) (token-secret access-token)))
292           (signature (encode-signature (hmac-sha1 sbs key) nil))
293           (signed-parameters (cons `("oauth_signature" . ,signature) auth-parameters)))
294      (when (and (eql request-method :post)
295                 user-parameters)
296        (assert (and (not (getf drakma-args :content-type))
297                     (not (getf drakma-args :content)))
298                () "User parameters and content/content-type in drakma arguments cannot be combined")
299        (setf drakma-args (list* :content-type "application/x-www-form-urlencoded"
300                                 :content (alist->query-string user-parameters
301                                                               :url-encode t
302                                                               :include-leading-ampersand nil)
303                                 drakma-args)))
304      (multiple-value-bind (body status headers)
305          (http-request uri
306                        :method request-method
307                        :auth-location auth-location
308                        :auth-parameters signed-parameters
309                        :parameters user-parameters
310                        :additional-headers additional-headers
311                        :drakma-args drakma-args)
312        (if (eql status 200)
313          (values body status nil nil headers)
314          (let* ((problem-report (get-problem-report headers body))
315                 (problem-hint (cdr (assoc "oauth_problem" problem-report :test #'equalp)))
316                 (problem-advice (cdr (assoc "oauth_problem_advice" problem-report :test #'equalp))))
317            (cond
318              ((and (eql status 401)
319                    (equalp problem-hint "token_expired"))
320               (format t "INFO: refreshing access token~%")
321               (let ((new-token (refresh-access-token access-token)))
322                 (when on-refresh
323                   (funcall on-refresh new-token))
324                 (apply #'access-protected-resource uri new-token kwargs)))
325              (t
326               (values body status problem-hint problem-advice headers)))))))))
327