summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/bogenherr.asd4
-rw-r--r--lisp/service/base-service.lisp6
-rw-r--r--lisp/service/messages-service.lisp4
-rw-r--r--lisp/service/password-service.lisp4
-rw-r--r--lisp/service/profile-service.lisp6
-rw-r--r--lisp/service/rest-service.lisp4
-rw-r--r--lisp/service/users-service.lisp24
-rw-r--r--lisp/sql/auth-pkg.lisp6
-rw-r--r--lisp/sql/user-session-pkg.lisp16
-rw-r--r--lisp/webapps/bogenherr/clojurescript/bogenherr/src/core.cljs6
-rw-r--r--lisp/webapps/bogenherr/site.lisp6
-rw-r--r--lisp/webapps/webapp-loader.lisp41
12 files changed, 62 insertions, 65 deletions
diff --git a/lisp/bogenherr.asd b/lisp/bogenherr.asd
index 4af87fa..495ae85 100644
--- a/lisp/bogenherr.asd
+++ b/lisp/bogenherr.asd
@@ -21,8 +21,8 @@
(defparameter *asdf-packages* '(org-ckons-core org-ckons-http org-ckons-json org-ckons-file org-ckons-serializable org-ckons-session org-ckons-condition org-ckons-sql))
(defparameter *all-packages* (append *quicklisp-packages* *asdf-packages*))
-(loop for pkg in *quicklisp-packages* do
- (ql:quickload (symbol-name pkg)))
+(loop for pkg in *quicklisp-packages*
+ do (ql:quickload (symbol-name pkg)))
(do-defsystem :name "bogenherr"
:version "1"
diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp
index 77df817..ecd9469 100644
--- a/lisp/service/base-service.lisp
+++ b/lisp/service/base-service.lisp
@@ -8,9 +8,9 @@
(:documentation ""))
(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)))
+ `(loop for ,slot in (intersect-slots ,record (org-ckons-core::map-slot-names ,other-object))
+ do (when (slot-is-field-p ,slot)
+ ,@body)))
(defmethod copy-from-record ((base-service base-service) (record record))
(loop-intersect-slots (slot record base-service)
diff --git a/lisp/service/messages-service.lisp b/lisp/service/messages-service.lisp
index 18999ab..e03c04c 100644
--- a/lisp/service/messages-service.lisp
+++ b/lisp/service/messages-service.lisp
@@ -38,8 +38,8 @@
(id (get-user))
(string= (session-value :messages-read) "read")))))
(sanitize-rest-json instance)
- (loop for result in (results instance) do
- (sanitize-json result))))
+ (loop for result in (results instance)
+ do (sanitize-json result))))
(defclass messages/mark-service (messages-service)
((location-p :initform nil))
diff --git a/lisp/service/password-service.lisp b/lisp/service/password-service.lisp
index fee720e..32507d2 100644
--- a/lisp/service/password-service.lisp
+++ b/lisp/service/password-service.lisp
@@ -42,8 +42,8 @@
(let ((auth-pkg (make-instance 'auth-pkg)))
(loop for param in (remove-if (lambda (x)
(intersection `(,x) '(id pwd2)))
- (sb-introspect:function-lambda-list #'password-submit-json)) do
- (setf (slot-value user param) (symbol-value param)))
+ (sb-introspect:function-lambda-list #'password-submit-json))
+ do (setf (slot-value user param) (symbol-value param)))
(update-password auth-pkg user)
(set-user user)
(setf (session-value :message) "Password saved successfully."))
diff --git a/lisp/service/profile-service.lisp b/lisp/service/profile-service.lisp
index c5783ad..256d599 100644
--- a/lisp/service/profile-service.lisp
+++ b/lisp/service/profile-service.lisp
@@ -48,12 +48,12 @@
(with-auth (instance profile/modify-service "profile-modify")
(with-bogenherr-database
(let ((user (get-user)))
- (if (= id (id user))
+ (if (= (id user) id)
(let ((auth-pkg (make-instance 'auth-pkg)))
(loop for param in (remove-if (lambda (x)
(intersection `(,x) '(id)))
- (sb-introspect:function-lambda-list #'profile-modify-submit-json)) do
- (setf (slot-value user param) (symbol-value param)))
+ (sb-introspect:function-lambda-list #'profile-modify-submit-json))
+ do (setf (slot-value user param) (symbol-value param)))
(copy-from-record instance user)
(update-user auth-pkg user)
(set-user user)
diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp
index eda0948..b01f7fa 100644
--- a/lisp/service/rest-service.lisp
+++ b/lisp/service/rest-service.lisp
@@ -37,5 +37,5 @@
(defmethod sanitize-rest-json ((rest-service rest-service))
(loop for slot in (intersection '(org-ckons-session::*session-key *table *where-expression pwd)
- (org-ckons-core::map-slot-names rest-service)) do
- (setf (slot-value rest-service slot) nil)))
+ (org-ckons-core::map-slot-names rest-service))
+ do (setf (slot-value rest-service slot) nil)))
diff --git a/lisp/service/users-service.lisp b/lisp/service/users-service.lisp
index fa56c53..5b16d46 100644
--- a/lisp/service/users-service.lisp
+++ b/lisp/service/users-service.lisp
@@ -26,8 +26,8 @@
(let ((auth-pkg (make-instance 'auth-pkg)))
(setf (users instance) (get-all-users auth-pkg))))
(sanitize-rest-json instance)
- (loop for user in (users instance) do
- (sanitize-json user))))
+ (loop for user in (users instance)
+ do (sanitize-json user))))
(defclass users/add-service (users/view-service)
((form :initarg :form
@@ -69,8 +69,8 @@
(with-auth (instance users/add-service "users-modify")
(with-bogenherr-database
(let ((registration (make-instance 'registration)))
- (loop for param in (sb-introspect:function-lambda-list #'users-add-submit-json) do
- (setf (slot-value registration param) (symbol-value param)))
+ (loop for param in (sb-introspect:function-lambda-list #'users-add-submit-json)
+ do (setf (slot-value registration param) (symbol-value param)))
(let* ((auth-pkg (make-instance 'auth-pkg))
(id (insert-registration auth-pkg registration)))
(setf registration (get-registration-by-id auth-pkg id)))
@@ -185,10 +185,10 @@
(progn
(loop for role-group in (union '("profile-admin")
(cl-ppcre:split "\\|" (role_groups registration))
- :test 'string=) do
- (insert-user-role-group auth-pkg (make-instance 'user-role
- :user_id (id user)
- :role_group_name role-group)))
+ :test 'string=)
+ do (insert-user-role-group auth-pkg (make-instance 'user-role
+ :user_id (id user)
+ :role_group_name role-group)))
(delete-registration auth-pkg hash)
(setf (session-value :message) "Registration completed successfully."))
(setf (session-value :errormsg) "Error while completing registration.")))
@@ -238,10 +238,10 @@
(delete-role-groups auth-pkg user)
(loop for role-group in (union '("profile-admin")
(cl-ppcre:split "\\|" role_groups)
- :test 'string=) do
- (insert-user-role-group auth-pkg (make-instance 'user-role
- :user_id (id user)
- :role_group_name role-group)))
+ :test 'string=)
+ do (insert-user-role-group auth-pkg (make-instance 'user-role
+ :user_id (id user)
+ :role_group_name role-group)))
(setf (session-value :message) "User saved successfully."))
(setf (session-value :errormsg) "An error occured."))))))
diff --git a/lisp/sql/auth-pkg.lisp b/lisp/sql/auth-pkg.lisp
index 21a996e..58d89cc 100644
--- a/lisp/sql/auth-pkg.lisp
+++ b/lisp/sql/auth-pkg.lisp
@@ -166,9 +166,9 @@
(let* ((auth-pkg (make-instance 'auth-pkg))
(has-all-roles-p (let ((has-all-roles-p t))
(with-bogenherr-database
- (loop for role in (if (listp ,roles) ,roles (list ,roles)) do
- (when (not (has-role auth-pkg ,session-name role))
- (setf has-all-roles-p nil)))
+ (loop for role in (if (listp ,roles) ,roles (list ,roles))
+ do (when (not (has-role auth-pkg ,session-name role))
+ (setf has-all-roles-p nil)))
has-all-roles-p))))
(if has-all-roles-p
,@body
diff --git a/lisp/sql/user-session-pkg.lisp b/lisp/sql/user-session-pkg.lisp
index 0adba55..954f84f 100644
--- a/lisp/sql/user-session-pkg.lisp
+++ b/lisp/sql/user-session-pkg.lisp
@@ -106,11 +106,11 @@ variable."
(setf org-ckons-session::*gc-last-cycle-timestamp* (get-universal-time))
(with-bogenherr-database
(let ((user-session-pkg (make-instance 'user-session-pkg)))
- (loop for user-session in (get-user-sessions user-session-pkg) do
- (let ((inactive-time (- org-ckons-session::*gc-last-cycle-timestamp* (datetime user-session))))
- (when (and (> inactive-time org-ckons-session::*session-timeout*)
- (sessionid user-session))
- (org-ckons-core::logger (format nil "Deleting expired session: id = [~a] ; sessionid = [~a]" (id user-session) (sessionid user-session)))
- (loop for user-session-object in (get-user-session-objects user-session-pkg user-session) do
- (delete-record user-session-pkg user-session-object))
- (delete-record user-session-pkg user-session))))))))
+ (loop for user-session in (get-user-sessions user-session-pkg)
+ do (let ((inactive-time (- org-ckons-session::*gc-last-cycle-timestamp* (datetime user-session))))
+ (when (and (> inactive-time org-ckons-session::*session-timeout*)
+ (sessionid user-session))
+ (org-ckons-core::logger (format nil "Deleting expired session: id = [~a] ; sessionid = [~a]" (id user-session) (sessionid user-session)))
+ (loop for user-session-object in (get-user-session-objects user-session-pkg user-session)
+ do (delete-record user-session-pkg user-session-object))
+ (delete-record user-session-pkg user-session))))))))
diff --git a/lisp/webapps/bogenherr/clojurescript/bogenherr/src/core.cljs b/lisp/webapps/bogenherr/clojurescript/bogenherr/src/core.cljs
index 80862b3..6e5276d 100644
--- a/lisp/webapps/bogenherr/clojurescript/bogenherr/src/core.cljs
+++ b/lisp/webapps/bogenherr/clojurescript/bogenherr/src/core.cljs
@@ -164,7 +164,7 @@
(declare goto-location)
(declare reset-app)
(declare goto-register)
-(declare site)
+(declare comp-app)
(declare start-render)
(declare start-nav-state)
(declare reset-nav-state)
@@ -204,7 +204,7 @@
;; body
-(defn site []
+(defn comp-app []
[:div {:class "container-fluid"}
[:div {:class "banner"}
[:table {:width "100%" :height "100%"}
@@ -226,7 +226,7 @@
(defn start-render []
(let [app-root (rdc/create-root (js/document.getElementById "app"))]
- (rdc/render app-root [site])))
+ (rdc/render app-root [comp-app])))
(defn start-nav-state []
(cond (str/starts-with? (@nav-state :location) "/register/")
diff --git a/lisp/webapps/bogenherr/site.lisp b/lisp/webapps/bogenherr/site.lisp
index 37f33cd..9bb1b2d 100644
--- a/lisp/webapps/bogenherr/site.lisp
+++ b/lisp/webapps/bogenherr/site.lisp
@@ -196,8 +196,8 @@
(define-endpoint ("/gallery/add/submit" :method :post) (&post (description :parameter-type 'string) (video_embed_url :parameter-type 'string) (upload :parameter-type 'string)) .gallery-add-submit)
(define-endpoint ("/gallery/modify" :method :post) (&post (id :parameter-type 'integer)) .gallery-modify)
(define-endpoint ("/gallery/modify/submit" :method :post) (&post (id :parameter-type 'integer) (description :parameter-type 'string) (video_embed_url :parameter-type 'string) (upload :parameter-type 'string)) .gallery-modify-submit)
-(define-endpoint ("/gallery/delete/:id" :method :delete) () .gallery-delete)
-(define-endpoint ("/gallery/file/view/:id" :method :get) () .gallery-file-view)
+(define-endpoint ("/gallery/delete/:id" :method :delete) (&path (id 'integer)) .gallery-delete)
+(define-endpoint ("/gallery/file/view/:id" :method :get) (&path (id 'integer)) .gallery-file-view)
(define-endpoint ("/testimonials" :method :get) () .testimonials)
(define-endpoint ("/testimonials/view" :method :get) () .testimonials-view)
(define-endpoint ("/testimonials/modify" :method :post) () .testimonials-modify)
@@ -212,7 +212,7 @@
(define-endpoint ("/users/view" :method :get) () .users-view)
(define-endpoint ("/users/add" :method :post) () .users-add)
(define-endpoint ("/users/add/submit" :method :post) (&post (role_groups :parameter-type 'string) (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string)) .users-add-submit)
-(define-endpoint ("/register/:hash" :method :get) () .base hash)
+(define-endpoint ("/register/:hash" :method :get) (&path (hash 'string)) .base (format nil "/register/~a" hash))
(define-endpoint ("/users/register" :method :post) (&post (hash :parameter-type 'string)) .users-register)
(define-endpoint ("/users/register/form" :method :post) (&post (hash :parameter-type 'string)) .users-register-form)
(define-endpoint ("/users/register/submit" :method :post) (&post (hash :parameter-type 'string) (username :parameter-type 'string) (pwd :parameter-type 'string) (pwd2 :parameter-type 'string) (phone :parameter-type 'string)) .users-register-submit)
diff --git a/lisp/webapps/webapp-loader.lisp b/lisp/webapps/webapp-loader.lisp
index 7f1461e..e18f661 100644
--- a/lisp/webapps/webapp-loader.lisp
+++ b/lisp/webapps/webapp-loader.lisp
@@ -118,25 +118,25 @@ with the new one."
(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)))))))
+ (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."
@@ -175,6 +175,3 @@ you wish to publish."
(easy-routes:defroute ,name ,template-and-options
,var-list
(with-request-wrapper ,uri ,page-function ,@args)))))
- ;; (define-easy-handler (,name :uri ,uri :default-request-type ,request-type)
- ;; ,var-list
- ;; (with-request-wrapper ,uri ,page-function ,@args)))))
generated by cgit v1.3 (git 2.53.0) at 2026-09-24 15:32:28 +0000