migrate to react

1 files changed, 204 insertions, 2 deletions

diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp
index ecd9469..760e2b9 100644
--- a/lisp/service/base-service.lisp
+++ b/lisp/service/base-service.lisp
@@ -3,15 +3,192 @@
 
 (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))))
@@ -19,3 +196,28 @@
 (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))))
+
+(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)