├── LICENSE ├── README ├── cl-oauth.asd ├── dev ├── config.git └── push.sh ├── doc └── STUB ├── examples ├── consumer │ ├── google.lisp │ ├── twitter.lisp │ └── yahoo.lisp └── service-provider │ ├── handlers.lisp │ └── server.lisp ├── src ├── core │ ├── consumer.lisp │ ├── crypto.lisp │ ├── error-handling.lisp │ ├── parameters.lisp │ ├── request-adapter.lisp │ ├── service-provider.lisp │ ├── signature.lisp │ └── tokens.lisp ├── package.lisp └── util │ ├── misc.lisp │ ├── query-string.lisp │ └── uri.lisp └── test ├── core ├── parameters.lisp ├── request-adapter.lisp ├── service-provider.lisp ├── signature.lisp └── tokens.lisp └── package.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | Preamble to the Gnu Lesser General Public License 2 | 3 | Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 4 | 5 | The concept of the GNU Lesser General Public License version 2.1 6 | ("LGPL") has been adopted to govern the use and distribution of 7 | above-mentioned application. However, the LGPL uses terminology that 8 | is more appropriate for a program written in C than one written in 9 | Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if 10 | certain clarifications are made. This document details those 11 | clarifications. Accordingly, the license for the open-source Lisp 12 | applications consists of this document plus the LGPL. Wherever there 13 | is a conflict between this document and the LGPL, this document takes 14 | precedence over the LGPL. 15 | 16 | A "Library" in Lisp is a collection of Lisp functions, data and 17 | foreign modules. The form of the Library can be Lisp source code (for 18 | processing by an interpreter) or object code (usually the result of 19 | compilation of source code or built with some other 20 | mechanisms). Foreign modules are object code in a form that can be 21 | linked into a Lisp executable. When we speak of functions we do so in 22 | the most general way to include, in addition, methods and unnamed 23 | functions. Lisp "data" is also a general term that includes the data 24 | structures resulting from defining Lisp classes. A Lisp application 25 | may include the same set of Lisp objects as does a Library, but this 26 | does not mean that the application is necessarily a "work based on the 27 | Library" it contains. 28 | 29 | The Library consists of everything in the distribution file set before 30 | any modifications are made to the files. If any of the functions or 31 | classes in the Library are redefined in other files, then those 32 | redefinitions ARE considered a work based on the Library. If 33 | additional methods are added to generic functions in the Library, 34 | those additional methods are NOT considered a work based on the 35 | Library. If Library classes are subclassed, these subclasses are NOT 36 | considered a work based on the Library. If the Library is modified to 37 | explicitly call other functions that are neither part of Lisp itself 38 | nor an available add-on module to Lisp, then the functions called by 39 | the modified Library ARE considered a work based on the Library. The 40 | goal is to ensure that the Library will compile and run without 41 | getting undefined function errors. 42 | 43 | It is permitted to add proprietary source code to the Library, but it 44 | must be done in a way such that the Library will still run without 45 | that proprietary code present. Section 5 of the LGPL distinguishes 46 | between the case of a library being dynamically linked at runtime and 47 | one being statically linked at build time. Section 5 of the LGPL 48 | states that the former results in an executable that is a "work that 49 | uses the Library." Section 5 of the LGPL states that the latter 50 | results in one that is a "derivative of the Library", which is 51 | therefore covered by the LGPL. Since Lisp only offers one choice, 52 | which is to link the Library into an executable at build time, we 53 | declare that, for the purpose applying the LGPL to the Library, an 54 | executable that results from linking a "work that uses the Library" 55 | with the Library is considered a "work that uses the Library" and is 56 | therefore NOT covered by the LGPL. 57 | 58 | Because of this declaration, section 6 of LGPL is not applicable to 59 | the Library. However, in connection with each distribution of this 60 | executable, you must also deliver, in accordance with the terms and 61 | conditions of the LGPL, the source code of Library (or your derivative 62 | thereof) that is incorporated into this executable. 63 | 64 | GNU LESSER GENERAL PUBLIC LICENSE 65 | Version 3, 29 June 2007 66 | 67 | Copyright (C) 2007 Free Software Foundation, Inc. 68 | Everyone is permitted to copy and distribute verbatim copies 69 | of this license document, but changing it is not allowed. 70 | 71 | 72 | This version of the GNU Lesser General Public License incorporates 73 | the terms and conditions of version 3 of the GNU General Public 74 | License, supplemented by the additional permissions listed below. 75 | 76 | 0. Additional Definitions. 77 | 78 | As used herein, "this License" refers to version 3 of the GNU Lesser 79 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 80 | General Public License. 81 | 82 | "The Library" refers to a covered work governed by this License, 83 | other than an Application or a Combined Work as defined below. 84 | 85 | An "Application" is any work that makes use of an interface provided 86 | by the Library, but which is not otherwise based on the Library. 87 | Defining a subclass of a class defined by the Library is deemed a mode 88 | of using an interface provided by the Library. 89 | 90 | A "Combined Work" is a work produced by combining or linking an 91 | Application with the Library. The particular version of the Library 92 | with which the Combined Work was made is also called the "Linked 93 | Version". 94 | 95 | The "Minimal Corresponding Source" for a Combined Work means the 96 | Corresponding Source for the Combined Work, excluding any source code 97 | for portions of the Combined Work that, considered in isolation, are 98 | based on the Application, and not on the Linked Version. 99 | 100 | The "Corresponding Application Code" for a Combined Work means the 101 | object code and/or source code for the Application, including any data 102 | and utility programs needed for reproducing the Combined Work from the 103 | Application, but excluding the System Libraries of the Combined Work. 104 | 105 | 1. Exception to Section 3 of the GNU GPL. 106 | 107 | You may convey a covered work under sections 3 and 4 of this License 108 | without being bound by section 3 of the GNU GPL. 109 | 110 | 2. Conveying Modified Versions. 111 | 112 | If you modify a copy of the Library, and, in your modifications, a 113 | facility refers to a function or data to be supplied by an Application 114 | that uses the facility (other than as an argument passed when the 115 | facility is invoked), then you may convey a copy of the modified 116 | version: 117 | 118 | a) under this License, provided that you make a good faith effort to 119 | ensure that, in the event an Application does not supply the 120 | function or data, the facility still operates, and performs 121 | whatever part of its purpose remains meaningful, or 122 | 123 | b) under the GNU GPL, with none of the additional permissions of 124 | this License applicable to that copy. 125 | 126 | 3. Object Code Incorporating Material from Library Header Files. 127 | 128 | The object code form of an Application may incorporate material from 129 | a header file that is part of the Library. You may convey such object 130 | code under terms of your choice, provided that, if the incorporated 131 | material is not limited to numerical parameters, data structure 132 | layouts and accessors, or small macros, inline functions and templates 133 | (ten or fewer lines in length), you do both of the following: 134 | 135 | a) Give prominent notice with each copy of the object code that the 136 | Library is used in it and that the Library and its use are 137 | covered by this License. 138 | 139 | b) Accompany the object code with a copy of the GNU GPL and this license 140 | document. 141 | 142 | 4. Combined Works. 143 | 144 | You may convey a Combined Work under terms of your choice that, 145 | taken together, effectively do not restrict modification of the 146 | portions of the Library contained in the Combined Work and reverse 147 | engineering for debugging such modifications, if you also do each of 148 | the following: 149 | 150 | a) Give prominent notice with each copy of the Combined Work that 151 | the Library is used in it and that the Library and its use are 152 | covered by this License. 153 | 154 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 155 | document. 156 | 157 | c) For a Combined Work that displays copyright notices during 158 | execution, include the copyright notice for the Library among 159 | these notices, as well as a reference directing the user to the 160 | copies of the GNU GPL and this license document. 161 | 162 | d) Do one of the following: 163 | 164 | 0) Convey the Minimal Corresponding Source under the terms of this 165 | License, and the Corresponding Application Code in a form 166 | suitable for, and under terms that permit, the user to 167 | recombine or relink the Application with a modified version of 168 | the Linked Version to produce a modified Combined Work, in the 169 | manner specified by section 6 of the GNU GPL for conveying 170 | Corresponding Source. 171 | 172 | 1) Use a suitable shared library mechanism for linking with the 173 | Library. A suitable mechanism is one that (a) uses at run time 174 | a copy of the Library already present on the user's computer 175 | system, and (b) will operate properly with a modified version 176 | of the Library that is interface-compatible with the Linked 177 | Version. 178 | 179 | e) Provide Installation Information, but only if you would otherwise 180 | be required to provide such information under section 6 of the 181 | GNU GPL, and only to the extent that such information is 182 | necessary to install and execute a modified version of the 183 | Combined Work produced by recombining or relinking the 184 | Application with a modified version of the Linked Version. (If 185 | you use option 4d0, the Installation Information must accompany 186 | the Minimal Corresponding Source and Corresponding Application 187 | Code. If you use option 4d1, you must provide the Installation 188 | Information in the manner specified by section 6 of the GNU GPL 189 | for conveying Corresponding Source.) 190 | 191 | 5. Combined Libraries. 192 | 193 | You may place library facilities that are a work based on the 194 | Library side by side in a single library together with other library 195 | facilities that are not Applications and are not covered by this 196 | License, and convey such a combined library under terms of your 197 | choice, if you do both of the following: 198 | 199 | a) Accompany the combined library with a copy of the same work based 200 | on the Library, uncombined with any other library facilities, 201 | conveyed under the terms of this License. 202 | 203 | b) Give prominent notice with the combined library that part of it 204 | is a work based on the Library, and explaining where to find the 205 | accompanying uncombined form of the same work. 206 | 207 | 6. Revised Versions of the GNU Lesser General Public License. 208 | 209 | The Free Software Foundation may publish revised and/or new versions 210 | of the GNU Lesser General Public License from time to time. Such new 211 | versions will be similar in spirit to the present version, but may 212 | differ in detail to address new problems or concerns. 213 | 214 | Each version is given a distinguishing version number. If the 215 | Library as you received it specifies that a certain numbered version 216 | of the GNU Lesser General Public License "or any later version" 217 | applies to it, you have the option of following the terms and 218 | conditions either of that published version or of any later version 219 | published by the Free Software Foundation. If the Library as you 220 | received it does not specify a version number of the GNU Lesser 221 | General Public License, you may choose any version of the GNU Lesser 222 | General Public License ever published by the Free Software Foundation. 223 | 224 | If the Library as you received it specifies that a proxy can decide 225 | whether future versions of the GNU Lesser General Public License shall 226 | apply, that proxy's public statement of acceptance of any version is 227 | permanent authorization for you to choose that version for the 228 | Library. 229 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is cl-oauth, an implementation of the OAuth 1.0a standard 2 | in Common Lisp. 3 | 4 | Spec URI: http://oauth.net/core/1.0a 5 | 6 | Section numbers mentioned in the code and documentation 7 | refer to this document, unless mentioned otherwise. 8 | 9 | Most of the code has passed basic manual and automated tests, 10 | but the SP code hasn't been used in a real-world application 11 | yet. 12 | 13 | 14 | Not supported at this time: 15 | 16 | Service Provider: 17 | 18 | * parameters from Auth header (needs some parsing) [5.4] 19 | in principle a MUST, but as SP you get to decide ;) 20 | 21 | * Nonce checking [9], a SHOULD. 22 | 23 | * Session extension 24 | http://oauth.googlecode.com/svn/spec/ext/session/1.0/drafts/1/spec.html 25 | 26 | * Problem Reporting extension 27 | http://oauth.pbworks.com/ProblemReporting 28 | 29 | Consumer: 30 | 31 | * Auth parameters should be working, but Google rejects them for 32 | some reason. Do more testing and debugging. 33 | 34 | * Revoking tokens as per section 7 of the Session extension 35 | 36 | * Problem Reporting extension: fields in body are ignored. 37 | 38 | Both: 39 | 40 | * crypto signatures different from HMAC-SHA1. It's easy to use 41 | other digests and MACs via Ironclad but RSA needs to have 42 | padding implemented. [9.3] 43 | 44 | * PLAINTEXT signature. Meh. [9.4] 45 | 46 | * POST and Auth requests are hardly tested yet. 47 | 48 | 49 | People who contributed in a substantial way to this library: 50 | 51 | * Leslie P. Polzer : base implementation. 52 | 53 | See also revision log for minor contributions. 54 | 55 | 56 | TODO (apart from spec things not implemented yet): 57 | 58 | * grep the code for TODO and FIXME 59 | 60 | * incorporate test cases from http://wiki.oauth.net/TestCases 61 | 62 | * abstract token storage, can't get far with volatile memory 63 | FETCH-TOKEN/STORE-TOKEN 64 | 65 | * better handling of different protocol versions; in particular 66 | we should support serving both 1.0 and 1.0a clients (and requesting 67 | stuff from 1.0 and 1.0a servers too, of course). 68 | 69 | * compare with the Hammer draft spec and resolve differences 70 | 71 | * always store the URL-decoded key/secret in the request token 72 | 73 | -------------------------------------------------------------------------------- /cl-oauth.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2009 Leslie P. Polzer 2 | ;;; All rights reserved. 3 | ;;; See the file LICENSE for terms of use and distribution. 4 | 5 | (in-package #:cl-user) 6 | 7 | (defpackage :cl-oauth-asd 8 | (:use #:cl #:asdf)) 9 | 10 | (in-package :cl-oauth-asd) 11 | 12 | (defsystem :cl-oauth 13 | :name "CL-OAuth" 14 | :description "Common Lisp OAuth implementation" 15 | :version "3" 16 | :maintainer "Leslie P. Polzer " 17 | :licence "LLGPL" 18 | :components ((:static-file "cl-oauth.asd") 19 | (:module "src" 20 | :components ((:file "package") 21 | (:module "util" 22 | :components ((:file "misc") 23 | (:file "query-string" 24 | :depends-on ("misc")) 25 | (:file "uri" 26 | :depends-on ("query-string"))) 27 | :depends-on ("package")) 28 | (:module "core" 29 | :components ((:file "crypto") 30 | (:file "request-adapter") 31 | (:file "error-handling" 32 | :depends-on ("request-adapter")) 33 | (:file "parameters" 34 | :depends-on ("request-adapter")) 35 | (:file "signature") 36 | (:file "tokens" 37 | :depends-on ("signature")) 38 | (:file "consumer" 39 | :depends-on ("tokens" "parameters" 40 | "error-handling")) 41 | (:file "service-provider" 42 | :depends-on ("tokens" "parameters" 43 | "error-handling"))) 44 | :depends-on ("package" "util"))))) 45 | :depends-on (:ironclad :cl-base64 :babel 46 | :closer-mop 47 | :alexandria :anaphora :f-underscore :split-sequence 48 | :trivial-garbage 49 | :drakma 50 | :puri :hunchentoot) 51 | :in-order-to ((test-op (load-op cl-oauth.tests)))) 52 | 53 | (defmethod operation-done-p ((op test-op) (c (eql (find-system :cl-oauth)))) 54 | (values nil)) 55 | 56 | (defsystem :cl-oauth.tests 57 | :depends-on (:fiveam :cl-oauth) 58 | :pathname "test/" 59 | :components ((:file "package") 60 | (:module "core" 61 | :components ((:file "request-adapter") 62 | (:file "parameters" 63 | :depends-on ("request-adapter")) 64 | (:file "signature" 65 | :depends-on ("request-adapter")) 66 | (:file "tokens") 67 | (:file "service-provider" 68 | :depends-on ("request-adapter"))) 69 | :depends-on ("package")))) 70 | -------------------------------------------------------------------------------- /dev/config.git: -------------------------------------------------------------------------------- 1 | [core] 2 | repositoryformatversion = 0 3 | filemode = true 4 | bare = false 5 | logallrefupdates = true 6 | [remote "gitorious"] 7 | url = git@gitorious.org:cl-oauth/cl-oauth.git 8 | fetch = +refs/heads/*:refs/remotes/origin/* 9 | [remote "github"] 10 | url = git@github.com:skypher/cl-oauth.git 11 | fetch = +refs/heads/*:refs/remotes/github/* 12 | -------------------------------------------------------------------------------- /dev/push.sh: -------------------------------------------------------------------------------- 1 | git push gitorious master 2 | git push github master 3 | -------------------------------------------------------------------------------- /doc/STUB: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skypher/cl-oauth/a7a463c8c2e4726ab0853d5b6623349b6428cb89/doc/STUB -------------------------------------------------------------------------------- /examples/consumer/google.lisp: -------------------------------------------------------------------------------- 1 | 2 | (asdf:oos 'asdf:load-op 'cl-oauth) 3 | (asdf:oos 'asdf:load-op 'hunchentoot) 4 | 5 | (defpackage :cl-oauth.google-consumer 6 | (:use :cl :cl-oauth)) 7 | 8 | (in-package :cl-oauth.google-consumer) 9 | 10 | ;;; insert your credentials and auxiliary information here. 11 | (defparameter *key* "") 12 | (defparameter *secret* "") 13 | (defparameter *callback-uri* "") 14 | (defparameter *callback-port* 8090 15 | "Port to listen on for the callback") 16 | 17 | 18 | ;;; go 19 | (defparameter *get-request-token-endpoint* "https://www.google.com/accounts/OAuthGetRequestToken") 20 | (defparameter *auth-request-token-endpoint* "https://www.google.com/accounts/OAuthAuthorizeToken") 21 | (defparameter *get-access-token-endpoint* "https://www.google.com/accounts/OAuthGetAccessToken") 22 | (defparameter *consumer-token* (make-consumer-token :key *key* :secret *secret*)) 23 | (defparameter *request-token* nil) 24 | (defparameter *access-token* nil) 25 | 26 | (defun get-access-token () 27 | (obtain-access-token *get-access-token-endpoint* *request-token*)) 28 | 29 | ;;; get a request token 30 | (defun get-request-token (scope) 31 | ;; TODO: scope could be a list. 32 | (obtain-request-token 33 | *get-request-token-endpoint* 34 | *consumer-token* 35 | :callback-uri *callback-uri* 36 | :user-parameters `(("scope" . ,scope)))) 37 | 38 | (setf *request-token* (get-request-token "http://www.google.com/calendar/feeds/")) 39 | 40 | (let ((auth-uri (make-authorization-uri *auth-request-token-endpoint* *request-token*))) 41 | (format t "Please authorize the request token at this URI: ~A~%" (puri:uri auth-uri))) 42 | 43 | 44 | ;;; set up callback uri 45 | (defun callback-dispatcher (request) 46 | (declare (ignorable request)) 47 | (unless (cl-ppcre:scan "favicon\.ico$" (hunchentoot:script-name request)) 48 | (lambda (&rest args) 49 | (declare (ignore args)) 50 | (handler-case 51 | (authorize-request-token-from-request 52 | (lambda (rt-key) 53 | (assert *request-token*) 54 | (unless (equal (url-encode rt-key) (token-key *request-token*)) 55 | (warn "Keys differ: ~S / ~S~%" (url-encode rt-key) (token-key *request-token*))) 56 | *request-token*)) 57 | (error (c) 58 | (warn "Couldn't verify request token authorization: ~A" c))) 59 | (when (request-token-authorized-p *request-token*) 60 | (format t "Successfully verified request token with key ~S~%" (token-key *request-token*)) 61 | (setf *access-token* (get-access-token)) 62 | ;; test request: 63 | (let ((result (access-protected-resource 64 | "http://www.google.com/calendar/feeds/default/allcalendars/full?orderby=starttime" 65 | *access-token*))) 66 | (if (stringp result) 67 | result 68 | (babel:octets-to-string result))))))) 69 | 70 | (pushnew 'callback-dispatcher hunchentoot:*dispatch-table*) 71 | 72 | 73 | (defvar *web-server* nil) 74 | 75 | (when *web-server* 76 | (hunchentoot:stop *web-server*) 77 | (setf *web-server* nil)) 78 | 79 | (setf *web-server* (hunchentoot:start (make-instance 'hunchentoot:acceptor :port *callback-port*))) 80 | 81 | -------------------------------------------------------------------------------- /examples/consumer/twitter.lisp: -------------------------------------------------------------------------------- 1 | (asdf:oos 'asdf:load-op 'cl-oauth) 2 | (asdf:oos 'asdf:load-op 'hunchentoot) 3 | 4 | (defpackage :cl-oauth.twitter-consumer 5 | (:use :cl :cl-oauth)) 6 | 7 | (in-package :cl-oauth.twitter-consumer) 8 | 9 | ;;; insert your credentials and auxiliary information here. 10 | (defparameter *key* "") 11 | (defparameter *secret* "") 12 | (defparameter *callback-uri* "") 13 | (defparameter *callback-port* 8090 14 | "Port to listen on for the callback") 15 | 16 | 17 | ;;; go 18 | (defparameter *get-request-token-endpoint* "https://api.twitter.com/oauth/request_token") 19 | (defparameter *auth-request-token-endpoint* "https://api.twitter.com/oauth/authorize") 20 | (defparameter *get-access-token-endpoint* "https://api.twitter.com/oauth/access_token") 21 | (defparameter *consumer-token* (make-consumer-token :key *key* :secret *secret*)) 22 | (defparameter *request-token* nil) 23 | (defparameter *access-token* nil) 24 | 25 | (defun get-access-token () 26 | (obtain-access-token *get-access-token-endpoint* *request-token*)) 27 | 28 | ;;; get a request token 29 | (defun get-request-token () 30 | (obtain-request-token 31 | *get-request-token-endpoint* 32 | *consumer-token* 33 | :callback-uri *callback-uri*)) 34 | 35 | (setf *request-token* (get-request-token)) 36 | 37 | (let ((auth-uri (make-authorization-uri *auth-request-token-endpoint* *request-token*))) 38 | (format t "Please authorize the request token at this URI: ~A~%" (puri:uri auth-uri))) 39 | 40 | 41 | ;;; set up callback uri 42 | (defun callback-dispatcher (request) 43 | (declare (ignorable request)) 44 | (unless (cl-ppcre:scan "favicon\.ico$" (hunchentoot:script-name request)) 45 | (lambda (&rest args) 46 | (declare (ignore args)) 47 | (handler-case 48 | (authorize-request-token-from-request 49 | (lambda (rt-key) 50 | (assert *request-token*) 51 | (unless (equal (url-encode rt-key) (token-key *request-token*)) 52 | (warn "Keys differ: ~S / ~S~%" (url-encode rt-key) (token-key *request-token*))) 53 | *request-token*)) 54 | (error (c) 55 | (warn "Couldn't verify request token authorization: ~A" c))) 56 | (when (request-token-authorized-p *request-token*) 57 | (format t "Successfully verified request token with key ~S~%" (token-key *request-token*)) 58 | (setf *access-token* (get-access-token)) 59 | ;; test request: 60 | (babel:octets-to-string 61 | (access-protected-resource "https://api.twitter.com/1.1/search/tweets.json?q=twitter" 62 | *access-token*)))))) 63 | 64 | (pushnew 'callback-dispatcher hunchentoot:*dispatch-table*) 65 | 66 | 67 | (defvar *web-server* nil) 68 | 69 | (when *web-server* 70 | (hunchentoot:stop *web-server*) 71 | (setf *web-server* nil)) 72 | 73 | (setf *web-server* (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port *callback-port*))) 74 | 75 | -------------------------------------------------------------------------------- /examples/consumer/yahoo.lisp: -------------------------------------------------------------------------------- 1 | 2 | (asdf:oos 'asdf:load-op 'cl-oauth) 3 | (asdf:oos 'asdf:load-op 'hunchentoot) 4 | 5 | (defpackage :cl-oauth.yahoo-consumer 6 | (:use :cl :cl-oauth)) 7 | 8 | (in-package :cl-oauth.yahoo-consumer) 9 | 10 | ;;; insert your credentials and auxiliary information here. 11 | (defparameter *key* "") 12 | (defparameter *secret* "") 13 | (defparameter *callback-uri* "") 14 | ;(defparameter *additional-parameters* '(("AppId" . ""))) 15 | (defparameter *callback-port* 8090 16 | "Port to listen on for the callback") 17 | 18 | 19 | 20 | ;;; go 21 | (defparameter *get-request-token-endpoint* "https://api.login.yahoo.com/oauth/v2/get_request_token") 22 | (defparameter *auth-request-token-endpoint* "https://api.login.yahoo.com/oauth/v2/request_auth") 23 | (defparameter *get-access-token-endpoint* "https://api.login.yahoo.com/oauth/v2/get_token") 24 | (defparameter *consumer-token* (make-consumer-token :key *key* :secret *secret*)) 25 | (defparameter *request-token* nil) 26 | (defparameter *access-token* nil) 27 | 28 | (defun get-access-token () 29 | (obtain-access-token *get-access-token-endpoint* *request-token*)) 30 | 31 | ;;; get a request token 32 | (defun get-request-token () 33 | (obtain-request-token 34 | *get-request-token-endpoint* 35 | *consumer-token* 36 | :callback-uri *callback-uri*)) 37 | 38 | (setf *request-token* (get-request-token)) 39 | 40 | (let ((auth-uri (make-authorization-uri *auth-request-token-endpoint* *request-token*))) 41 | (format t "Please authorize the request token at this URI: ~A~%" (puri:uri auth-uri))) 42 | 43 | 44 | ;;; set up callback uri 45 | (defun callback-dispatcher (request) 46 | (declare (ignorable request)) 47 | (unless (cl-ppcre:scan "favicon\.ico$" (hunchentoot:script-name request)) 48 | (lambda (&rest args) 49 | (declare (ignore args)) 50 | (handler-case 51 | (authorize-request-token-from-request 52 | (lambda (rt-key) 53 | (assert *request-token*) 54 | (unless (equal (url-encode rt-key) (token-key *request-token*)) 55 | (warn "Keys differ: ~S / ~S~%" (url-encode rt-key) (token-key *request-token*))) 56 | *request-token*)) 57 | (error (c) 58 | (warn "Couldn't verify request token authorization: ~A" c))) 59 | (when (request-token-authorized-p *request-token*) 60 | (format t "Successfully verified request token with key ~S~%" (token-key *request-token*)) 61 | (setf *access-token* (get-access-token)) 62 | (let ((reply-body (access-protected-resource 63 | "http://social.yahooapis.com/v1/user/jupitercollision/profile" 64 | *access-token* 65 | ;; Yahoo uses OAuth session so the token might need refresh. 66 | :on-refresh (lambda (new-token) 67 | (setf *access-token* new-token)) ))) 68 | (etypecase reply-body 69 | (string reply-body) 70 | ((vector (unsigned-byte 8)) (babel:octets-to-string reply-body)))))))) 71 | 72 | (pushnew 'callback-dispatcher hunchentoot:*dispatch-table*) 73 | 74 | 75 | (defvar *web-server* nil) 76 | 77 | (when *web-server* 78 | (hunchentoot:stop *web-server*) 79 | (setf *web-server* nil)) 80 | 81 | (setf *web-server* (hunchentoot:start (make-instance 'hunchentoot:acceptor :port *callback-port*))) 82 | 83 | -------------------------------------------------------------------------------- /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 | 83 | -------------------------------------------------------------------------------- /examples/service-provider/server.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (export '(start-server stop-server)) 5 | 6 | (defvar *server* nil) 7 | 8 | (defun start-server (&rest acceptor-args) 9 | (setf oauth:*request-adapter* (oauth:make-hunchentoot-request-adapter)) 10 | (if *server* 11 | (warn "Server already started, doing nothing.") 12 | (hunchentoot:start (apply #'make-instance 'hunchentoot:acceptor acceptor-args)))) 13 | 14 | (defun stop-server () 15 | (when *server* 16 | (hunchentoot:stop *server*))) 17 | 18 | -------------------------------------------------------------------------------- /src/core/consumer.lisp: -------------------------------------------------------------------------------- 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 5 | it 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 105 | for 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 | 127 | REQUEST-TOKEN-LOOKUP-FN will be called with the request token key 128 | and must return a valid unauthorized request token or NIL. 129 | 130 | Returns 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 165 | token. 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 | 274 | If the token contains OAuth Session information it will be checked for 275 | validity before the request is made. Should the server notify us that 276 | it has prematurely expired the token will be refresh as well and the 277 | request sent again using the new token. ON-REFRESH will be called 278 | whenever 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 | 328 | -------------------------------------------------------------------------------- /src/core/crypto.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (defun string-or-octets->octets (x) 5 | (etypecase x 6 | (string (babel:string-to-octets x)) 7 | ((simple-array (unsigned-byte 8)) x))) 8 | 9 | (defun hmac-sha1 (s key) 10 | (let* ((s (string-or-octets->octets s)) 11 | (key (string-or-octets->octets key)) 12 | (hmac (ironclad:make-hmac key 'ironclad:sha1))) 13 | (ironclad:update-hmac hmac s) 14 | (ironclad:hmac-digest hmac))) 15 | 16 | -------------------------------------------------------------------------------- /src/core/error-handling.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | 5 | (define-condition http-error (error) 6 | ((status-code :reader http-error-status-code 7 | :initarg :status-code) 8 | (reason-phrase :reader http-error-reason-phrase 9 | :initarg :reason-phrase))) 10 | 11 | (define-condition bad-request (http-error) 12 | () (:default-initargs :status-code 400 :reason-phrase "Bad Request")) 13 | 14 | (define-condition unauthorized (http-error) 15 | () (:default-initargs :status-code 401 :reason-phrase "Unauthorized")) 16 | 17 | (defun raise-error (type &optional reason-phrase-fmt &rest reason-phrase-args) 18 | (if reason-phrase-fmt 19 | (let ((reason-phrase (apply #'format nil reason-phrase-fmt reason-phrase-args))) 20 | (error type :reason-phrase reason-phrase)) 21 | (error type))) 22 | 23 | (defun default-error-handler (condition) 24 | "Default error handler for conditions of type HTTP-ERROR." 25 | (check-type condition http-error) 26 | (let ((status-code (http-error-status-code condition)) 27 | (reason-phrase (http-error-reason-phrase condition))) 28 | (setf (hunchentoot:return-code*) status-code) 29 | (setf (hunchentoot:content-type*) "text/plain") 30 | (abort-request 31 | (format nil "~D ~A" status-code reason-phrase)))) 32 | 33 | (defmacro protocol-assert (&body body) 34 | `(unless (progn ,@body) 35 | (raise-error 'bad-request "Failed protocol assertion"))) 36 | 37 | -------------------------------------------------------------------------------- /src/core/parameters.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (export '(parameter sort-parameters normalized-parameters)) 5 | 6 | ;; the cache allows us to call NORMALIZED-PARAMETERS repeatedly 7 | ;; without excessive processing penalty. 8 | (defvar *parameters-cache* (tg:make-weak-hash-table :test #'eq :weakness :key) 9 | "Per-request cache for parameters in OAuth requests.") 10 | 11 | (defvar *signature-cache* (tg:make-weak-hash-table :test #'eq :weakness :key) 12 | ;; this is much more simple than maintaining multiple caches 13 | ;; for different parameter list flavors. 14 | "Per-request cache for signatures in OAuth requests.") 15 | 16 | (defun sort-parameters (parameters) 17 | "Sort PARAMETERS according to the OAuth spec. This is a destructive operation." 18 | (assert (not (assoc "oauth_signature" parameters :test #'equal))) 19 | (sort parameters #'string< :key (lambda (x) 20 | "Sort by key and value." 21 | (concatenate 'string (princ-to-string (car x)) 22 | (princ-to-string (cdr x)))))) 23 | 24 | (defun normalized-parameters (&key remove-duplicates-p) 25 | "Collect request parameters and remove those excluded by the standard. See 9.1.1. 26 | Note: REMOVE-DUPLICATES-P has no effect right now." 27 | (declare (ignorable remove-duplicates-p)) 28 | (or (gethash (request) *parameters-cache*) 29 | (let ((parameters (append (remove "realm" (auth-parameters) 30 | :key #'car :test #'equalp) ; TODO: http auth header parameters 31 | (post-parameters) 32 | (get-parameters)))) 33 | ;; save the signature, we might need it later 34 | (setf (gethash (request) *signature-cache*) 35 | (cdr (assoc "oauth_signature" parameters :test #'equal))) 36 | (let* ((parameters (remove "oauth_signature" parameters 37 | :key #'car :test #'equal)) 38 | (sorted-parameters (sort-parameters parameters))) 39 | (setf (gethash (request) *parameters-cache*) sorted-parameters) 40 | sorted-parameters 41 | #+(or) ; disabled for now because it makes caching slightly more complex. 42 | ; we just don't support elimination of duplicates right now. 43 | (if remove-duplicates-p 44 | (remove-duplicates sorted-parameters :key #'car :test #'string-equal :from-end t) 45 | sorted-parameters))))) 46 | 47 | (defun parameter (name &key (test #'equal)) 48 | "Note: OAuth parameters are case-sensitive per section 5. 49 | The case of user-supplied parameters is not restricted." 50 | (cdr (assoc name (normalized-parameters) :test test))) 51 | 52 | (defun oauth-parameter-p (parameter) 53 | "Return T if PARAMETER starts with \"oauth_\". PARAMETER is a 54 | string denoting the parameter name." 55 | (equal 56 | (subseq (car (ensure-list parameter)) 0 (min 6 (length parameter))) 57 | "oauth_" )) 58 | 59 | (defun remove-oauth-parameters (parameters) 60 | (remove-if #'oauth-parameter-p parameters :key #'car)) 61 | 62 | -------------------------------------------------------------------------------- /src/core/request-adapter.lisp: -------------------------------------------------------------------------------- 1 | (in-package :oauth) 2 | 3 | ;;; server-specific request abstraction layer 4 | ;;; 5 | ;;; defaults to Hunchentoot 6 | 7 | (export '(request-adapter 8 | make-request-adapter 9 | *request-adapter* 10 | make-hunchentoot-request-adapter 11 | init-default-request-adapter 12 | *request* 13 | request 14 | request-method 15 | request-uri 16 | abort-request 17 | auth-parameters 18 | post-parameters 19 | get-parameters)) ; TODO move to package.lisp 20 | 21 | 22 | #.`(defstruct request-adapter ; TODO: make this a standard-class, too 23 | "An adapter for server-specific parts of OAuth. 24 | The return value of REQUEST-OBJECT-FN must be comparable with EQ." 25 | ,@(loop for slotname in '(request-object-fn 26 | request-method-fn 27 | request-uri-fn 28 | abort-request-fn 29 | auth-parameters-fn 30 | post-parameters-fn 31 | get-parameters-fn) 32 | collect `(,slotname nil :type (or function symbol null)))) 33 | 34 | (defun make-hunchentoot-request-adapter () 35 | (make-request-adapter :request-object-fn (lambda () hunchentoot:*request*) 36 | :request-uri-fn (lambda (request) 37 | (let* ((http-host (split-sequence #\: (hunchentoot:host request))) 38 | (hostname (first http-host)) 39 | (port (second http-host))) 40 | (make-instance 'puri:uri 41 | :scheme (etypecase hunchentoot:*acceptor* 42 | (hunchentoot:ssl-acceptor :https) 43 | (hunchentoot:acceptor :http)) 44 | :host hostname 45 | :port port 46 | :path (hunchentoot:script-name* request)))) 47 | :request-method-fn 'hunchentoot:request-method* 48 | :abort-request-fn 'hunchentoot:abort-request-handler 49 | :auth-parameters-fn (lambda (request) (declare (ignore request)) nil) ; TODO 50 | :post-parameters-fn 'hunchentoot:post-parameters* 51 | :get-parameters-fn 'hunchentoot:get-parameters*)) 52 | 53 | 54 | (defvar *request-adapter* nil 55 | "Set this variable to an instance of REQUEST-ADAPTER tailored to 56 | your web server.") 57 | 58 | (defun init-default-request-adapter () 59 | (setf *request-adapter* (make-hunchentoot-request-adapter))) 60 | 61 | (init-default-request-adapter) 62 | 63 | (defvar *request* nil 64 | "User-supplied request override. Only if you know what you're doing.") 65 | 66 | (defun request () 67 | (or *request* ; allow request object override 68 | (funcall (request-adapter-request-object-fn *request-adapter*)))) 69 | 70 | (defun request-method (&optional (request (request))) 71 | (let* ((result (funcall (request-adapter-request-method-fn *request-adapter*) request)) 72 | (normalized-result (etypecase result 73 | (keyword result) 74 | (symbol (intern (symbol-name result) :keyword)) 75 | (string (intern result :keyword))))) 76 | (assert (member normalized-result '(:get :post :put :delete :head :trace :options :connect))) 77 | result)) 78 | 79 | (defun request-uri (&optional (request (request))) 80 | "Return the request uri including protocol, host, port 81 | and path. Other parts like the query string are optional and 82 | will be ignored. The result type is (or string puri:uri)." 83 | ;; TODO: cache this 84 | (let ((result (funcall (request-adapter-request-uri-fn *request-adapter*) request))) 85 | (check-type result (or string puri:uri)) 86 | result)) 87 | 88 | ;; TODO: assertions/type checks for the following functions 89 | 90 | (defun auth-parameters (&optional (request (request))) 91 | (funcall (request-adapter-auth-parameters-fn *request-adapter*) request)) 92 | 93 | (defun post-parameters (&optional (request (request))) 94 | (funcall (request-adapter-post-parameters-fn *request-adapter*) request)) 95 | 96 | (defun get-parameters (&optional (request (request))) 97 | (funcall (request-adapter-get-parameters-fn *request-adapter*) request)) 98 | 99 | 100 | (defun abort-request (result) 101 | "Return the string RESULT immediately from the request handler." 102 | (funcall (request-adapter-abort-request-fn *request-adapter*) result)) 103 | 104 | -------------------------------------------------------------------------------- /src/core/service-provider.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (defvar *protocol-version* :1.0) 5 | 6 | ;;;; Service provider infrastructure 7 | 8 | ;;;; TODO: need to store application-specific data somewhere. 9 | 10 | 11 | (defun finalize-callback-uri (request-token) 12 | "Prepares the callback URI of REQUEST-TOKEN for 13 | redirection." 14 | (let ((uri (request-token-callback-uri request-token))) 15 | (setf (puri:uri-query uri) 16 | (concatenate 'string (or (puri:uri-query uri) "") 17 | (if (puri:uri-query uri) "&" "") 18 | "oauth_token=" 19 | (url-encode (token-key request-token)) 20 | "&oauth_verifier=" 21 | (url-encode (request-token-verification-code request-token)))) 22 | uri)) 23 | 24 | 25 | ;;; Consumer management 26 | (defvar *registered-consumers* (make-hash-table :test #'equalp)) 27 | 28 | (defmethod register-token ((token consumer-token)) 29 | (setf (gethash (token-key token) *registered-consumers*) token) 30 | token) 31 | 32 | (defmethod unregister-token ((token consumer-token)) 33 | (remhash (token-key token) *registered-consumers*)) 34 | 35 | (defun get-consumer-token (key) 36 | (gethash key *registered-consumers*)) 37 | 38 | (defmacro ignore-oauth-errors (&body body) 39 | `(handler-case (progn ,@body) 40 | (http-error (condition) (values nil condition)))) 41 | 42 | ;;; signature checking 43 | (defun check-signature () 44 | (unless (equalp (parameter "oauth_signature_method") "HMAC-SHA1") 45 | (raise-error 'bad-request "Signature method not passed or different from HMAC-SHA1")) 46 | (let* ((supplied-signature (gethash (request) *signature-cache*)) 47 | ;; TODO: do not bluntly ignore all errors. Factor out into GET-TOKEN 48 | (consumer-secret (ignore-errors 49 | (token-secret 50 | (get-consumer-token (parameter "oauth_consumer_key"))))) 51 | (token-secret (ignore-errors 52 | (token-secret (or (ignore-oauth-errors (get-supplied-request-token)) 53 | (ignore-oauth-errors (get-supplied-access-token))))))) 54 | (unless supplied-signature 55 | (raise-error 'bad-request "This request is not signed")) 56 | (unless consumer-secret 57 | (raise-error 'unauthorized "Invalid consumer")) 58 | ;; now calculate the signature and check for match 59 | (let* ((signature-base-string (signature-base-string)) 60 | (hmac-key (hmac-key consumer-secret token-secret)) 61 | (signature (hmac-sha1 signature-base-string hmac-key)) 62 | (encoded-signature (encode-signature signature nil))) 63 | (unless (equal encoded-signature supplied-signature) 64 | (format t "calculated: ~S / supplied: ~S~%" encoded-signature supplied-signature) 65 | (raise-error 'unauthorized "Invalid signature"))) 66 | t)) 67 | 68 | 69 | ;;; nonce and timestamp checking 70 | (defun check-nonce-and-timestamp (consumer-token) 71 | ;; TODO: nonce checking 72 | (unless (parameter "oauth_timestamp") 73 | (raise-error 'bad-request "Missing Timestamp")) 74 | (let ((timestamp (ignore-errors (parse-integer (parameter "oauth_timestamp")))) 75 | (nonce (parameter "oauth_nonce"))) 76 | (unless timestamp 77 | (raise-error 'unauthorized "Malformed Timestamp")) 78 | (unless nonce 79 | (raise-error 'bad-request "Missing nonce")) 80 | (unless (>= timestamp (consumer-token-last-timestamp consumer-token)) 81 | (raise-error 'unauthorized "Invalid timestamp")) 82 | t)) 83 | 84 | 85 | ;;; version checking 86 | (defun check-version () 87 | (let ((version (parameter "oauth_version"))) 88 | (unless (member version '("1.0" nil) :test #'equalp) 89 | (raise-error 'bad-request "Not prepared to handle OAuth version other than 1.0" version)) 90 | t)) 91 | 92 | 93 | ;;; verification code checking 94 | (defun check-verification-code () 95 | (unless (equal (parameter "oauth_verifier") 96 | (request-token-verification-code (get-supplied-request-token))) 97 | (raise-error 'unauthorized "Invalid verification code")) 98 | t) 99 | 100 | 101 | ;;; misc 102 | (defun get-supplied-consumer-token () 103 | (let ((consumer-key (parameter "oauth_consumer_key"))) 104 | (unless consumer-key 105 | (raise-error 'bad-request "Consumer key not supplied")) 106 | (let ((consumer-token (get-consumer-token consumer-key))) 107 | (unless consumer-token 108 | (raise-error 'unauthorized "Can't identify Consumer")) 109 | consumer-token))) 110 | 111 | 112 | (defun get-supplied-callback-uri (&key allow-oob-callback-p 113 | (allow-none (eq *protocol-version* :1.0))) 114 | (let ((callback (parameter "oauth_callback"))) 115 | (cond 116 | ((and (not allow-none) (not callback)) 117 | (raise-error 'bad-request "No callback supplied")) 118 | ((and (not allow-oob-callback-p) (equal callback "oob")) 119 | (raise-error 'bad-request "Not prepared for an OOB callback setup!")) 120 | (t 121 | callback)))) 122 | 123 | 124 | ;;; request token management 125 | (defvar *issued-request-tokens* (make-hash-table :test #'equalp)) 126 | 127 | (defmethod register-token ((token request-token)) 128 | ;; TODO: already registered? 129 | (setf (gethash (token-key token) *issued-request-tokens*) token)) 130 | 131 | (defmethod unregister-token ((token request-token)) 132 | (remhash (token-key token) *issued-request-tokens*)) 133 | 134 | (defun invalidate-request-token (request-token) 135 | (remhash (token-key request-token) *issued-request-tokens*)) 136 | 137 | (defun make-response (alist) 138 | "[5.3]" 139 | (alist->query-string 140 | (mapcar (lambda (cons) 141 | (cons (url-encode (car cons)) 142 | (url-encode (cdr cons)))) 143 | alist) 144 | :include-leading-ampersand nil)) 145 | 146 | (defun request-token-response (request-token &rest additional-parameters) 147 | "Respond to a valid request token request. [6.1.2]" 148 | (assert (notany #'oauth-parameter-p additional-parameters)) 149 | (make-response 150 | (append 151 | `(("oauth_token" . ,(token-key request-token)) 152 | ("oauth_token_secret" . ,(token-secret request-token)) 153 | ("oauth_callback_confirmed" . "true")) 154 | additional-parameters))) 155 | 156 | (defun validate-request-token-request (&key (request-token-ctor #'make-request-token) 157 | allow-oob-callback-p) 158 | "Check whether REQUEST is a valid request token request. 159 | 160 | Returns the supplied Consumer callback (a PURI:URI) or NIL if 161 | the callback is supposed to be transferred oob. [6.1.1]" 162 | (protocol-assert (>= (length (normalized-parameters)) 163 | (case *protocol-version* 164 | ;; callbacks were introduced in 1.0a 165 | (1.0 4) 166 | (t 6 5)))) 167 | (check-version) 168 | (check-signature) 169 | (let ((consumer-token (get-supplied-consumer-token))) 170 | (check-nonce-and-timestamp consumer-token) 171 | (let* ((callback-uri (get-supplied-callback-uri :allow-oob-callback-p allow-oob-callback-p 172 | :allow-none t)) 173 | (request-token (funcall request-token-ctor :consumer consumer-token 174 | :callback-uri (when callback-uri 175 | (puri:parse-uri callback-uri)) 176 | :user-data (remove-oauth-parameters (normalized-parameters))))) 177 | (register-token request-token) 178 | request-token))) 179 | 180 | (defun get-supplied-request-token (&key check-verification-code-p) 181 | "Utility function that extracts the Consumer-supplied request token 182 | from a list of normalized parameters. Guards against non-existing 183 | and unknown tokens. Returns the request token on success." 184 | ;; TODO: check whether the supplied token matches the Consumer key 185 | (let ((request-token-key (parameter "oauth_token"))) 186 | ;; check if the Consumer supplied a request token 187 | (unless request-token-key 188 | (raise-error 'bad-request "Missing request token")) 189 | ;; check if the supplied request token is known to us 190 | (let ((request-token (gethash request-token-key *issued-request-tokens*))) 191 | (unless request-token 192 | (raise-error 'unauthorized "Invalid request token")) 193 | (when check-verification-code-p 194 | (check-verification-code)) 195 | ;; everything's looking good 196 | request-token))) 197 | 198 | 199 | ;;; access token management 200 | (defvar *issued-access-tokens* (make-hash-table :test #'equalp)) 201 | 202 | (defmethod register-token ((token access-token)) 203 | (setf (gethash (token-key token) *issued-access-tokens*) token)) 204 | 205 | (defmethod unregister-token ((token access-token)) 206 | (remhash (token-key token) *issued-access-tokens*)) 207 | 208 | (defun validate-access-token-request (&key (access-token-ctor #'make-access-token)) 209 | ;; no user-supplied parameters allowed here, and the 210 | ;; spec forbids duplicate oauth args per section 5. 211 | ;; moreover we don't count the oauth_signature parameter as it isn't 212 | ;; part of the normalized parameter list. 213 | (protocol-assert (multiple-value-call #'between (length (normalized-parameters)) 214 | (case *protocol-version* 215 | (1.0 (values 5 6)) 216 | (t 6 (values 6 7))))) 217 | (format t "foo~%") 218 | (protocol-assert (null (remove-oauth-parameters (normalized-parameters)))) 219 | (format t "bar~%") 220 | (check-version) 221 | (check-signature) 222 | (let* ((request-token (get-supplied-request-token 223 | :check-verification-code-p (not (eq *protocol-version* :1.0)))) 224 | (consumer (token-consumer request-token))) 225 | (check-nonce-and-timestamp consumer) 226 | (let ((access-token (funcall access-token-ctor :consumer consumer))) 227 | (register-token access-token) 228 | (prog1 229 | access-token 230 | (invalidate-request-token request-token))))) 231 | 232 | (defun access-token-response (access-token &rest additional-parameters) 233 | (declare (ignore additional-parameters)) ; TODO not supported yet 234 | (url-encode (alist->query-string 235 | `(("oauth_token" . ,(token-key access-token)) 236 | ("oauth_token_secret" . ,(token-secret access-token)))))) 237 | 238 | 239 | ;;; protected resource access management [7] 240 | (defun get-supplied-access-token () 241 | "Utility function that extracts the Consumer-supplied request token 242 | from a list of normalized parameters. Guards against non-existing 243 | and unknown tokens. Returns the request token on success." 244 | ;; TODO: check whether the supplied token matches the Consumer key 245 | (let ((access-token-key (parameter "oauth_token"))) 246 | (unless access-token-key 247 | (raise-error 'bad-request "Missing access token")) 248 | ;; check if the supplied access token is known to us 249 | (let ((access-token (gethash access-token-key *issued-access-tokens*))) 250 | (unless access-token 251 | (raise-error 'unauthorized "Invalid access token")) 252 | access-token))) 253 | 254 | (defun validate-access-token () 255 | (protocol-assert (>= (length (normalized-parameters)) 6)) 256 | (check-version) 257 | (check-signature) 258 | (let ((consumer-token (get-supplied-consumer-token))) 259 | (check-nonce-and-timestamp consumer-token) 260 | (let ((access-token (get-supplied-access-token))) 261 | (unless (eq consumer-token (token-consumer access-token)) 262 | (raise-error 'unauthorized "Access token ~S wasn't issued for Consumer ~S" access-token consumer-token)) 263 | t))) 264 | 265 | -------------------------------------------------------------------------------- /src/core/signature.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (defun signature-base-string (&key (uri (request-uri)) 5 | (request-method (request-method)) 6 | (parameters (normalized-parameters))) 7 | (concatenate 'string (string-upcase (princ-to-string request-method)) 8 | "&" (url-encode 9 | (normalize-uri uri)) 10 | "&" (url-encode 11 | (alist->query-string parameters 12 | :url-encode t 13 | :include-leading-ampersand nil)))) 14 | 15 | (declaim (notinline hmac-key)) ; we want to trace this when debugging. 16 | (defun hmac-key (consumer-secret &optional token-secret) 17 | "9.2" 18 | (concatenate 'string (url-encode consumer-secret) "&" (url-encode (or token-secret "")))) 19 | 20 | (defun encode-signature (octets url-encode-p) 21 | "9.2.1" 22 | (let ((base64 (cl-base64:usb8-array-to-base64-string octets))) 23 | (if url-encode-p 24 | (url-encode base64) 25 | base64))) 26 | 27 | -------------------------------------------------------------------------------- /src/core/tokens.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | ;;; section 6. 5 | ;;; 6 | ;;; OAuth Authentication is done in three steps: 7 | ;;; 8 | ;;; 1. The Consumer obtains an unauthorized Request Token. 9 | ;;; 2. The User authorizes the Request Token. 10 | ;;; 3. The Consumer exchanges the Request Token for an Access Token. 11 | ;;; 12 | 13 | ;;; TODO: token registry GC 14 | 15 | ;;; default token values 16 | (let ((random-state (make-random-state t))) 17 | (defun random-key () 18 | (format nil "~36,25,'0r" (random (expt 36 25) random-state))) 19 | 20 | (defun random-secret () 21 | (format nil "~36,25,'0r" (random (expt 36 25) random-state))) 22 | 23 | (defun random-verification-code () 24 | (format nil "~36,25,'0r" (random (expt 36 25) random-state)))) 25 | 26 | 27 | ;;; token base class 28 | (defclass token () 29 | ((key :type string 30 | :reader token-key 31 | :initarg :key 32 | :initform (random-key)) 33 | (secret :type string 34 | :reader token-secret 35 | :initarg :secret 36 | :initform (random-secret)) 37 | (user-data :type list 38 | :accessor token-user-data 39 | :initarg :user-data 40 | :initform nil 41 | :documentation "Application-specific data associated 42 | with this token; an alist."))) 43 | 44 | (defmethod print-object ((obj token) stream) 45 | "Faking STRUCT-like output. It would probably be better to use 46 | the pretty printer; the code for sb-kernel::%default-structure-pretty-print 47 | will be a useful template." 48 | (print-unreadable-object (obj stream :type t :identity (not *print-pretty*)) 49 | (loop for slotname in (mapcar #'c2mop:slot-definition-name 50 | (c2mop:class-slots (class-of obj))) 51 | do (progn 52 | (terpri stream) 53 | (write " " :stream stream :escape nil) 54 | (prin1 (intern (symbol-name slotname) :keyword) stream) 55 | (write " " :stream stream :escape nil) 56 | (prin1 (if (slot-boundp obj slotname) 57 | (slot-value obj slotname) 58 | "(unbound)") 59 | stream))))) 60 | 61 | 62 | ;;; consumer tokens 63 | (defclass consumer-token (token) 64 | ((last-timestamp :type integer 65 | :accessor consumer-token-last-timestamp 66 | :initform 0))) 67 | 68 | (defun make-consumer-token (&rest args) 69 | (apply #'make-instance 'consumer-token args)) 70 | 71 | 72 | (defclass consumer-ref-mixin () 73 | ((consumer :type consumer-token 74 | :accessor token-consumer 75 | :initarg :consumer 76 | :documentation "The Consumer that originally requested this 77 | token.")) 78 | (:documentation "Mixin for classes that refer to a consumer.")) 79 | 80 | 81 | ;;; request tokens 82 | (defclass request-token (token consumer-ref-mixin) 83 | ((callback-uri :type (or puri:uri null) 84 | :reader request-token-callback-uri 85 | :initarg :callback-uri 86 | :initform nil 87 | :documentation "Callback URI for this request token. 88 | NIL means oob.") 89 | (verification-code :type (or string null) 90 | :accessor request-token-verification-code 91 | :initarg :verification-code 92 | :initform (random-verification-code) 93 | :documentation "Might be NIL for OAuth 1.0") 94 | (authorized-p :type boolean 95 | :accessor request-token-authorized-p 96 | :initform nil))) 97 | 98 | (defun make-request-token (&rest args) 99 | (apply #'make-instance 'request-token args)) 100 | 101 | 102 | ;;; access tokens 103 | (defclass access-token (token consumer-ref-mixin) 104 | ((session-handle :type (or string null) 105 | :reader access-token-session-handle 106 | :initarg :session-handle 107 | :initform nil) 108 | (expires :type (or integer null) 109 | :reader access-token-expires 110 | :initarg :expires 111 | :initform nil 112 | :documentation "Universal time when this token expires.") 113 | (authorization-expires 114 | :type (or integer null) 115 | :reader access-token-authorization-expires 116 | :initarg :authorization-expires 117 | :initform nil 118 | :documentation "Universal time when this token's session expires.") 119 | (origin-uri 120 | :type (or puri:uri string null) 121 | :reader access-token-origin-uri 122 | :initarg :origin-uri 123 | :initform nil 124 | :documentation "URI this access token has been obtained from. 125 | Needed for refresh."))) 126 | 127 | 128 | (defun make-access-token (&rest args) 129 | (apply #'make-instance 'access-token args)) 130 | 131 | (defun access-token-expired-p (access-token) 132 | (and (access-token-session-handle access-token) 133 | (or (aand (access-token-expires access-token) 134 | (> (get-universal-time) it)) 135 | (aand (access-token-authorization-expires access-token) 136 | (> (get-universal-time) it))))) 137 | 138 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defmacro without-package-variance-warnings (&body body) 3 | `(eval-when (:compile-toplevel :load-toplevel :execute) 4 | (handler-bind (#+sbcl(sb-int:package-at-variance #'muffle-warning)) 5 | ,@body))) 6 | 7 | (without-package-variance-warnings 8 | (defpackage #:cl-oauth 9 | (:nicknames #:oauth) 10 | (:use #:cl #:anaphora #:f-underscore) 11 | (:import-from #:hunchentoot 12 | #:create-prefix-dispatcher 13 | #:*dispatch-table*) 14 | (:import-from #:alexandria #:with-unique-names #:curry #:rcurry #:ensure-list #:compose) 15 | (:import-from #:split-sequence #:split-sequence) 16 | (:export 17 | #:*protocol-version* 18 | 19 | ;;; error handling 20 | #:http-error 21 | #:bad-request 22 | #:unauthorized 23 | #:raise-error 24 | #:default-error-handler 25 | #:protocol-assert 26 | 27 | ;;; tokens 28 | #:token 29 | #:token-key 30 | #:token-secret 31 | #:token-user-data 32 | 33 | #:token-consumer 34 | 35 | #:register-token 36 | #:unregister-token 37 | 38 | #:consumer-token 39 | #:make-consumer-token 40 | 41 | #:request-token 42 | #:make-request-token 43 | #:request-token-authorized-p 44 | #:request-token-callback-uri 45 | #:request-token-verification-code 46 | 47 | #:access-token 48 | #:make-access-token 49 | #:access-token-session-handle 50 | #:access-token-expires 51 | #:access-token-authorization-expires 52 | #:access-token-expired-p 53 | 54 | ;;; consumer functions 55 | #:obtain-access-token 56 | #:authorize-request-token 57 | #:authorize-request-token-from-request 58 | #:make-authorization-uri 59 | #:obtain-request-token 60 | #:access-protected-resource 61 | 62 | ;;; crypto 63 | #:signature-base-string 64 | #:hmac-key 65 | #:hmac-sha1 66 | #:encode-url 67 | #:encode-signature 68 | 69 | ;;; parameters 70 | #:remove-auth-parameters 71 | #:normalized-parameters 72 | 73 | ;;; service provider 74 | #:check-version 75 | #:check-nonce-and-timestamp 76 | #:check-signature 77 | #:check-verification-code 78 | 79 | #:validate-request-token-request 80 | #:request-token-response 81 | 82 | #:get-supplied-request-token 83 | #:finalize-callback-uri 84 | 85 | #:validate-access-token-request 86 | 87 | #:validate-access-token 88 | 89 | #:make-response 90 | ))) 91 | 92 | -------------------------------------------------------------------------------- /src/util/misc.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (defun alist->plist (alist) 5 | "Converts an alist to plist." 6 | (let ((keyword-package (find-package :keyword))) 7 | (loop for i in alist 8 | collect (if (symbolp (car i)) 9 | (intern (symbol-name (car i)) keyword-package) 10 | (intern (string-upcase (car i)) keyword-package)) 11 | collect (cdr i)))) 12 | 13 | (defun splice-alist (alist) 14 | (reduce #'nconc (mapcar (lambda (x) 15 | (list (car x) (cdr x))) 16 | alist))) 17 | 18 | (defun between (what lower upper) 19 | (and (>= what lower) (<= what upper))) 20 | 21 | (defconstant +unix-to-universal-time+ 2208988800) 22 | 23 | (defun get-unix-time (&optional (ut (get-universal-time))) 24 | (- ut +unix-to-universal-time+)) 25 | 26 | -------------------------------------------------------------------------------- /src/util/query-string.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (defun alist->query-string (alist &key (include-leading-ampersand t) url-encode) 5 | (let* ((plist (splice-alist alist)) 6 | (plist* (if url-encode 7 | (loop for (key value) on plist by #'cddr 8 | collect (url-encode (string key)) 9 | collect (url-encode value)) 10 | plist)) 11 | (result (format nil "~{&~A=~A~}" plist*))) 12 | (subseq ; TODO: nsubseq http://darcs.informatimago.com/lisp/common-lisp/utility.lisp 13 | result 14 | (if (or (zerop (length result)) include-leading-ampersand) 15 | 0 16 | 1)))) 17 | 18 | (defun query-string->alist (query-string) 19 | ;; TODO: doesn't handle leading ? 20 | (check-type query-string string) 21 | (let* ((kv-pairs (remove "" (split-sequence #\& query-string) :test #'equal)) 22 | (alist (mapcar (lambda (kv-pair) 23 | (let ((kv (split-sequence #\= kv-pair))) 24 | (cons (first kv) (second kv)))) 25 | kv-pairs))) 26 | alist)) 27 | 28 | -------------------------------------------------------------------------------- /src/util/uri.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth) 3 | 4 | (export '(url-encode)) 5 | 6 | (defvar +utf-8+ (flexi-streams:make-external-format :utf8 :eol-style :lf)) 7 | 8 | ;; this function is taken from Hunchentoot but modified to 9 | ;; satisfy the OAuth spec demands. 10 | (defun url-encode (input &optional (external-format +utf-8+)) 11 | "URL-encodes INPUT according to the percent encoding rules of 12 | RFC5849 (section 3.6). If a string is passed as INPUT, it is 13 | encoded using the external format EXTERNAL-FORMAT. If a vector of 14 | bytes is passed, the values are used verbatim." 15 | (with-output-to-string (s) 16 | (loop for octet across (etypecase input 17 | (string 18 | (flexi-streams:string-to-octets input :external-format external-format)) 19 | ((or (array (integer) (*)) 20 | (array (unsigned-byte 8) (*))) 21 | input) 22 | (null 23 | #())) 24 | for char = (code-char octet) 25 | do (if (or (char<= #\0 char #\9) 26 | (char<= #\a char #\z) 27 | (char<= #\A char #\Z) 28 | (find char "-_.~" :test #'char=)) 29 | (write-char char s) 30 | (format s "%~2,'0x" octet))))) 31 | 32 | (defmacro upgrade-vector (vector new-type &key converter) 33 | "Returns a vector with the same length and the same elements as 34 | VECTOR \(a variable holding a vector) but having element type 35 | NEW-TYPE. If CONVERTER is not NIL, it should designate a function 36 | which will be applied to each element of VECTOR before the result is 37 | stored in the new vector. The resulting vector will have a fill 38 | pointer set to its end. 39 | 40 | The macro also uses SETQ to store the new vector in VECTOR." 41 | `(setq ,vector 42 | (loop with length = (length ,vector) 43 | with new-vector = (make-array length 44 | :element-type ,new-type 45 | :fill-pointer length) 46 | for i below length 47 | do (setf (aref new-vector i) ,(if converter 48 | `(funcall ,converter (aref ,vector i)) 49 | `(aref ,vector i))) 50 | finally (return new-vector)))) 51 | 52 | ;;; this function is taken from Hunchentoot 1.1.0 without effective modification 53 | (defun url-decode (string &optional (external-format +utf-8+)) 54 | "Decodes a URL-encoded STRING which is assumed to be encoded using 55 | the external format EXTERNAL-FORMAT." 56 | (when (zerop (length string)) 57 | (return-from url-decode "")) 58 | (let ((vector (make-array (length string) :element-type '(unsigned-byte 8) :fill-pointer 0)) 59 | (i 0) 60 | unicodep) 61 | (loop 62 | (unless (< i (length string)) 63 | (return)) 64 | (let ((char (aref string i))) 65 | (labels ((decode-hex (length) 66 | (prog1 67 | (parse-integer string :start i :end (+ i length) :radix 16) 68 | (incf i length))) 69 | (push-integer (integer) 70 | (vector-push integer vector)) 71 | (peek () 72 | (aref string i)) 73 | (advance () 74 | (setq char (peek)) 75 | (incf i))) 76 | (cond 77 | ((char= #\% char) 78 | (advance) 79 | (cond 80 | ((char= #\u (peek)) 81 | (unless unicodep 82 | (setq unicodep t) 83 | (upgrade-vector vector '(integer 0 65535))) 84 | (advance) 85 | (push-integer (decode-hex 4))) 86 | (t 87 | (push-integer (decode-hex 2))))) 88 | (t 89 | (push-integer (char-code (case char 90 | ((#\+) #\Space) 91 | (otherwise char)))) 92 | (advance)))))) 93 | (cond (unicodep 94 | (upgrade-vector vector 'character :converter #'code-char)) 95 | (t (flexi-streams:octets-to-string vector :external-format external-format))))) 96 | 97 | 98 | (defmethod normalize-uri ((uri string)) 99 | (normalize-uri (puri:parse-uri uri))) 100 | 101 | (defmethod normalize-uri ((uri puri:uri)) 102 | "9.1.2" 103 | (let ((*print-case* :downcase) ; verify that this works!! 104 | (scheme (puri:uri-scheme uri)) 105 | (host (puri:uri-host uri)) 106 | (port (puri:uri-port uri)) 107 | (path (puri:uri-path uri))) 108 | (values 109 | (concatenate 'string 110 | (string-downcase (princ-to-string scheme)) 111 | "://" 112 | (string-downcase host) 113 | (cond 114 | ((null port) 115 | "") 116 | ((and (eq scheme :http) (eql port 80)) 117 | "") 118 | ((and (eq scheme :https) (eql port 443)) 119 | "") 120 | (t 121 | (concatenate 'string ":" (princ-to-string port)))) 122 | path) 123 | (awhen (puri:uri-query uri) 124 | (query-string->alist it))))) 125 | 126 | -------------------------------------------------------------------------------- /test/core/parameters.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth-test) 3 | 4 | (def-suite parameters :in oauth) 5 | 6 | (in-suite parameters) 7 | 8 | (test splice-alist/nil 9 | (is (null (oauth::splice-alist nil)))) 10 | 11 | (test splice-alist/simple 12 | (is (equal (oauth::splice-alist '((a . 1)(b . 2))) 13 | '(a 1 b 2)))) 14 | 15 | (test alist->query-string/nil 16 | (is (equal (oauth::alist->query-string nil) ""))) 17 | 18 | (test alist->query-string/simple 19 | (is (equal (oauth::alist->query-string '(("foo" . 1) ("bar" . 2))) 20 | "&foo=1&bar=2"))) 21 | 22 | (test alist->query-string/no-ampersand 23 | (is (equal (oauth::alist->query-string '(("foo" . 1) ("bar" . 2)) 24 | :include-leading-ampersand nil) 25 | "foo=1&bar=2"))) 26 | 27 | (test normalized-parameters/spec-example 28 | (let ((*post-parameters* '(("a" . "1") 29 | ("c" . "hi%20there") 30 | ("f" . "25") 31 | ("f" . "50") 32 | ("f" . "a") 33 | ("z" . "p") 34 | ("z" . "t")))) 35 | (is (equal 36 | (oauth::alist->query-string 37 | (oauth::normalized-parameters) 38 | :include-leading-ampersand nil) 39 | "a=1&c=hi%20there&f=25&f=50&f=a&z=p&z=t")))) 40 | 41 | -------------------------------------------------------------------------------- /test/core/request-adapter.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth-test) 3 | 4 | (defvar *request-object* nil) 5 | (defvar *request-method* :get) 6 | (defvar *request-uri* "http://host.domain/path") 7 | (defvar *auth-parameters* nil) 8 | (defvar *post-parameters* nil) 9 | (defvar *get-parameters* nil) 10 | 11 | (defun make-test-request-adapter () 12 | (make-request-adapter :request-object-fn (lambda () 13 | ;; prevent caching. 14 | ;; TODO: use private caches for testing 15 | ;; so we don't interfere with live data. 16 | (or *request-object* (random most-positive-fixnum))) 17 | :request-method-fn (lambda (request) 18 | (declare (ignore request)) 19 | *request-method*) 20 | :request-uri-fn (lambda (request) 21 | (declare (ignore request)) 22 | *request-uri*) 23 | :auth-parameters-fn (lambda (request) 24 | (declare (ignore request)) 25 | *auth-parameters*) 26 | :post-parameters-fn (lambda (request) 27 | (declare (ignore request)) 28 | *post-parameters*) 29 | :get-parameters-fn (lambda (request) 30 | (declare (ignore request)) 31 | *get-parameters*))) 32 | 33 | (defun init-test-request-adapter () 34 | (setf *request-adapter* (make-test-request-adapter))) 35 | 36 | (defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system :cl-oauth)))) 37 | (let ((original-request-adapter *request-adapter*)) 38 | (unwind-protect 39 | (progn 40 | (init-test-request-adapter) 41 | (fiveam:run! 'oauth)) 42 | (setf *request-adapter* original-request-adapter)))) 43 | 44 | -------------------------------------------------------------------------------- /test/core/service-provider.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth-test) 3 | 4 | (def-suite service-provider :in oauth) 5 | 6 | (in-suite service-provider) 7 | 8 | ;; TODO tests for check-nonce-and-timestamp 9 | 10 | 11 | (test check-version.valid 12 | (let ((*get-parameters* '(("oauth_version" . "1.0")))) 13 | (finishes (check-version)))) 14 | 15 | (test check-version.invalid 16 | (let ((*get-parameters* '(("oauth_version" . "foo")))) 17 | (signals error (check-version)))) 18 | 19 | 20 | (defmacro with-signed-request ((&key user-parameters 21 | 22 | (version "1.0") 23 | (timestamp (get-universal-time)) 24 | (nonce (random most-positive-fixnum)) 25 | 26 | signature-override 27 | (signature-method "HMAC-SHA1") 28 | 29 | (consumer-token (make-consumer-token)) 30 | 31 | token 32 | verification-code) 33 | &body body) 34 | "Execute BODY in a signed request environment. SIGNATURE-OVERRIDE may be used 35 | to provide a specific signature (which is supposed to be base64-urlencoded)." 36 | `(progn 37 | (register-token ,consumer-token) 38 | (when ,token 39 | (assert (typep ,token '(or request-token access-token))) 40 | (setf (token-consumer ,token) ,consumer-token) 41 | (register-token ,token)) 42 | (let* ((*request-object* (random most-positive-fixnum)) 43 | (*request-method* :get) 44 | (*request-uri* "/foo") 45 | (parameters (append ',user-parameters 46 | (list (cons "oauth_version" ,version) 47 | (cons "oauth_signature_method" ,signature-method) 48 | (cons "oauth_consumer_key" (token-key ,consumer-token)) 49 | (cons "oauth_timestamp" (princ-to-string ,timestamp)) 50 | (cons "oauth_nonce" (princ-to-string ,nonce))) 51 | (when ,token 52 | (list (cons "oauth_token" (token-key ,token)))) 53 | (when (and ,token (typep ,token 'request-token)) 54 | (list (cons "oauth_verifier" (or ,verification-code 55 | (request-token-verification-code ,token))))))) 56 | (signature (or ,signature-override 57 | (encode-signature 58 | (hmac-sha1 (signature-base-string :parameters (sort-parameters 59 | (copy-alist parameters))) 60 | (hmac-key (token-secret ,consumer-token) 61 | (when ,token (token-secret ,token)))) 62 | nil))) 63 | (*get-parameters* (cons (cons "oauth_signature" signature) parameters))) 64 | (setf (gethash (request) oauth::*signature-cache*) signature) 65 | ,@body) 66 | (when ,token 67 | (unregister-token ,token)) 68 | (unregister-token ,consumer-token))) 69 | 70 | 71 | ;; TODO check for specific errors in the following tests. 72 | (test check-signature.invalid-method 73 | (with-signed-request (:signature-method "foo") 74 | (signals error (check-signature)))) 75 | 76 | (test check-signature.invalid 77 | (with-signed-request (:signature-override "haha") 78 | (signals error (check-signature)))) 79 | 80 | (test check-signature.valid 81 | (with-signed-request () 82 | (finishes (check-signature)))) 83 | 84 | (test check-signature.valid2 85 | (with-signed-request () 86 | (finishes (check-signature)))) 87 | 88 | 89 | ;;;; high-level API 90 | 91 | ;;; phase 1 92 | (test (validate-request-token-request.oob 93 | :depends-on (and check-version.valid check-signature.valid)) 94 | (with-signed-request (:user-parameters (("oauth_callback" . "oob"))) 95 | (is (typep (validate-request-token-request :allow-oob-callback-p t) 'request-token)))) 96 | 97 | (test (validate-request-token-request.oob-disallowed 98 | :depends-on (and check-version.valid check-signature.valid)) 99 | (with-signed-request (:user-parameters (("oauth_callback" . "oob"))) 100 | (signals error (validate-request-token-request :allow-oob-callback-p nil)))) 101 | 102 | (test (validate-request-token-request.callback-uri 103 | :depends-on (and check-version.valid check-signature.valid)) 104 | (with-signed-request (:user-parameters (("oauth_callback" . "http://example.com/bar"))) 105 | (is (typep (validate-request-token-request :allow-oob-callback-p nil) 'request-token)))) 106 | 107 | 108 | ;;; phase 2 109 | (test (validate-access-token-request.valid-request-token 110 | :depends-on (and check-version.valid check-signature.valid)) 111 | (let ((request-token (make-request-token)) 112 | (*protocol-version* :1.0a)) 113 | (setf (request-token-authorized-p request-token) t) 114 | (with-signed-request (:token request-token) 115 | (is (typep (validate-access-token-request) 'access-token))))) 116 | 117 | ;; TODO more tests, esp. for invalid requests. 118 | 119 | 120 | ;;; phase 3 121 | (test (validate-access-token.valid 122 | :depends-on (and check-version.valid check-signature.valid)) 123 | (let ((access-token (make-access-token))) 124 | (with-signed-request (:token access-token) 125 | (is (eq t (validate-access-token)))))) 126 | 127 | -------------------------------------------------------------------------------- /test/core/signature.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth-test) 3 | 4 | (def-suite signature :in oauth) 5 | 6 | (in-suite signature) 7 | 8 | (defvar *sample-signature-base-string* 9 | (format nil "GET&http%3A%2F%2Fphotos.example.net%2Fphotos~ 10 | &file%3Dvacation.jpg%26oauth_consumer_key~ 11 | %3Ddpf43f3p2l4k3l03%26oauth_nonce%3Dkllo9940pd9333jh~ 12 | %26oauth_signature_method%3DHMAC-SHA1%26oauth_timestamp~ 13 | %3D1191242096%26oauth_token%3Dnnch734d00sl2jdk~ 14 | %26oauth_version%3D1.0%26size%3Doriginal")) 15 | 16 | ;; A.5.1 17 | (test signature-base-string/spec 18 | (let* ((*request-method* :get) 19 | (uri "http://photos.example.net/photos") 20 | (parameters (format nil "file=vacation.jpg&oauth_consumer_key=dpf43f3p2l4k3l03~ 21 | &oauth_nonce=kllo9940pd9333jh&oauth_signature_method=HMAC-SHA1~ 22 | &oauth_timestamp=1191242096&oauth_token=nnch734d00sl2jdk~ 23 | &oauth_version=1.0&size=original")) 24 | (parameters-alist (oauth::query-string->alist parameters)) 25 | (*get-parameters* parameters-alist) 26 | (signature-base-string (signature-base-string :uri uri))) 27 | (is (equal signature-base-string 28 | *sample-signature-base-string*)))) 29 | 30 | ;; A.5.2 31 | (test hmac-sha1-digest/spec 32 | (let* ((key "kd94hf93k423kf44&pfkkdhi9sl3r4s00") 33 | (text *sample-signature-base-string*) 34 | (digest (hmac-sha1 text key)) 35 | (digest/base64 (cl-base64:usb8-array-to-base64-string digest))) 36 | (is (equal digest/base64 "tR3+Ty81lMeYAr/Fid0kMTYa/WM=")))) 37 | 38 | -------------------------------------------------------------------------------- /test/core/tokens.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :oauth-test) 3 | 4 | (def-suite tokens :in oauth) 5 | 6 | (in-suite tokens) 7 | 8 | (test request-token.not-authorized-by-default 9 | (is (not (request-token-authorized-p (make-request-token))))) 10 | 11 | (test token-printer.deals-with-unbound-slots 12 | (finishes (write-to-string (make-request-token)))) 13 | 14 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:oauth-test 2 | (:use #:cl #:oauth #:5am) 3 | (:import-from #:alexandria #:with-unique-names #:curry #:rcurry)) 4 | 5 | (in-package :oauth-test) 6 | 7 | (def-suite oauth) 8 | 9 | --------------------------------------------------------------------------------