1 (uiop:define-package
#:lw2.backend-modules
3 (:import-from
#:alexandria
#:symbolicate
)
5 #:backend-class
#:class-cached-databases
#:class-own-databases
#:class-databases-epoch
7 #:backend-lmdb-cache
#:backend-lmdb-environment
#:backend-cache-db-path
10 #:backend-password-login
11 #:backend-websocket-login
12 #:backend-passport-js-login
13 #:backend-oauth2.0-login
14 #:graphql-uri
#:websocket-uri
#:algolia-search-uri
#:rest-api-uri
15 #:oauth2.0-login-uri
#:oauth2.0-client-id
#:oauth2.0-client-secret
16 #:backend-feed-crossposts
17 #:backend-q-and-a
#:backend-related-questions
19 #:backend-alignment-forum
23 #:backend-push-notifications
25 #:backend-lw2-tags-comments
26 #:backend-lw2-wiki-tags
27 #:backend-magnum-crossposts
#:backend-magnum-crosspost-site
28 #:backend-lw2-misc-workarounds
29 #:backend-lw2-misc-features
30 #:backend-lw2-legacy
#:backend-lw2-modernized
#:backend-lw2
#:backend-algolia-search
#:backend-ea-forum
#:backend-accordius
31 #:backend-progress-forum
33 #:make-backend
#:define-backend-function
#:define-backend-operation
#:backend
34 #:call-with-backend-context
)
35 (:unintern
#:declare-backend-function
)
36 (:recycle
#:lw2.backend
#:lw2.login
))
38 (in-package #:lw2.backend-modules
)
40 (defclass backend-class
(standard-class)
41 ((cached-databases :accessor class-cached-databases
:initform nil
)
42 (own-databases :accessor class-own-databases
:initform nil
)
43 (databases-epoch :accessor class-databases-epoch
:initform
0)))
45 (defmethod closer-mop:validate-superclass
((c backend-class
) (sc standard-class
))
48 (defclass backend-base
() () (:metaclass backend-class
))
50 (defclass backend-lmdb-cache
(backend-base)
51 ((lmdb-environment :accessor backend-lmdb-environment
:initform nil
)
52 (cache-db-path :accessor backend-cache-db-path
:initarg
:cache-db-path
:type simple-string
))
53 (:metaclass backend-class
))
55 (defclass backend-graphql
(backend-lmdb-cache)
56 ((graphql-uri :accessor graphql-uri
:initarg
:graphql-uri
:type simple-string
))
57 (:metaclass backend-class
))
59 (defclass backend-token-login
(backend-base) ()
60 (:metaclass backend-class
))
62 (defclass backend-password-login
(backend-base) ()
63 (:metaclass backend-class
))
65 (defclass backend-websocket-login
(backend-token-login backend-password-login
)
66 ((websocket-uri :accessor websocket-uri
:initarg
:websocket-uri
:type simple-string
))
67 (:metaclass backend-class
))
69 (defclass backend-passport-js-login
(backend-token-login backend-password-login
) ()
70 (:metaclass backend-class
))
72 (defclass backend-oauth2.0-login
(backend-token-login)
73 ((oauth2.0-login-uri
:accessor oauth2.0-login-uri
:initarg
:oauth2.0-login-uri
:type simple-string
)
74 (oauth2.0-client-id
:accessor oauth2.0-client-id
:initarg
:oauth2.0-client-id
:type simple-string
)
75 (oauth2.0-client-secret
:accessor oauth2.0-client-secret
:initarg
:oauth2.0-client-secret
:type simple-string
))
76 (:metaclass backend-class
))
78 (defclass backend-algolia-search
(backend-base)
79 ((algolia-search-uri :accessor algolia-search-uri
:initarg
:algolia-search-uri
:type simple-string
))
80 (:metaclass backend-class
))
82 (defclass backend-feed-crossposts
(backend-graphql) ()
83 (:metaclass backend-class
))
85 (defclass backend-q-and-a
(backend-graphql) ()
86 (:metaclass backend-class
))
88 (defclass backend-related-questions
(backend-graphql) ()
89 (:metaclass backend-class
))
91 (defclass backend-debates
(backend-graphql) ()
92 (:metaclass backend-class
))
94 (defclass backend-backlinks
(backend-lmdb-cache) ()
95 (:metaclass backend-class
))
97 (defclass backend-push-notifications
(backend-lmdb-cache) ()
98 (:metaclass backend-class
))
100 (defclass backend-alignment-forum
(backend-graphql) ()
101 (:metaclass backend-class
))
103 (defclass backend-events
(backend-graphql) ()
104 (:metaclass backend-class
))
106 (defclass backend-shortform
(backend-graphql) ()
107 (:metaclass backend-class
))
109 (defclass backend-lw2-tags
(backend-graphql) ()
110 (:metaclass backend-class
))
112 (defclass backend-lw2-tags-comments
(backend-lw2-tags) ()
113 (:metaclass backend-class
))
115 (defclass backend-magnum-crossposts
(backend-graphql)
116 ((magnum-crosspost-site :accessor backend-magnum-crosspost-site
:initarg
:magnum-crosspost-site
:type
(or simple-string null
) :initform nil
))
117 (:metaclass backend-class
))
119 (defclass backend-lw2-wiki-tags
(backend-lw2-tags) ()
120 (:metaclass backend-class
))
122 (defclass backend-lw2-misc-workarounds
(backend-graphql) ()
123 (:metaclass backend-class
))
125 (defclass backend-lw2-misc-features
(backend-graphql) ()
126 (:metaclass backend-class
))
128 (defclass backend-lw2-legacy
(backend-graphql) ()
129 (:metaclass backend-class
))
131 (defclass backend-lw2-modernized
(backend-graphql) ()
132 (:metaclass backend-class
))
134 (defclass backend-lw2
(backend-passport-js-login
135 backend-lw2-modernized
137 backend-lw2-misc-workarounds
138 backend-lw2-misc-features
139 backend-algolia-search
141 backend-related-questions
143 backend-alignment-forum
145 backend-feed-crossposts
147 backend-push-notifications
149 backend-lw2-tags-comments
150 backend-lw2-wiki-tags
151 backend-magnum-crossposts
) ()
152 (:metaclass backend-class
))
154 (defclass backend-ea-forum
(backend-oauth2.0-login
155 backend-lw2-modernized
157 backend-lw2-misc-features
158 backend-algolia-search
160 backend-related-questions
161 backend-feed-crossposts
163 backend-push-notifications
165 backend-lw2-tags-comments
166 backend-lw2-wiki-tags
167 backend-magnum-crossposts
) ()
168 (:metaclass backend-class
))
170 (defclass backend-progress-forum
(backend-passport-js-login
171 backend-lw2-modernized
173 backend-algolia-search
177 backend-push-notifications
179 backend-lw2-tags-comments
180 backend-lw2-wiki-tags
) ()
181 (:metaclass backend-class
))
183 (defclass backend-accordius
(backend-lw2-legacy backend-lw2-modernized
)
184 ((rest-api-uri :accessor rest-api-uri
:initarg
:rest-api-uri
:type simple-string
))
185 (:metaclass backend-class
))
187 (defclass backend-arbital
(backend-lmdb-cache) ()
188 (:metaclass backend-class
))
190 (defun make-backend (type-string &rest args
)
191 (apply #'make-instance
(symbolicate "BACKEND-" (string-upcase type-string
)) args
))
193 (defun process-operation-definition (args)
194 (let* ((latter-args (member-if #'listp args
))
195 (method-qualifiers (ldiff args latter-args
))
196 (method-args (first latter-args
))
197 (body (rest latter-args
)))
198 (values method-qualifiers method-args body
)))
200 (defun operation-name-and-lambda-list-translator (name)
201 (labels ((setf-lambda-list (backend lambda-list
)
202 `(,(first lambda-list
) (backend ,backend
) ,@(rest lambda-list
)))
203 (ordinary-lambda-list (backend lambda-list
)
204 `((backend ,backend
) ,@lambda-list
)))
206 ((list 'setf
(and (type symbol
) bare-name
))
207 (let* ((inner-bare-name (symbolicate "%" bare-name
))
208 (inner-name (list 'setf inner-bare-name
)))
211 `(defun ,name
(set-value &rest args
) (setf (apply #',inner-bare-name lw2.context
:*current-backend
* args
) set-value
))
215 (let ((inner-name (symbolicate "%" name
)))
217 #'ordinary-lambda-list
218 `(defun ,name
(&rest args
) (apply #',inner-name lw2.context
:*current-backend
* args
))
222 (error "Invalid function name: ~A" name
)))))
224 (defun names-only-lambda-list (lambda-list)
225 (map 'list
(lambda (x) (if (atom x
) x
(first x
))) lambda-list
))
227 (defmacro define-backend-function
(name lambda-list
&rest operations
)
228 (multiple-value-bind (inner-name lambda-list-translator wrapper-defun
bare-name inner-bare-name
)
229 (operation-name-and-lambda-list-translator name
)
230 (let ((lambda-list (names-only-lambda-list lambda-list
))
233 (destructuring-bind (backend &rest body
) op
234 `(:method
,(funcall lambda-list-translator backend lambda-list
) ,@body
)))
237 (export '(,bare-name
,inner-bare-name
))
238 (declaim (inline ,name
))
240 (defgeneric ,inner-name
,(names-only-lambda-list (funcall lambda-list-translator t lambda-list
)) ,.method-definitions
)))))
242 (defmacro define-backend-operation
(name backend
&rest args
)
243 (multiple-value-bind (inner-name lambda-list-translator
) (operation-name-and-lambda-list-translator name
)
244 (multiple-value-bind (method-qualifiers method-args body
) (process-operation-definition args
)
245 `(defmethod ,inner-name
,.method-qualifiers
,(funcall lambda-list-translator backend method-args
) ,@body
))))
247 (defgeneric call-with-backend-context
(backend request fn
)
248 (:method
((backend backend-base
) (request t
) fn
)