· 7 years ago · Jun 13, 2018, 06:56 AM
1;;; -*- mode:Lisp; package:oauth -*-
2
3(require 'xml-http-request)
4(defpackage :oauth
5 (:use :lisp :editor))
6
7(in-package "oauth")
8
9(export '(authenticate
10 make-cred
11 auth-header))
12
13;;; utility
14(defun pair (xs &optional (f #'list))
15 (cond ((null xs) nil)
16 ((null (cdr xs)) #1=(list (list (car xs))))
17 (t (do* ((acc #2=(list (funcall f (car xs) (cadr xs))))
18 (tail acc)
19 (xs #3=(cddr xs) #3#))
20 ((null xs) acc)
21 (setf (cdr tail) (if (cdr xs) #2# #1#)
22 tail (cdr tail))))))
23
24(defun random-string (size)
25 (make-random-state t)
26 (map 'string #'(lambda (_) (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ\
27abcdefghijklmnopqrstuvwxyz" (random 62)))
28 (make-list size)))
29
30(defun time-stamp ()
31 (- (get-universal-time)
32 #.(encode-universal-time 0 0 0 1 1 1970 0)))
33
34(defun url-encode (str)
35 (let ((utf8str (convert-encoding-from-internal *encoding-utf8n* str)))
36 (si:www-url-encode utf8str nil "0-9A-Za-z-._~")))
37
38
39;;; hmac-sha1
40(defun sha1bin (str)
41 (let* ((h (si:sha-1 str))
42 (l (/ (length h) 2))
43 (v (make-vector l)))
44 (dotimes (i l v)
45 (setf (svref v i)
46 (parse-integer h :start (* i 2) :end (* (1+ i) 2) :radix 16)))))
47
48(defun unibyte-string (octets)
49 (map 'string #'code-char octets))
50
51(defun hmac-sha1 (key msg)
52 ; key and msg must be unibyte-strings
53 (let* ((key-block (replace (make-vector 64 :initial-element 0)
54 (if (< 64 (length key)) (sha1bin key)
55 (map 'vector #'char-code key))))
56 (opad (map 'string #'(lambda (i) (code-char (logxor i #x5c))) key-block))
57 (ipad (map 'string #'(lambda (i) (code-char (logxor i #x36))) key-block)))
58 (unibyte-string
59 (sha1bin (concat opad (unibyte-string (sha1bin (concat ipad msg))))))))
60
61(defun signature (cred method apiurl params)
62 (let ((sigkey (concat (cred-consumer-secret cred) "&"
63 (or (cred-token-secret cred) "")))
64 (sigstr (concat (format nil "~:@(~A~)" method) "&"
65 (url-encode apiurl) "&"
66 (url-encode (format nil "~{~{~A=~A~}~^&~}"
67 (sort params #'string<= :key #'car))))))
68 (remove #\LFD (si:base64-encode (hmac-sha1 sigkey sigstr)))))
69
70
71;;; exports
72(defstruct
73 (cred (:print-function
74 (lambda (o s p)
75 (format s "#S(oauth::cred consumer-key ~S token ~S)"
76 (cred-consuker-key o)
77 (cred-token o)))))
78 consumer-key consumer-secret token token-secret)
79
80
81(defun auth-header (cred method apiurl params)
82 (let* ((oauth-params `(("oauth_consumer_key" ,(cred-consumer-key cred))
83 ("oauth_nonce" ,(random-string 32))
84 ("oauth_signature_method" "HMAC-SHA1")
85 ("oauth_timestamp" ,(time-stamp))
86 ("oauth_version" "1.0")
87 . ,(when #1=(cred-token cred)
88 `(("oauth_token" ,#1#)))))
89 (all-params `(,@oauth-params
90 ,@(pair params
91 (lambda (k v) `(,(symbol-name k)
92 ,(url-encode (format nil "~A" v))))))))
93 (format nil "OAuth ~{~{~A=~A~}, ~}oauth_signature=~A"
94 oauth-params (url-encode (signature cred method apiurl all-params)))))
95
96
97
98(defun authenticate (request-token-url authorize-url access-token-url
99 consumer-key consumer-secret)
100 (let* ((cred (make-cred :consumer-key consumer-key
101 :consumer-secret consumer-secret))
102 (rauth (auth-header cred 'get request-token-url nil))
103 (rquery (substitute-string (subseq rauth 6) ", " "&")))
104 (multiple-value-bind (res status)
105 (xhr:xhr-get request-token-url :query rquery
106 :header `(:Authorization ,rauth)
107 :key #'xhr:xhr-response-values)
108 (when #1=(and (= status 200)
109 (string-match "oauth_token=\\([^&]+\\)&oauth_token_secret=\\([^&]+\\)" res))
110 (setf (cred-token cred) (match-string 1)
111 (cred-token-secret cred) (match-string 2))
112 (shell-execute (concat authorize-url "?oauth_token=" (cred-token cred)) t)
113 (sit-for 1)
114 (let ((pin (read-string "PIN: ")))
115 (when pin
116 (let* ((auth (auth-header cred 'get access-token-url `(:oauth_verifier ,pin)))
117 (query (concat (substitute-string (subseq auth 6) ", " "&")
118 "&oauth_verifier=" pin)))
119 (multiple-value-bind (res status)
120 (xhr:xhr-get token-url :query query
121 :header `(:Authorization ,auth)
122 :key #'xhr:xhr-response-values)
123 (if #1#
124 (values (match-string 1)
125 (match-string 2)
126 res)
127 (error res 'simple-error))))))))))