src/sites.lisp

   1 (uiop:define-package #:lw2.sites
   2   (:use #:cl #:lw2.utils #:lw2.context #:lw2.routes #:lw2.backend-modules #:lw2.fonts-modules)
   3   (:import-from #:sb-ext #:defglobal)
   4   (:export
   5     #:*sites*
   6     #:site #:forum-site #:wiki-site
   7     #:login-site #:basic-login-site #:oidc-login-site
   8     #:shortform-site #:ignore-list-site
   9     #:alternate-frontend-site #:lw2-frontend-site #:lesswrong-viewer-site #:ea-forum-viewer-site
  10     #:progress-forum-site
  11     #:arbital-site
  12     #:site-class #:call-route-handler #:site-class-routes
  13     #:site-uri #:site-host #:site-domain #:site-link-base #:site-secure #:site-backend #:site-title #:site-description #:background-loader-enabled #:site-fonts-source
  14     #:main-site-title #:main-site-abbreviation #:main-site-uri #:always-canonical
  15     #:host-matches #:find-site
  16     #:call-with-site-context #:with-site-context
  17     #:reset-site-definitions
  18     #:define-site
  19     #:define-route))
  20
  21 (in-package #:lw2.sites)
  22
  23 (defglobal *sites* nil)
  24
  25 (defclass site-class (standard-class)
  26   ((routes :accessor site-class-routes :initform nil)))
  27
  28 (defmethod closer-mop:validate-superclass ((c site-class) (sc standard-class))
  29   t)
  30
  31 (defmethod site-class-routes ((c t))
  32   nil)
  33
  34 (defmethod call-route-handler ((original-class site-class) request-uri)
  35   (dolist (class (closer-mop:class-precedence-list original-class))
  36     (dolist (route (site-class-routes class))
  37       (when (execute-route route request-uri)
  38         (return-from call-route-handler t)))))
  39
  40 (defclass site ()
  41   ((uri :accessor site-uri :initarg :uri :type simple-string)
  42    (host :accessor site-host :initarg :host :type simple-string)
  43    (domain :accessor site-domain :initarg :domain :initform nil)
  44    (secure :accessor site-secure :initarg :secure)
  45    (title :accessor site-title :initarg :title :type simple-string)
  46    (description :accessor site-description :initarg :description :type simple-string)
  47    (fonts-source :accessor site-fonts-source :initarg :fonts-source :initform (make-instance 'google-fonts-source) :type fonts-source))
  48   (:metaclass site-class))
  49
  50 (defmethod main-site-title ((s site)) nil)
  51
  52 (defmethod main-site-abbreviation ((s site)) nil)
  53
  54 (defmethod site-link-base ((s site)) (site-uri s))
  55
  56 (defmethod always-canonical ((s site)) nil)
  57
  58 (defmethod call-route-handler ((s site) request-uri)
  59   (call-route-handler (class-of s) request-uri))
  60
  61 (defclass backend-site (site)
  62   ((backend :accessor site-backend :initarg :backend :type backend-base)
  63    (background-loader-enabled :accessor background-loader-enabled :initarg :use-background-loader :initform nil :type boolean))
  64   (:metaclass site-class))
  65
  66 (defclass login-site (backend-site) ()
  67   (:metaclass site-class))
  68
  69 (defclass forum-site (backend-site) ()
  70   (:metaclass site-class))
  71
  72 (defclass wiki-site (backend-site) ()
  73   (:metaclass site-class))
  74
  75 (defclass shortform-site (backend-site) ()
  76   (:metaclass site-class))
  77
  78 (defclass ignore-list-site (login-site) ()
  79   (:metaclass site-class))
  80
  81 (defclass alternate-frontend-site (backend-site)
  82   ((main-site-title :accessor main-site-title :initarg :main-site-title :type simple-string)
  83    (main-site-abbreviation :accessor main-site-abbreviation :initarg :main-site-abbreviation :type simple-string)
  84    (main-site-uri :accessor main-site-uri :initarg :main-site-uri :type simple-string)
  85    (always-canonical :accessor always-canonical :initarg :always-canonical :initform nil :type boolean))
  86   (:metaclass site-class))
  87
  88 (defmethod site-link-base ((s alternate-frontend-site)) (main-site-uri s))
  89
  90 (defclass lw2-frontend-site (alternate-frontend-site) ()
  91   (:metaclass site-class))
  92
  93 (defclass lesswrong-viewer-site (forum-site ignore-list-site login-site lw2-frontend-site shortform-site) ()
  94   (:metaclass site-class))
  95
  96 (defclass ea-forum-viewer-site (forum-site ignore-list-site login-site lw2-frontend-site shortform-site) ()
  97   (:metaclass site-class))
  98
  99 (defclass progress-forum-viewer-site (forum-site ignore-list-site login-site lw2-frontend-site shortform-site) ()
 100   (:metaclass site-class))
 101
 102 (defclass arbital-site (wiki-site alternate-frontend-site) ()
 103   (:metaclass site-class))
 104
 105 (defmethod host-matches ((site site) host)
 106   (let ((site-host (site-host site)))
 107     (and site-host (string-equal site-host host))))
 108
 109 (defun find-site (host)
 110   (find-if (lambda (site) (host-matches site host))
 111            *sites*))
 112
 113 (defgeneric call-with-site-context (site request fn)
 114   (:method :around ((site site) (request t) fn)
 115     (let ((*current-site* site))
 116       (call-next-method)))
 117   (:method ((site site) (request t) fn)
 118     (funcall fn))
 119   (:method ((site backend-site) request fn)
 120     (let* ((backend (site-backend site))
 121            (*current-backend* backend))
 122       (call-with-backend-context backend request #'call-next-method))))
 123
 124 (defmacro with-site-context ((site &key (request t)) &body body)
 125   `(call-with-site-context ,site ,request (lambda () ,@body)))
 126
 127 (defun reset-site-definitions ()
 128   (setf *sites* nil))
 129
 130 (defmacro define-site (&rest args)
 131   (let* ((class 'site)
 132          (args2
 133            (map-plist (lambda (key val)
 134                         (cond
 135                           ((eq key :class)
 136                            (setf class val)
 137                            nil)
 138                           ((eq key :backend)
 139                            (list key `(make-backend ,@val)))
 140                           ((eq key :uri)
 141                            (let* ((uri (quri:uri val))
 142                                   (scheme (quri:uri-scheme uri))
 143                                   (host (quri:uri-host uri))
 144                                   (port (quri:uri-port uri))
 145                                   (default-port (quri.port:scheme-default-port scheme)))
 146                              (list key val
 147                                    :host (format nil "~A~@[:~A~]"
 148                                                  host
 149                                                  (if (/= default-port port) port))
 150                                    :secure (string-equal "https" scheme))))
 151                           (t (list key val))))
 152                       args)))
 153     `(push (make-instance ',class ,.args2) *sites*)))
 154
 155 (defun define-route (site-class route-class &rest args)
 156   (let ((new-route (apply #'make-instance route-class args)))
 157     (setf (site-class-routes (find-class site-class))
 158           (cons
 159            new-route
 160            (remove (route-name new-route) (site-class-routes (find-class site-class)) :key #'route-name)))))