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 #: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
  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 call-route-handler ((s site) request-uri)
  55   (call-route-handler (class-of s) request-uri))
  56
  57 (defclass backend-site (site)
  58   ((backend :accessor site-backend :initarg :backend :type backend-base)
  59    (background-loader-enabled :accessor background-loader-enabled :initarg :use-background-loader :initform nil :type boolean))
  60   (:metaclass site-class))
  61
  62 (defclass login-site (backend-site) ()
  63   (:metaclass site-class))
  64
  65 (defclass forum-site (backend-site) ()
  66   (:metaclass site-class))
  67
  68 (defclass wiki-site (backend-site) ()
  69   (:metaclass site-class))
  70
  71 (defclass shortform-site (backend-site) ()
  72   (:metaclass site-class))
  73
  74 (defclass ignore-list-site (login-site) ()
  75   (:metaclass site-class))
  76
  77 (defclass alternate-frontend-site (backend-site)
  78   ((main-site-title :accessor main-site-title :initarg :main-site-title :type simple-string)
  79    (main-site-abbreviation :accessor main-site-abbreviation :initarg :main-site-abbreviation :type simple-string)
  80    (main-site-uri :accessor main-site-uri :initarg :main-site-uri :type simple-string))
  81   (:metaclass site-class))
  82
  83 (defmethod site-link-base ((s alternate-frontend-site)) (main-site-uri s))
  84
  85 (defclass lesswrong-viewer-site (forum-site ignore-list-site login-site alternate-frontend-site shortform-site) ()
  86   (:metaclass site-class))
  87
  88 (defclass ea-forum-viewer-site (forum-site ignore-list-site login-site alternate-frontend-site shortform-site) ()
  89   (:metaclass site-class))
  90
  91 (defclass arbital-site (wiki-site alternate-frontend-site) ()
  92   (:metaclass site-class))
  93
  94 (defmethod host-matches ((site site) host)
  95   (let ((site-host (site-host site)))
  96     (and site-host (string-equal site-host host))))
  97
  98 (defun find-site (host)
  99   (find-if (lambda (site) (host-matches site host))
 100            *sites*))
 101
 102 (defgeneric call-with-site-context (site request fn)
 103   (:method :around ((site site) (request t) fn)
 104     (let ((*current-site* site))
 105       (call-next-method)))
 106   (:method ((site site) (request t) fn)
 107     (funcall fn))
 108   (:method ((site backend-site) request fn)
 109     (let* ((backend (site-backend site))
 110            (*current-backend* backend))
 111       (call-with-backend-context backend request #'call-next-method))))
 112
 113 (defmacro with-site-context ((site &key (request t)) &body body)
 114   `(call-with-site-context ,site ,request (lambda () ,@body)))
 115
 116 (defun reset-site-definitions ()
 117   (setf *sites* nil))
 118
 119 (defmacro define-site (&rest args)
 120   (let* ((class 'site)
 121          (args2
 122            (map-plist (lambda (key val)
 123                         (cond
 124                           ((eq key :class)
 125                            (setf class val)
 126                            nil)
 127                           ((eq key :backend)
 128                            (list key `(make-backend ,@val)))
 129                           ((eq key :uri)
 130                            (let* ((uri (quri:uri val))
 131                                   (scheme (quri:uri-scheme uri))
 132                                   (host (quri:uri-host uri))
 133                                   (port (quri:uri-port uri))
 134                                   (default-port (quri.port:scheme-default-port scheme)))
 135                              (list key val
 136                                    :host (format nil "~A~@[:~A~]"
 137                                                  host
 138                                                  (if (/= default-port port) port))
 139                                    :secure (string-equal "https" scheme))))
 140                           (t (list key val))))
 141                       args)))
 142     `(push (make-instance ',class ,.args2) *sites*)))
 143
 144 (defun define-route (site-class route-class &rest args)
 145   (let ((new-route (apply #'make-instance route-class args)))
 146     (setf (site-class-routes (find-class site-class))
 147           (cons
 148            new-route
 149            (remove (route-name new-route) (site-class-routes (find-class site-class)) :key #'route-name)))))