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-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
  16     #:backend-events
  17     #:backend-shortform
  18     #:backend-backlinks
  19     #:backend-push-notifications
  20     #:backend-lw2-tags
  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
  27     #:backend-arbital
  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))
  32
  33 (in-package #:lw2.backend-modules)
  34
  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)))
  39
  40 (defmethod closer-mop:validate-superclass ((c backend-class) (sc standard-class))
  41   t)
  42
  43 (defclass backend-base () () (:metaclass backend-class))
  44
  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))
  49
  50 (defclass backend-graphql (backend-lmdb-cache)
  51   ((graphql-uri :accessor graphql-uri :initarg :graphql-uri :type simple-string))
  52   (:metaclass backend-class))
  53
  54 (defclass backend-token-login (backend-base) ()
  55   (:metaclass backend-class))
  56
  57 (defclass backend-websocket-login (backend-token-login)
  58   ((websocket-uri :accessor websocket-uri :initarg :websocket-uri :type simple-string))
  59   (:metaclass backend-class))
  60
  61 (defclass backend-passport-js-login (backend-token-login) ()
  62   (:metaclass backend-class))
  63
  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))
  67
  68 (defclass backend-feed-crossposts (backend-graphql) ()
  69   (:metaclass backend-class))
  70
  71 (defclass backend-q-and-a (backend-graphql) ()
  72   (:metaclass backend-class))
  73
  74 (defclass backend-related-questions (backend-graphql) ()
  75   (:metaclass backend-class))
  76
  77 (defclass backend-backlinks (backend-lmdb-cache) ()
  78   (:metaclass backend-class))
  79
  80 (defclass backend-push-notifications (backend-lmdb-cache) ()
  81   (:metaclass backend-class))
  82
  83 (defclass backend-alignment-forum (backend-graphql) ()
  84   (:metaclass backend-class))
  85
  86 (defclass backend-events (backend-graphql) ()
  87   (:metaclass backend-class))
  88
  89 (defclass backend-shortform (backend-graphql) ()
  90   (:metaclass backend-class))
  91
  92 (defclass backend-lw2-tags (backend-graphql) ()
  93   (:metaclass backend-class))
  94
  95 (defclass backend-lw2-tags-comments (backend-lw2-tags) ()
  96   (:metaclass backend-class))
  97
  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))
 101
 102 (defclass backend-lw2-wiki-tags (backend-lw2-tags) ()
 103   (:metaclass backend-class))
 104
 105 (defclass backend-lw2-misc-workarounds (backend-graphql) ()
 106   (:metaclass backend-class))
 107
 108 (defclass backend-lw2-misc-features (backend-graphql) ()
 109   (:metaclass backend-class))
 110
 111 (defclass backend-lw2-legacy (backend-graphql) ()
 112   (:metaclass backend-class))
 113
 114 (defclass backend-lw2-modernized (backend-graphql) ()
 115   (:metaclass backend-class))
 116
 117 (defclass backend-lw2 (backend-passport-js-login
 118                        backend-lw2-modernized
 119                        backend-lw2-legacy
 120                        backend-lw2-misc-workarounds
 121                        backend-lw2-misc-features
 122                        backend-algolia-search
 123                        backend-q-and-a
 124                        backend-related-questions
 125                        backend-alignment-forum
 126                        backend-events
 127                        backend-feed-crossposts
 128                        backend-backlinks
 129                        backend-push-notifications
 130                        backend-shortform
 131                        backend-lw2-tags-comments
 132                        backend-lw2-wiki-tags
 133                        backend-magnum-crossposts) ()
 134   (:metaclass backend-class))
 135
 136 (defclass backend-ea-forum (backend-passport-js-login
 137                             backend-lw2-modernized
 138                             backend-lw2-legacy
 139                             backend-lw2-misc-features
 140                             backend-algolia-search
 141                             backend-q-and-a
 142                             backend-related-questions
 143                             backend-feed-crossposts
 144                             backend-backlinks
 145                             backend-push-notifications
 146                             backend-shortform
 147                             backend-lw2-tags-comments
 148                             backend-lw2-wiki-tags
 149                             backend-magnum-crossposts) ()
 150   (:metaclass backend-class))
 151
 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))
 155
 156 (defclass backend-arbital (backend-lmdb-cache) ()
 157   (:metaclass backend-class))
 158
 159 (defun make-backend (type-string &rest args)
 160   (apply #'make-instance (symbolicate "BACKEND-" (string-upcase type-string)) args))
 161
 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)))
 168
 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)))
 174     (trivia:match name
 175                   ((list 'setf (and (type symbol) bare-name))
 176                    (let* ((inner-bare-name (symbolicate "%" bare-name))
 177                           (inner-name (list 'setf inner-bare-name)))
 178                      (values inner-name
 179                              #'setf-lambda-list
 180                              `(defun ,name (set-value &rest args) (setf (apply #',inner-bare-name lw2.context:*current-backend* args) set-value))
 181                              bare-name
 182                              inner-bare-name)))
 183                   ((type symbol)
 184                    (let ((inner-name (symbolicate "%" name)))
 185                      (values inner-name
 186                              #'ordinary-lambda-list
 187                              `(defun ,name (&rest args) (apply #',inner-name lw2.context:*current-backend* args))
 188                              name
 189                              inner-name)))
 190                   (_
 191                    (error "Invalid function name: ~A" name)))))
 192
 193 (defun names-only-lambda-list (lambda-list)
 194   (map 'list (lambda (x) (if (atom x) x (first x))) lambda-list))
 195
 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))
 200         (method-definitions
 201          (mapcar (lambda (op)
 202                    (destructuring-bind (backend &rest body) op
 203                      `(:method ,(funcall lambda-list-translator backend lambda-list) ,@body)))
 204                  operations)))
 205    `(progn
 206       (export '(,bare-name ,inner-bare-name))
 207       (declaim (inline ,name))
 208       ,wrapper-defun
 209       (defgeneric ,inner-name ,(names-only-lambda-list (funcall lambda-list-translator t lambda-list)) ,.method-definitions)))))
 210
 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))))
 215
 216 (defgeneric call-with-backend-context (backend request fn)
 217   (:method ((backend backend-base) (request t) fn)
 218     (funcall fn)))