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