diff options
Diffstat (limited to 'lisp/service/base-service.lisp')
| -rw-r--r-- | lisp/service/base-service.lisp | 210 |
1 files changed, 206 insertions, 4 deletions
diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp index ecd9469..c830254 100644 --- a/lisp/service/base-service.lisp +++ b/lisp/service/base-service.lisp @@ -3,19 +3,221 @@ (in-package :bogenherr) -(defclass base-service () - () +;; webapp + +(defvar *acceptor* nil) +(defvar *dispatch-table* '(#'dispatch-easy-handlers #'default-dispatcher)) +(defvar *webapps* (make-hash-table :test 'equal)) +(defvar *webapp* nil) +(defvar *uri* nil) +(defvar *header-register* nil) +(defvar *sessionid* nil) +(defparameter *port* 3012) +(defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name #.*package*)) "./")) + "The location of the web server root on the filesystem.") + +(defclass webapp () + ((name :initarg :name + :initform nil + :accessor name + :documentation "The name of the webapp as used in the code. A +string used as the key to any webapp config lookup.") + (scheme :initarg :scheme + :initform nil + :accessor scheme) + (url :initarg :url + :initform nil + :accessor url + :documentation "The domain portion of the URL to the +root of the webapp.") + (document-root :initarg :document-root + :initform nil + :accessor document-root + :documentation "The absolute filesystem path to the +webapp's top-level directory which is inside the webapps folder.") + (title :initarg :title + :initform nil + :accessor title + :documentation "The default title that shows up in +the browser title bar.") + (meta-description :initarg :meta-description + :initform nil + :accessor meta-description + :documentation "The text that goes into the META DESCRIPTION +tag, and anywhere else we want to put this text so that it will show +up in Google.") + (databases :initarg :databases + :initform nil + :accessor databases) + (mail-mx :initarg :mail-mx + :initform nil + :accessor mail-mx) + (mail-from :initarg :mail-from + :initform nil + :accessor mail-from) + (mail-postmaster :initarg :mail-postmaster + :initform nil + :accessor mail-postmaster) + (mail-webmaster :initarg :mail-webmaster + :initform nil + :accessor mail-webmaster) + (mail-info :initarg :mail-info + :initform nil + :accessor mail-info) + (mail-login-notify :initarg :mail-login-notify + :initform nil + :accessor mail-login-notify) + (mail-authentication :initarg :mail-authentication + :initform nil + :accessor mail-authentication) + (mail-ssl :initarg :mail-ssl + :initform nil + :accessor mail-ssl)) (:documentation "")) +(defmethod get-site-file-path ((webapp webapp)) + (format nil "~a/site" (document-root webapp))) + +(defmethod get-pages-file-paths ((webapp webapp)) + (mapcar (lambda (pages-file) + (ppcre:regex-replace-all "\\.lisp$" (format nil "~a" pages-file) "")) + (remove-if (lambda (x) (equal x "shared")) + (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type f -iname 'pages*.lisp' |sort" (document-root webapp)))))) + +(defun make-server-path (relative-path) + "Makes a relative filesystem path into a full one, using +`*server-root*' as the base." + (make-document-root-path *server-root* relative-path)) + +(defun make-document-root-path (document-root relative-path) + "Makes a relative filesystem path into a full one, using +`document-root' as the base." + (concatenate 'string document-root relative-path)) + +(defun make-webapp-path (relative-path) + "Makes an absolute filesystem path to a location in the webapps +folder." + (concatenate 'string *server-root* "webapps/" relative-path)) + +(defun get-options-files () + (mapcar (lambda (webapp-directory) + (format nil "~a/conf/options.lisp" webapp-directory)) + (remove-if (lambda (x) (or (org-ckons-core::match-it "webapps/$" x) + (org-ckons-core::match-it "webapps/shared$" x) + (org-ckons-core::match-it "webapps/CVS$" x) + (org-ckons-core::match-it "webapps/\\.$" x) + (org-ckons-core::match-it "webapps/\\.\\.$" x))) + (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type d |sort" (make-webapp-path "")))))) + +(defun set-webapp (webapp) + "Sets a `webapp' object in `*webapps*'. The lookup key is the webapp +name. If a webapp already exists under this key, it gets overwritten +with the new one." + (setf (gethash (name webapp) *webapps*) webapp)) + +(defun get-webapp (key) + "Gets the webapp object stored under the key `key'." + (gethash key *webapps*)) + +(defun populate-webapps () + (loop for options-file in (get-options-files) + do (with-open-file (input options-file :direction :input) + (let* ((form (read input))) + (set-webapp (make-instance 'webapp + :name (getf form :name) + :scheme (getf form :scheme) + :url (getf form :url) + :document-root (make-webapp-path (getf form :document-root)) + :title (getf form :title) + :meta-description (getf form :meta-description) + :databases (getf form :databases) + :mail-mx (getf form :mail-mx) + :mail-from (getf form :mail-from) + :mail-postmaster (getf form :mail-postmaster) + :mail-webmaster (getf form :mail-webmaster) + :mail-info (getf form :mail-info) + :mail-login-notify (getf form :mail-login-notify) + :mail-authentication (getf form :mail-authentication) + :mail-ssl (getf form :mail-ssl))))))) + +(defun bogenherr () + "Call this to start the server." + (when (null *acceptor*) + (let ((package (string-downcase (package-name #.*package*)))) + (populate-webapps) + (setf (log-manager) (make-instance 'log-manager :message-class 'formatted-message)) + (start-messenger 'text-file-messenger :filename (format nil "/var/log/lisp/~a.log" package)) + (setf *session-secret* (org-ckons-session::generate-sessionid)) + (populate-webapps) + (setf *acceptor* (start (make-instance 'easy-routes:easy-routes-acceptor + :port *port* + :document-root (make-server-path (format nil "webapps/~a/" package)) + :name (format nil "~a-acceptor" package))))))) + +(defmacro with-request-wrapper (uri page-function &rest args) + (let ((package (string-downcase (package-name #.*package*)))) + `(let (output) + (let* ((*webapp* (get-webapp ,package)) + (*uri* ,uri) + (*header-register* (make-instance 'org-ckons-session::header-register)) + (*sessionid* (ensure-user-session-exists))) + (ensure-user-exists) + (setf output (,page-function ,@args)) + (org-ckons-session::ship-headers *header-register*)) + output))) + +(defmacro define-endpoint (template-and-options var-list page-function &rest args) + "Does the grunt work of creating an `easy-routes' route for each page +you wish to publish." + (let ((name (gensym)) + (uri (first template-and-options)) + (method (getf (rest template-and-options) :method))) + `(progn + (org-ckons-core::logger (format nil "Publishing page. URL = [~a], method = [~a]" ,uri ,method)) + (easy-routes:defroute ,name ,template-and-options + ,var-list + (with-request-wrapper ,uri ,page-function ,@args))))) + +;; base-service + (defmacro loop-intersect-slots ((slot record other-object) &body body) `(loop for ,slot in (intersect-slots ,record (org-ckons-core::map-slot-names ,other-object)) do (when (slot-is-field-p ,slot) ,@body))) +(defclass base-service () + () + (:documentation "")) + (defmethod copy-from-record ((base-service base-service) (record record)) (loop-intersect-slots (slot record base-service) - (setf (slot-value base-service slot) (slot-value record slot)))) + (setf (slot-value base-service slot) (slot-value record slot)))) (defmethod copy-to-record ((base-service base-service) (record record)) (loop-intersect-slots (slot record base-service) - (setf (slot-value record slot) (slot-value base-service slot)))) + (setf (slot-value record slot) (slot-value base-service slot)))) + +(defun base (&optional (start-url "/home")) + (org-ckons-http::html5 + `(html + (head + ((meta :name "viewport" :content "width=device-width, initial-scale=1, shrink-to-fit=no")) + ((meta :charset "utf-8")) + ((title) ,(title *webapp*)) + ,@(mapcar (lambda (css) + `((link :rel "stylesheet" :href ,(getf css :href) :integrity ,(getf css :integrity) :crossorigin ,(getf css :crossorigin)))) + '((:href "https://cdn.jsdelivr.net/npm/bootstrap@4.6.2/dist/css/bootstrap.min.css" :integrity "sha384-xOolHFLEh07PJGoPkLv1IbcEPTNtaed2xpHsD9ESMhqIYd0nLMwNLD69Npy4HI+N" :crossorigin "anonymous") + (:href "/static/css/stylesheet.css" :crossorigin "anonymous"))) + ,@(mapcar (lambda (js) + `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin)))) + '((:src "https://code.jquery.com/jquery-3.7.1.slim.min.js" :integrity "sha256-kmHvs0B+OpCW5GVHUNjv9rOmY0IvSIRcf7zGUDTDQM8=" :crossorigin "anonymous"))) + ((script :type "text/javascript" :src "/cljs-out/dev-main.js"))) + ((body :onload ,(format nil "bogenherr.core.start(~a)" (if start-url + (format nil "'~a'" start-url) + "null"))) + ((div :id "app")) + ,@(mapcar (lambda (js) + `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin)))) + '((:src "https://cdn.jsdelivr.net/npm/bootstrap@4.6.2/dist/js/bootstrap.bundle.min.js" :integrity "sha384-Fy6S3B9q64WdZWQUiU+q4/2Lc9npb8tCaSX9FK7E8HnRr0Jz8D6OP9dO5Vg3Q9ct" :crossorigin "anonymous"))))))) + +(define-endpoint ("/" :method :get) () base) |