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