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-websocket-login
11 #:backend-passport-js-login
12 #:graphql-uri
#:websocket-uri
#:algolia-search-uri
#:rest-api-uri
13 #:backend-feed-crossposts
14 #:backend-q-and-a
#:backend-related-questions
15 #:backend-alignment-forum
19 #:backend-push-notifications
21 #:backend-lw2-tags-comments
22 #:backend-lw2-wiki-tags
23 #:backend-magnum-crossposts
#:backend-magnum-crosspost-site
24 #:backend-lw2-misc-workarounds
25 #:backend-lw2-misc-features
26 #:backend-lw2-legacy
#:backend-lw2-modernized
#:backend-lw2
#:backend-algolia-search
#:backend-ea-forum
#:backend-accordius
28 #:make-backend
#:define-backend-function
#:define-backend-operation
#:backend
29 #:call-with-backend-context
)
30 (:unintern
#:declare-backend-function
)
31 (:recycle
#:lw2.backend
#:lw2.login
))
33 (in-package #:lw2.backend-modules
)
35 (defclass backend-class
(standard-class)
36 ((cached-databases :accessor class-cached-databases
:initform nil
)
37 (own-databases :accessor class-own-databases
:initform nil
)
38 (databases-epoch :accessor class-databases-epoch
:initform
0)))
40 (defmethod closer-mop:validate-superclass
((c backend-class
) (sc standard-class
))
43 (defclass backend-base
() () (:metaclass backend-class
))
45 (defclass backend-lmdb-cache
(backend-base)
46 ((lmdb-environment :accessor backend-lmdb-environment
:initform nil
)
47 (cache-db-path :accessor backend-cache-db-path
:initarg
:cache-db-path
:type simple-string
))
48 (:metaclass backend-class
))
50 (defclass backend-graphql
(backend-lmdb-cache)
51 ((graphql-uri :accessor graphql-uri
:initarg
:graphql-uri
:type simple-string
))
52 (:metaclass backend-class
))
54 (defclass backend-token-login
(backend-base) ()
55 (:metaclass backend-class
))
57 (defclass backend-websocket-login
(backend-token-login)
58 ((websocket-uri :accessor websocket-uri
:initarg
:websocket-uri
:type simple-string
))
59 (:metaclass backend-class
))
61 (defclass backend-passport-js-login
(backend-token-login) ()
62 (:metaclass backend-class
))
64 (defclass backend-algolia-search
(backend-base)
65 ((algolia-search-uri :accessor algolia-search-uri
:initarg
:algolia-search-uri
:type simple-string
))
66 (:metaclass backend-class
))
68 (defclass backend-feed-crossposts
(backend-graphql) ()
69 (:metaclass backend-class
))
71 (defclass backend-q-and-a
(backend-graphql) ()
72 (:metaclass backend-class
))
74 (defclass backend-related-questions
(backend-graphql) ()
75 (:metaclass backend-class
))
77 (defclass backend-backlinks
(backend-lmdb-cache) ()
78 (:metaclass backend-class
))
80 (defclass backend-push-notifications
(backend-lmdb-cache) ()
81 (:metaclass backend-class
))
83 (defclass backend-alignment-forum
(backend-graphql) ()
84 (:metaclass backend-class
))
86 (defclass backend-events
(backend-graphql) ()
87 (:metaclass backend-class
))
89 (defclass backend-shortform
(backend-graphql) ()
90 (:metaclass backend-class
))
92 (defclass backend-lw2-tags
(backend-graphql) ()
93 (:metaclass backend-class
))
95 (defclass backend-lw2-tags-comments
(backend-lw2-tags) ()
96 (:metaclass backend-class
))
98 (defclass backend-magnum-crossposts
(backend-graphql)
99 ((magnum-crosspost-site :accessor backend-magnum-crosspost-site
:initarg
:magnum-crosspost-site
:type
(or simple-string null
) :initform nil
))
100 (:metaclass backend-class
))
102 (defclass backend-lw2-wiki-tags
(backend-lw2-tags) ()
103 (:metaclass backend-class
))
105 (defclass backend-lw2-misc-workarounds
(backend-graphql) ()
106 (:metaclass backend-class
))
108 (defclass backend-lw2-misc-features
(backend-graphql) ()
109 (:metaclass backend-class
))
111 (defclass backend-lw2-legacy
(backend-graphql) ()
112 (:metaclass backend-class
))
114 (defclass backend-lw2-modernized
(backend-graphql) ()
115 (:metaclass backend-class
))
117 (defclass backend-lw2
(backend-passport-js-login
118 backend-lw2-modernized
120 backend-lw2-misc-workarounds
121 backend-lw2-misc-features
122 backend-algolia-search
124 backend-related-questions
125 backend-alignment-forum
127 backend-feed-crossposts
129 backend-push-notifications
131 backend-lw2-tags-comments
132 backend-lw2-wiki-tags
133 backend-magnum-crossposts
) ()
134 (:metaclass backend-class
))
136 (defclass backend-ea-forum
(backend-passport-js-login
137 backend-lw2-modernized
139 backend-lw2-misc-features
140 backend-algolia-search
142 backend-related-questions
143 backend-feed-crossposts
145 backend-push-notifications
147 backend-lw2-tags-comments
148 backend-lw2-wiki-tags
149 backend-magnum-crossposts
) ()
150 (:metaclass backend-class
))
152 (defclass backend-accordius
(backend-lw2-legacy backend-lw2-modernized
)
153 ((rest-api-uri :accessor rest-api-uri
:initarg
:rest-api-uri
:type simple-string
))
154 (:metaclass backend-class
))
156 (defclass backend-arbital
(backend-lmdb-cache) ()
157 (:metaclass backend-class
))
159 (defun make-backend (type-string &rest args
)
160 (apply #'make-instance
(symbolicate "BACKEND-" (string-upcase type-string
)) args
))
162 (defun process-operation-definition (args)
163 (let* ((latter-args (member-if #'listp args
))
164 (method-qualifiers (ldiff args latter-args
))
165 (method-args (first latter-args
))
166 (body (rest latter-args
)))
167 (values method-qualifiers method-args body
)))
169 (defun operation-name-and-lambda-list-translator (name)
170 (labels ((setf-lambda-list (backend lambda-list
)
171 `(,(first lambda-list
) (backend ,backend
) ,@(rest lambda-list
)))
172 (ordinary-lambda-list (backend lambda-list
)
173 `((backend ,backend
) ,@lambda-list
)))
175 ((list 'setf
(and (type symbol
) bare-name
))
176 (let* ((inner-bare-name (symbolicate "%" bare-name
))
177 (inner-name (list 'setf inner-bare-name
)))
180 `(defun ,name
(set-value &rest args
) (setf (apply #',inner-bare-name lw2.context
:*current-backend
* args
) set-value
))
184 (let ((inner-name (symbolicate "%" name
)))
186 #'ordinary-lambda-list
187 `(defun ,name
(&rest args
) (apply #',inner-name lw2.context
:*current-backend
* args
))
191 (error "Invalid function name: ~A" name
)))))
193 (defun names-only-lambda-list (lambda-list)
194 (map 'list
(lambda (x) (if (atom x
) x
(first x
))) lambda-list
))
196 (defmacro define-backend-function
(name lambda-list
&rest operations
)
197 (multiple-value-bind (inner-name lambda-list-translator wrapper-defun
bare-name inner-bare-name
)
198 (operation-name-and-lambda-list-translator name
)
199 (let ((lambda-list (names-only-lambda-list lambda-list
))
202 (destructuring-bind (backend &rest body
) op
203 `(:method
,(funcall lambda-list-translator backend lambda-list
) ,@body
)))
206 (export '(,bare-name
,inner-bare-name
))
207 (declaim (inline ,name
))
209 (defgeneric ,inner-name
,(names-only-lambda-list (funcall lambda-list-translator t lambda-list
)) ,.method-definitions
)))))
211 (defmacro define-backend-operation
(name backend
&rest args
)
212 (multiple-value-bind (inner-name lambda-list-translator
) (operation-name-and-lambda-list-translator name
)
213 (multiple-value-bind (method-qualifiers method-args body
) (process-operation-definition args
)
214 `(defmethod ,inner-name
,.method-qualifiers
,(funcall lambda-list-translator backend method-args
) ,@body
))))
216 (defgeneric call-with-backend-context
(backend request fn
)
217 (:method
((backend backend-base
) (request t
) fn
)