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-arbital
  32     #:make-backend #:define-backend-function #:define-backend-operation #:backend
  33     #:call-with-backend-context)
  34   (:unintern #:declare-backend-function)
  35   (:recycle #:lw2.backend #:lw2.login))
  36
  37 (in-package #:lw2.backend-modules)
  38
  39 (defclass backend-class (standard-class)
  40   ((cached-databases :accessor class-cached-databases :initform nil)
  41    (own-databases :accessor class-own-databases :initform nil)
  42    (databases-epoch :accessor class-databases-epoch :initform 0)))
  43
  44 (defmethod closer-mop:validate-superclass ((c backend-class) (sc standard-class))
  45   t)
  46
  47 (defclass backend-base () () (:metaclass backend-class))
  48
  49 (defclass backend-lmdb-cache (backend-base)
  50   ((lmdb-environment :accessor backend-lmdb-environment :initform nil)
  51    (cache-db-path :accessor backend-cache-db-path :initarg :cache-db-path :type simple-string))
  52   (:metaclass backend-class))
  53
  54 (defclass backend-graphql (backend-lmdb-cache)
  55   ((graphql-uri :accessor graphql-uri :initarg :graphql-uri :type simple-string))
  56   (:metaclass backend-class))
  57
  58 (defclass backend-token-login (backend-base) ()
  59   (:metaclass backend-class))
  60
  61 (defclass backend-password-login (backend-base) ()
  62   (:metaclass backend-class))
  63
  64 (defclass backend-websocket-login (backend-token-login backend-password-login)
  65   ((websocket-uri :accessor websocket-uri :initarg :websocket-uri :type simple-string))
  66   (:metaclass backend-class))
  67
  68 (defclass backend-passport-js-login (backend-token-login backend-password-login) ()
  69   (:metaclass backend-class))
  70
  71 (defclass backend-oauth2.0-login (backend-token-login)
  72   ((oauth2.0-login-uri :accessor oauth2.0-login-uri :initarg :oauth2.0-login-uri :type simple-string)
  73    (oauth2.0-client-id :accessor oauth2.0-client-id :initarg :oauth2.0-client-id :type simple-string)
  74    (oauth2.0-client-secret :accessor oauth2.0-client-secret :initarg :oauth2.0-client-secret :type simple-string))
  75   (:metaclass backend-class))
  76
  77 (defclass backend-algolia-search (backend-base)
  78   ((algolia-search-uri :accessor algolia-search-uri :initarg :algolia-search-uri :type simple-string))
  79   (:metaclass backend-class))
  80
  81 (defclass backend-feed-crossposts (backend-graphql) ()
  82   (:metaclass backend-class))
  83
  84 (defclass backend-q-and-a (backend-graphql) ()
  85   (:metaclass backend-class))
  86
  87 (defclass backend-related-questions (backend-graphql) ()
  88   (:metaclass backend-class))
  89
  90 (defclass backend-debates (backend-graphql) ()
  91   (:metaclass backend-class))
  92
  93 (defclass backend-backlinks (backend-lmdb-cache) ()
  94   (:metaclass backend-class))
  95
  96 (defclass backend-push-notifications (backend-lmdb-cache) ()
  97   (:metaclass backend-class))
  98
  99 (defclass backend-alignment-forum (backend-graphql) ()
 100   (:metaclass backend-class))
 101
 102 (defclass backend-events (backend-graphql) ()
 103   (:metaclass backend-class))
 104
 105 (defclass backend-shortform (backend-graphql) ()
 106   (:metaclass backend-class))
 107
 108 (defclass backend-lw2-tags (backend-graphql) ()
 109   (:metaclass backend-class))
 110
 111 (defclass backend-lw2-tags-comments (backend-lw2-tags) ()
 112   (:metaclass backend-class))
 113
 114 (defclass backend-magnum-crossposts (backend-graphql)
 115   ((magnum-crosspost-site :accessor backend-magnum-crosspost-site :initarg :magnum-crosspost-site :type (or simple-string null) :initform nil))
 116   (:metaclass backend-class))
 117
 118 (defclass backend-lw2-wiki-tags (backend-lw2-tags) ()
 119   (:metaclass backend-class))
 120
 121 (defclass backend-lw2-misc-workarounds (backend-graphql) ()
 122   (:metaclass backend-class))
 123
 124 (defclass backend-lw2-misc-features (backend-graphql) ()
 125   (:metaclass backend-class))
 126
 127 (defclass backend-lw2-legacy (backend-graphql) ()
 128   (:metaclass backend-class))
 129
 130 (defclass backend-lw2-modernized (backend-graphql) ()
 131   (:metaclass backend-class))
 132
 133 (defclass backend-lw2 (backend-passport-js-login
 134                        backend-lw2-modernized
 135                        backend-lw2-legacy
 136                        backend-lw2-misc-workarounds
 137                        backend-lw2-misc-features
 138                        backend-algolia-search
 139                        backend-q-and-a
 140                        backend-related-questions
 141                        backend-debates
 142                        backend-alignment-forum
 143                        backend-events
 144                        backend-feed-crossposts
 145                        backend-backlinks
 146                        backend-push-notifications
 147                        backend-shortform
 148                        backend-lw2-tags-comments
 149                        backend-lw2-wiki-tags
 150                        backend-magnum-crossposts) ()
 151   (:metaclass backend-class))
 152
 153 (defclass backend-ea-forum (backend-oauth2.0-login
 154                             backend-lw2-modernized
 155                             backend-lw2-legacy
 156                             backend-lw2-misc-features
 157                             backend-algolia-search
 158                             backend-q-and-a
 159                             backend-related-questions
 160                             backend-feed-crossposts
 161                             backend-backlinks
 162                             backend-push-notifications
 163                             backend-shortform
 164                             backend-lw2-tags-comments
 165                             backend-lw2-wiki-tags
 166                             backend-magnum-crossposts) ()
 167   (:metaclass backend-class))
 168
 169 (defclass backend-accordius (backend-lw2-legacy backend-lw2-modernized)
 170   ((rest-api-uri :accessor rest-api-uri :initarg :rest-api-uri :type simple-string))
 171   (:metaclass backend-class))
 172
 173 (defclass backend-arbital (backend-lmdb-cache) ()
 174   (:metaclass backend-class))
 175
 176 (defun make-backend (type-string &rest args)
 177   (apply #'make-instance (symbolicate "BACKEND-" (string-upcase type-string)) args))
 178
 179 (defun process-operation-definition (args)
 180   (let* ((latter-args (member-if #'listp args))
 181          (method-qualifiers (ldiff args latter-args))
 182          (method-args (first latter-args))
 183          (body (rest latter-args)))
 184     (values method-qualifiers method-args body)))
 185
 186 (defun operation-name-and-lambda-list-translator (name)
 187   (labels ((setf-lambda-list (backend lambda-list)
 188              `(,(first lambda-list) (backend ,backend) ,@(rest lambda-list)))
 189            (ordinary-lambda-list (backend lambda-list)
 190              `((backend ,backend) ,@lambda-list)))
 191     (trivia:match name
 192                   ((list 'setf (and (type symbol) bare-name))
 193                    (let* ((inner-bare-name (symbolicate "%" bare-name))
 194                           (inner-name (list 'setf inner-bare-name)))
 195                      (values inner-name
 196                              #'setf-lambda-list
 197                              `(defun ,name (set-value &rest args) (setf (apply #',inner-bare-name lw2.context:*current-backend* args) set-value))
 198                              bare-name
 199                              inner-bare-name)))
 200                   ((type symbol)
 201                    (let ((inner-name (symbolicate "%" name)))
 202                      (values inner-name
 203                              #'ordinary-lambda-list
 204                              `(defun ,name (&rest args) (apply #',inner-name lw2.context:*current-backend* args))
 205                              name
 206                              inner-name)))
 207                   (_
 208                    (error "Invalid function name: ~A" name)))))
 209
 210 (defun names-only-lambda-list (lambda-list)
 211   (map 'list (lambda (x) (if (atom x) x (first x))) lambda-list))
 212
 213 (defmacro define-backend-function (name lambda-list &rest operations)
 214   (multiple-value-bind (inner-name lambda-list-translator wrapper-defun bare-name inner-bare-name)
 215       (operation-name-and-lambda-list-translator name)
 216   (let ((lambda-list (names-only-lambda-list lambda-list))
 217         (method-definitions
 218          (mapcar (lambda (op)
 219                    (destructuring-bind (backend &rest body) op
 220                      `(:method ,(funcall lambda-list-translator backend lambda-list) ,@body)))
 221                  operations)))
 222    `(progn
 223       (export '(,bare-name ,inner-bare-name))
 224       (declaim (inline ,name))
 225       ,wrapper-defun
 226       (defgeneric ,inner-name ,(names-only-lambda-list (funcall lambda-list-translator t lambda-list)) ,.method-definitions)))))
 227
 228 (defmacro define-backend-operation (name backend &rest args)
 229   (multiple-value-bind (inner-name lambda-list-translator) (operation-name-and-lambda-list-translator name)
 230     (multiple-value-bind (method-qualifiers method-args body) (process-operation-definition args)
 231       `(defmethod ,inner-name ,.method-qualifiers ,(funcall lambda-list-translator backend method-args) ,@body))))
 232
 233 (defgeneric call-with-backend-context (backend request fn)
 234   (:method ((backend backend-base) (request t) fn)
 235     (funcall fn)))