src/backend-modules.lisp

   1 (uiop:define-package #:lw2.backend-modules
   2   (:use #:cl)
   3   (:import-from #:alexandria #:symbolicate)
   4   (:export
   5     #:backend-class #:class-cached-databases #:class-own-databases #:class-databases-epoch
   6     #:backend-base
   7     #:backend-lmdb-cache #:backend-lmdb-environment #:backend-cache-db-path
   8     #:backend-graphql
   9     #:backend-token-login
  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
  18     #:backend-debates
  19     #:backend-alignment-forum
  20     #:backend-events
  21     #:backend-shortform
  22     #:backend-backlinks
  23     #:backend-push-notifications
  24     #:backend-lw2-tags
  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
  32     #:backend-arbital
  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))
  37
  38 (in-package #:lw2.backend-modules)
  39
  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)))
  44
  45 (defmethod closer-mop:validate-superclass ((c backend-class) (sc standard-class))
  46   t)
  47
  48 (defclass backend-base () () (:metaclass backend-class))
  49
  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))
  54
  55 (defclass backend-graphql (backend-lmdb-cache)
  56   ((graphql-uri :accessor graphql-uri :initarg :graphql-uri :type simple-string))
  57   (:metaclass backend-class))
  58
  59 (defclass backend-token-login (backend-base) ()
  60   (:metaclass backend-class))
  61
  62 (defclass backend-password-login (backend-base) ()
  63   (:metaclass backend-class))
  64
  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))
  68
  69 (defclass backend-passport-js-login (backend-token-login backend-password-login) ()
  70   (:metaclass backend-class))
  71
  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))
  77
  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))
  81
  82 (defclass backend-feed-crossposts (backend-graphql) ()
  83   (:metaclass backend-class))
  84
  85 (defclass backend-q-and-a (backend-graphql) ()
  86   (:metaclass backend-class))
  87
  88 (defclass backend-related-questions (backend-graphql) ()
  89   (:metaclass backend-class))
  90
  91 (defclass backend-debates (backend-graphql) ()
  92   (:metaclass backend-class))
  93
  94 (defclass backend-backlinks (backend-lmdb-cache) ()
  95   (:metaclass backend-class))
  96
  97 (defclass backend-push-notifications (backend-lmdb-cache) ()
  98   (:metaclass backend-class))
  99
 100 (defclass backend-alignment-forum (backend-graphql) ()
 101   (:metaclass backend-class))
 102
 103 (defclass backend-events (backend-graphql) ()
 104   (:metaclass backend-class))
 105
 106 (defclass backend-shortform (backend-graphql) ()
 107   (:metaclass backend-class))
 108
 109 (defclass backend-lw2-tags (backend-graphql) ()
 110   (:metaclass backend-class))
 111
 112 (defclass backend-lw2-tags-comments (backend-lw2-tags) ()
 113   (:metaclass backend-class))
 114
 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))
 118
 119 (defclass backend-lw2-wiki-tags (backend-lw2-tags) ()
 120   (:metaclass backend-class))
 121
 122 (defclass backend-lw2-misc-workarounds (backend-graphql) ()
 123   (:metaclass backend-class))
 124
 125 (defclass backend-lw2-misc-features (backend-graphql) ()
 126   (:metaclass backend-class))
 127
 128 (defclass backend-lw2-legacy (backend-graphql) ()
 129   (:metaclass backend-class))
 130
 131 (defclass backend-lw2-modernized (backend-graphql) ()
 132   (:metaclass backend-class))
 133
 134 (defclass backend-lw2 (backend-passport-js-login
 135                        backend-lw2-modernized
 136                        backend-lw2-legacy
 137                        backend-lw2-misc-workarounds
 138                        backend-lw2-misc-features
 139                        backend-algolia-search
 140                        backend-q-and-a
 141                        backend-related-questions
 142                        backend-debates
 143                        backend-alignment-forum
 144                        backend-events
 145                        backend-feed-crossposts
 146                        backend-backlinks
 147                        backend-push-notifications
 148                        backend-shortform
 149                        backend-lw2-tags-comments
 150                        backend-lw2-wiki-tags
 151                        backend-magnum-crossposts) ()
 152   (:metaclass backend-class))
 153
 154 (defclass backend-ea-forum (backend-oauth2.0-login
 155                             backend-lw2-modernized
 156                             backend-lw2-legacy
 157                             backend-lw2-misc-features
 158                             backend-algolia-search
 159                             backend-q-and-a
 160                             backend-related-questions
 161                             backend-feed-crossposts
 162                             backend-backlinks
 163                             backend-push-notifications
 164                             backend-shortform
 165                             backend-lw2-tags-comments
 166                             backend-lw2-wiki-tags
 167                             backend-magnum-crossposts) ()
 168   (:metaclass backend-class))
 169
 170 (defclass backend-progress-forum (backend-passport-js-login
 171                                   backend-lw2-modernized
 172                                   backend-lw2-legacy
 173                                   backend-algolia-search
 174                                   backend-q-and-a
 175                                   backend-events
 176                                   backend-backlinks
 177                                   backend-push-notifications
 178                                   backend-shortform
 179                                   backend-lw2-tags-comments
 180                                   backend-lw2-wiki-tags) ()
 181   (:metaclass backend-class))
 182
 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))
 186
 187 (defclass backend-arbital (backend-lmdb-cache) ()
 188   (:metaclass backend-class))
 189
 190 (defun make-backend (type-string &rest args)
 191   (apply #'make-instance (symbolicate "BACKEND-" (string-upcase type-string)) args))
 192
 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)))
 199
 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)))
 205     (trivia:match name
 206                   ((list 'setf (and (type symbol) bare-name))
 207                    (let* ((inner-bare-name (symbolicate "%" bare-name))
 208                           (inner-name (list 'setf inner-bare-name)))
 209                      (values inner-name
 210                              #'setf-lambda-list
 211                              `(defun ,name (set-value &rest args) (setf (apply #',inner-bare-name lw2.context:*current-backend* args) set-value))
 212                              bare-name
 213                              inner-bare-name)))
 214                   ((type symbol)
 215                    (let ((inner-name (symbolicate "%" name)))
 216                      (values inner-name
 217                              #'ordinary-lambda-list
 218                              `(defun ,name (&rest args) (apply #',inner-name lw2.context:*current-backend* args))
 219                              name
 220                              inner-name)))
 221                   (_
 222                    (error "Invalid function name: ~A" name)))))
 223
 224 (defun names-only-lambda-list (lambda-list)
 225   (map 'list (lambda (x) (if (atom x) x (first x))) lambda-list))
 226
 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))
 231         (method-definitions
 232          (mapcar (lambda (op)
 233                    (destructuring-bind (backend &rest body) op
 234                      `(:method ,(funcall lambda-list-translator backend lambda-list) ,@body)))
 235                  operations)))
 236    `(progn
 237       (export '(,bare-name ,inner-bare-name))
 238       (declaim (inline ,name))
 239       ,wrapper-defun
 240       (defgeneric ,inner-name ,(names-only-lambda-list (funcall lambda-list-translator t lambda-list)) ,.method-definitions)))))
 241
 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))))
 246
 247 (defgeneric call-with-backend-context (backend request fn)
 248   (:method ((backend backend-base) (request t) fn)
 249     (funcall fn)))