-
-
Notifications
You must be signed in to change notification settings - Fork 6
/
client.lisp
165 lines (148 loc) · 6.81 KB
/
client.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
(in-package #:org.shirakumo.tooter)
(defun %request (uri parameters headers method content-type)
(let ((drakma:*text-content-types* '(("application" . "json"))))
(drakma:http-request uri :method method
:parameters parameters
:content-type content-type
:additional-headers headers
:external-format-out :utf-8
:external-format-in :utf-8
:want-stream T)))
(define-condition request-failed (error)
((uri :initarg :uri :reader uri)
(request-method :initarg :request-method :reader request-method)
(code :initarg :code :reader code)
(data :initarg :data :reader data)
(message :initarg :message :reader message))
(:report (lambda (c s)
(format s
"Mastodon ~a request to ~s failed with code ~d~@[:~% ~a~]"
(request-method c) (uri c) (code c) (message c)))))
(defun request (uri &key parameters headers (method :get) (content-type "application/x-www-form-urlencoded"))
(multiple-value-bind (stream code headers)
(%request uri parameters headers method content-type)
(let ((data (unwind-protect
(yason:parse stream)
(close stream))))
(if (= 200 code)
(values data headers)
(error 'request-failed :uri uri
:request-method method
:code code
:data data
:message (or (getj data :error-description)
(getj data :error)))))))
(defclass client ()
((base :initarg :base :accessor base)
(key :initarg :key :accessor key)
(secret :initarg :secret :accessor secret)
(access-token :initarg :access-token :accessor access-token)
(name :initarg :name :accessor name)
(redirect :initarg :redirect :accessor redirect)
(scopes :initarg :scopes :accessor scopes)
(website :initarg :website :accessor website)
(account :initform NIL :accessor account))
(:default-initargs
:base (error "BASE required.")
:key NIL
:secret NIL
:access-token NIL
:name (error "NAME required.")
:redirect "urn:ietf:wg:oauth:2.0:oob"
:scopes '(:read :write :follow)
:website NIL))
(defclass v2:client (client) ())
(defmethod shared-initialize :after ((client client) slots &key)
(when (access-token client)
(let ((ideal-class (ecase (max-api-version client)
(2 (find-class 'v2:client))
(1 (find-class 'client)))))
(unless (eq ideal-class (class-of client))
(change-class client ideal-class)))))
(defmethod (setf access-token) ((value string) (client client))
(reinitialize-instance client :access-token value)
value)
(defmethod print-object ((client client) stream)
(print-unreadable-object (client stream :type T)
(format stream "~a ~a" (name client) (base client))))
(defmethod account ((client client))
(let ((account (slot-value client 'account)))
(or account
(verify-credentials client))))
(defmethod make-load-form ((client client) &optional env)
(declare (ignore env))
`(make-instance ',(type-of client)
:base ,(base client)
:key ,(key client)
:secret ,(secret client)
:access-token ,(access-token client)
:name ,(name client)
:redirect ,(redirect client)
:scopes (list ,@(scopes client))
:website ,(website client)))
(defmethod default-headers ((client client) &key idempotency-key)
(remove nil (list
(when (access-token client)
`("Authorization" . ,(format NIL "Bearer ~a" (access-token client))))
(when idempotency-key
`("Idempotency-Key" . idempotency-key)))))
(defmethod query-url ((client client) url &key (method :get) (parameters nil))
(request url
:method method
:parameters parameters
:content-type "application/x-www-form-urlencoded"
:headers (default-headers client)))
(defmethod query ((client client) endpoint &rest parameters)
(let ((method (or (getf parameters :http-method) :get)))
(remf parameters :http-method)
(query-url client
(format NIL "~a~a" (base client) endpoint)
:method method
:parameters (param-plist->alist parameters))))
(defmethod submit ((client client) endpoint &rest parameters)
(let ((method (or (getf parameters :http-method) :post))
(idempotency-key (getf parameters :idempotency-key)))
(remf parameters :http-method)
(remf parameters :idempotency-key)
(request (format NIL "~a~a" (base client) endpoint)
:parameters (param-plist->alist parameters)
:method method
:content-type "multipart/form-data"
:headers (default-headers client :idempotency-key idempotency-key))))
(defmethod max-api-version ((client client))
(let ((instance (ignore-errors (decode-instance (query client "/api/v2/instance")))))
(if instance
(getf (getf (api-versions instance) :api-versions) :mastodon 1)
1)))
(defmethod register ((client client))
(let ((data (decode-credential-application (submit client "/api/v1/apps"
:client-name (name client)
:redirect-uris (redirect client)
:scopes (format NIL "~{~(~a~)~^ ~}" (scopes client))
:website (website client)))))
(setf (key client) (client-id data))
(setf (secret client) (client-secret data))
(values client (key client) (secret client))))
(defmethod authorize ((client client) &optional authorization-code)
(unless (and (key client) (secret client))
(register client))
(cond
((access-token client)
(values client (access-token client)))
(authorization-code
(let ((data (submit client "/oauth/token"
:client-id (key client)
:grant-type "authorization_code"
:code authorization-code
:redirect-uri (redirect client)
:client-id (key client)
:client-secret (secret client))))
(setf (access-token client) (getj data :access-token))
(values client (access-token client))))
(T
(values NIL
(make-url (format NIL "~a/oauth/authorize" (base client))
:scope (format NIL "~{~(~a~)~^ ~}" (scopes client))
:response-type "code"
:redirect-uri (redirect client)
:client-id (key client))))))