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
)
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
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
19 (in-package #:lw2.sites
)
21 (defglobal *sites
* nil
)
23 (defclass site-class
(standard-class)
24 ((routes :accessor site-class-routes
:initform nil
)))
26 (defmethod closer-mop:validate-superclass
((c site-class
) (sc standard-class
))
29 (defmethod site-class-routes ((c t
))
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
)))))
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
))
48 (defmethod main-site-title ((s site
)) nil
)
50 (defmethod main-site-abbreviation ((s site
)) nil
)
52 (defmethod site-link-base ((s site
)) (site-uri s
))
54 (defmethod always-canonical ((s site
)) nil
)
56 (defmethod call-route-handler ((s site
) request-uri
)
57 (call-route-handler (class-of s
) request-uri
))
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
))
64 (defclass login-site
(backend-site) ()
65 (:metaclass site-class
))
67 (defclass forum-site
(backend-site) ()
68 (:metaclass site-class
))
70 (defclass wiki-site
(backend-site) ()
71 (:metaclass site-class
))
73 (defclass shortform-site
(backend-site) ()
74 (:metaclass site-class
))
76 (defclass ignore-list-site
(login-site) ()
77 (:metaclass site-class
))
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
))
86 (defmethod site-link-base ((s alternate-frontend-site
)) (main-site-uri s
))
88 (defclass lw2-frontend-site
(alternate-frontend-site) ()
89 (:metaclass site-class
))
91 (defclass lesswrong-viewer-site
(forum-site ignore-list-site login-site lw2-frontend-site shortform-site
) ()
92 (:metaclass site-class
))
94 (defclass ea-forum-viewer-site
(forum-site ignore-list-site login-site lw2-frontend-site shortform-site
) ()
95 (:metaclass site-class
))
97 (defclass arbital-site
(wiki-site alternate-frontend-site
) ()
98 (:metaclass site-class
))
100 (defmethod host-matches ((site site
) host
)
101 (let ((site-host (site-host site
)))
102 (and site-host
(string-equal site-host host
))))
104 (defun find-site (host)
105 (find-if (lambda (site) (host-matches site host
))
108 (defgeneric call-with-site-context
(site request fn
)
109 (:method
:around
((site site
) (request t
) fn
)
110 (let ((*current-site
* site
))
112 (:method
((site site
) (request t
) 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
))))
119 (defmacro with-site-context
((site &key
(request t
)) &body body
)
120 `(call-with-site-context ,site
,request
(lambda () ,@body
)))
122 (defun reset-site-definitions ()
125 (defmacro define-site
(&rest args
)
128 (map-plist (lambda (key val
)
134 (list key
`(make-backend ,@val
)))
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
)))
142 :host
(format nil
"~A~@[:~A~]"
144 (if (/= default-port port
) port
))
145 :secure
(string-equal "https" scheme
))))
148 `(push (make-instance ',class
,.args2
) *sites
*)))
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
))
155 (remove (route-name new-route
) (site-class-routes (find-class site-class
)) :key
#'route-name
)))))