diff options
Diffstat (limited to 'lisp')
57 files changed, 3488 insertions, 0 deletions
diff --git a/lisp/core/core.lisp b/lisp/core/core.lisp new file mode 100644 index 0000000..873b371 --- /dev/null +++ b/lisp/core/core.lisp @@ -0,0 +1,7 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defpackage :resume + (:use :cl :cl-log :hunchentoot :org-ckons-sql)) + +(in-package :resume) diff --git a/lisp/resume.asd b/lisp/resume.asd new file mode 100644 index 0000000..a63bc46 --- /dev/null +++ b/lisp/resume.asd @@ -0,0 +1,73 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :cl) + +(defpackage :resume-system (:use :cl :asdf)) +(in-package :resume-system) + +(defmacro do-defsystem (&key name version maintainer author description long-description depends-on components) + `(defsystem ,name + :name ,name + :version ,version + :maintainer ,maintainer + :author ,author + :description ,description + :long-description ,long-description + :depends-on ,(eval depends-on) + :components ,components)) + +(defparameter *quicklisp-packages* '(cl-ppcre cl-smtp hunchentoot easy-routes cl-log ironclad cl-markdown tmpdir net-telent-date uffi drakma cl-json postmodern fiveam local-time trivial-octet-streams)) +(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))) + +(do-defsystem :name "resume" + :version "1" + :maintainer "Carlos Konstanski <me@ckons.org>" + :author "Carlos Konstanski <me@ckons.org>" + :description "resume" + :long-description "resume is a web application written in Common Lisp based on the Hunchentoot web server. The client-side code is written in ClojureScript. Purpose: public website for the Violin and Viola Studio in Pocatello ID." + :depends-on *all-packages* + :components ((:module core + :components ((:file "core"))) + (:module sql + :depends-on (core) + :components ((:file "generics") + (:file "user-session" :depends-on ("generics")) + (:file "user-session-pkg" :depends-on ("generics" "user-session")) + (:file "user" :depends-on ("generics")) + (:file "role-group" :depends-on ("generics")) + (:file "user-role" :depends-on ("generics")) + (:file "registration" :depends-on ("generics")) + (:file "about-us" :depends-on ("generics")) + (:file "contact-us" :depends-on ("generics")) + (:file "auth-pkg" :depends-on ("user-session-pkg" "user" "role-group" "user-role" "registration")) + (:file "general-pkg" :depends-on ("about-us")) + (:file "contact-pkg" :depends-on ("contact-us")))) + (:module service + :depends-on (sql) + :components ((:file "generics") + (:file "base-service") + (:file "rest-service" :depends-on ("base-service")) + (:file "auth-service" :depends-on ("rest-service")) + (:file "generic-form" :depends-on ("rest-service")) + (:file "menu-service" :depends-on ("base-service")) + (:file "home-service" :depends-on ("rest-service")) + (:file "login-service" :depends-on ("generic-form" "rest-service")) + (:file "logout-service" :depends-on ("rest-service")) + (:file "profile-service" :depends-on ("generic-form" "auth-service")) + (:file "password-service" :depends-on ("generic-form" "auth-service")) + (:file "about-us-service" :depends-on ("generic-form" "auth-service")) + (:file "contact-us-service" :depends-on ("generic-form" "auth-service")) + (:file "users-service" :depends-on ("generic-form" "auth-service")) + (:file "messages-service" :depends-on ("generic-form" "auth-service")))) + (:module webapps + :depends-on (service) + :components ((:file "generics") + (:file "webapp-loader" :depends-on ("generics")) + (:module resume + :depends-on ("webapp-loader") + :components ((:file "site"))))))) diff --git a/lisp/service/about-us-service.lisp b/lisp/service/about-us-service.lisp new file mode 100644 index 0000000..c479efe --- /dev/null +++ b/lisp/service/about-us-service.lisp @@ -0,0 +1,66 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass about-us-service (rest-service) + ((category :initarg :category + :initform nil + :accessor category)) + (:documentation "")) + +(defun about-us-json (category) + (with-noauth (instance about-us-service) + (setf (category instance) category))) + +(defclass about-us/view-service (about-us-service) + ((content :initarg :content + :initform nil + :accessor content) + (admin-p :initarg :admin-p + :initform nil + :accessor admin-p) + (location :initform nil)) + (:documentation "")) + +(defun about-us-view-json (category) + (with-noauth (instance about-us/view-service) + (setf (category instance) category) + (with-valid-user (user "about-us-modify") + (setf (admin-p instance) nil) + (setf (admin-p instance) t)) + (with-resume-database + (let* ((general-pkg (make-instance 'general-pkg)) + (about-us (get-about-us general-pkg category))) + (when about-us + (setf (content instance) (content about-us))))))) + +(defclass about-us/modify-service (about-us/view-service auth-service) + ((form :initarg :form + :initform nil + :accessor form) + (admin-p :initform t) + (location-p :initform nil)) + (:documentation "")) + +(defun about-us-modify-json (category) + (with-auth (instance about-us/modify-service "about-us-modify") + (with-resume-database + (let* ((general-pkg (make-instance 'general-pkg)) + (about-us (get-about-us general-pkg category))) + (setf (form instance) (make-form "about-us-modify-form" + nil + nil + `((:label "Content" :name "txt-content" :field-type "textarea" :value ,(content about-us) :required "required") + (:label "Modify" :field-type "button" :onclick "on_about_us_modify_submit_clicked()")))))))) + +(defun about-us-modify-submit-json (category content) + (with-auth (instance about-us/modify-service "about-us-modify") + (with-resume-database + (let* ((general-pkg (make-instance 'general-pkg)) + (about-us (get-about-us general-pkg category))) + (when about-us + (setf (content about-us) content) + (update-record general-pkg about-us)))) + (setf (content instance) content) + (setf (message instance) "About Us text saved successfully."))) diff --git a/lisp/service/auth-service.lisp b/lisp/service/auth-service.lisp new file mode 100644 index 0000000..8450e64 --- /dev/null +++ b/lisp/service/auth-service.lisp @@ -0,0 +1,48 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass auth-service (rest-service) + () + (:documentation "")) + +(defmethod initialize-instance :after ((auth-service auth-service) &key roles) + (with-valid-user (session roles) + (progn + (setf (location auth-service) "/home") + (setf (message auth-service) nil) + (setf (errormsg auth-service) "You are not authorized to access this resource.")) + t)) + +(defmacro with-auth ((instance auth-service roles) &body body) + `(let ((,instance (make-instance ',auth-service :roles ,roles))) + (when (null (errormsg ,instance)) + ,@body) + (when (location-p ,instance) + (setf (session-value :message) nil) + (setf (session-value :errormsg) nil)) + (org-ckons-json::objects-to-json `(,,instance)))) + +(defmacro with-auth-raw ((instance auth-service roles) &body body) + `(let ((,instance (make-instance ',auth-service :roles ,roles))) + (when (location-p ,instance) + (setf (session-value :message) nil) + (setf (session-value :errormsg) nil)) + (when (null (errormsg ,instance)) + ,@body))) + +(defmacro with-noauth ((instance rest-service) &body body) + `(let ((,instance (make-instance ',rest-service))) + ,@body + (when (location-p ,instance) + (setf (session-value :message) nil) + (setf (session-value :errormsg) nil)) + (org-ckons-json::objects-to-json `(,,instance)))) + +(defmacro with-noauth-raw ((instance rest-service) &body body) + `(let ((,instance (make-instance ',rest-service))) + (when (location-p ,instance) + (setf (session-value :message) nil) + (setf (session-value :errormsg) nil)) + ,@body)) diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp new file mode 100644 index 0000000..bd38c5a --- /dev/null +++ b/lisp/service/base-service.lisp @@ -0,0 +1,21 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass base-service () + () + (: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))) + +(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)))) + +(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)))) diff --git a/lisp/service/contact-us-service.lisp b/lisp/service/contact-us-service.lisp new file mode 100644 index 0000000..43f6da3 --- /dev/null +++ b/lisp/service/contact-us-service.lisp @@ -0,0 +1,84 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass contact-us-service (rest-service) + () + (:documentation "")) + +(defun contact-us-form () + (make-form "contact-us-form" + nil + t + `((:name "first_name" :label "First Name" :field-type "text" :required "required") + (:name "last_name" :label "Last Name" :field-type "text" :required "required") + (:name "email" :label "Email" :field-type "text" :required "required") + (:name "phone" :label "Phone" :field-type "text") + (:name "comments" :label "Message" :field-type "textarea" :required "required") + (:label "Submit" :field-type "button" :onclick "on_contact_us_email_submit_clicked()")))) + +(defun contact-us-json () + (with-noauth (instance contact-us-service) + t)) + +(defclass contact-us/view-service (contact-us-service) + ((content :initarg :content + :initform nil + :accessor content) + (form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun contact-us-view-json () + (with-noauth (instance contact-us/view-service) + (setf (form instance) (contact-us-form)))) + +(defclass contact-us/email-service (contact-us/view-service) + () + (:documentation "")) + +(defun contact-us-email-json (first_name last_name email phone comments) + (declare (special first_name last_name email phone comments)) + (with-noauth (instance contact-us/email-service) + (with-resume-database + (let ((contact-pkg (make-instance 'contact-pkg)) + (contact-us-post (make-instance 'contact-us-post))) + (loop for param in (sb-introspect:function-lambda-list #'contact-us-email-json) + do (setf (slot-value contact-us-post param) (symbol-value param))) + (insert-contact-us-post contact-pkg contact-us-post) + (handler-case + (let ((text-message (format nil + "A contact-us form submission was received.~%~%Name: ~a ~a~%Email: ~a~%Phone: ~a~%~%Message: ~a~%" + (first_name contact-us-post) + (last_name contact-us-post) + (email contact-us-post) + (phone contact-us-post) + (comments contact-us-post))) + (html-message (org-ckons-http::html5 + `(html + ((p) "A contact-us form submission was received.") + ((p) + ,(format nil + "Name: ~a ~a<br/>Email: ~a<br/>Phone: ~a" + (first_name contact-us-post) + (last_name contact-us-post) + (email contact-us-post) + (phone contact-us-post))) + ((p) + ,(format nil "Message: ~a" (comments contact-us-post))))))) + (org-ckons-core::sendmail (mail-mx *webapp*) + (mail-postmaster *webapp*) + (mail-info *webapp*) + (format nil "~a contact-us form" (name *webapp*)) + text-message + :html-message html-message + :reply-to (mail-postmaster *webapp*) + :ssl (mail-ssl *webapp*) + :authentication (mail-authentication *webapp*)) + (setf (session-value :message) "Form submitted successfully.")) + (error (e) + (declare (ignore e)) + (setf (session-value :errormsg) "Error submitting form."))))))) diff --git a/lisp/service/generic-form.lisp b/lisp/service/generic-form.lisp new file mode 100644 index 0000000..c9742a4 --- /dev/null +++ b/lisp/service/generic-form.lisp @@ -0,0 +1,87 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass generic-form (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (http-method :initarg :http-method + :initform "POST" + :accessor http-method) + (action :initarg :action + :initform nil + :accessor action) + (required-p :initarg :required-p + :initform nil + :accessor required-p) + (form-fields :initarg :form-fields + :initform nil + :accessor form-fields)) + (:documentation "")) + +(defclass form-field (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value) + (checked :initarg :checked + :initform nil + :accessor checked) + (field-type :initarg :field-type + :initform nil + :accessor field-type) + (required :initarg :required + :initform nil + :accessor required) + (dismiss :initarg :dismiss + :initform nil + :accessor dismiss) + (options :initarg :options + :initform nil + :accessor options) + (onclick :initarg :onclick + :initform nil + :accessor onclick) + (onchange :initarg :onchange + :initform nil + :accessor onchange)) + (:documentation "")) + +(defclass option (base-service) + ((label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value)) + (:documentation "")) + +(defun make-form (name action required-p fields) + (make-instance 'generic-form + :name name + :action action + :required-p required-p + :form-fields (mapcar (lambda (field) + (make-instance 'form-field + :name (getf field :name) + :label (getf field :label) + :value (getf field :value) + :checked (getf field :checked) + :field-type (getf field :field-type) + :required (getf field :required) + :dismiss (getf field :dismiss) + :options (mapcar (lambda (option) + (make-instance 'option + :label (getf option :label) + :value (getf option :value))) + (getf field :options)) + :onclick (getf field :onclick) + :onchange (getf field :onchange))) + fields))) diff --git a/lisp/service/generics.lisp b/lisp/service/generics.lisp new file mode 100644 index 0000000..caca29b --- /dev/null +++ b/lisp/service/generics.lisp @@ -0,0 +1,15 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defgeneric copy-from-record (base-service record) + (:documentation "Copies the fields from `record' to +`base-service'.")) + +(defgeneric copy-to-record (base-service record) + (:documentation "Copies the fields from `base-service' to +`record'.")) + +(defgeneric sanitize-rest-json (rest-service) + (:documentation "")) diff --git a/lisp/service/home-service.lisp b/lisp/service/home-service.lisp new file mode 100644 index 0000000..8e8a740 --- /dev/null +++ b/lisp/service/home-service.lisp @@ -0,0 +1,18 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass home-service (rest-service) + ((content :initarg :content + :initform nil + :accessor content)) + (:documentation "")) + +(defmethod initialize-instance :after ((home-service home-service) &key) + t) + +(defun home-json (&optional message errormsg) + (with-noauth (instance home-service) + (when (not (org-ckons-core::null-or-empty-p message)) (setf (message instance) message)) + (when (not (org-ckons-core::null-or-empty-p errormsg)) (setf (errormsg instance) errormsg)))) diff --git a/lisp/service/login-service.lisp b/lisp/service/login-service.lisp new file mode 100644 index 0000000..5f7dd2c --- /dev/null +++ b/lisp/service/login-service.lisp @@ -0,0 +1,64 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass login-service (rest-service) + ((form :initarg :form + :initform nil + :accessor form) + (title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defclass login-forgot-service (login-service) + () + (:documentation "")) + +(defmethod initialize-instance :after ((login-service login-service) &key) + (setf (title login-service) "Login") + (setf (form login-service) (make-form "login-form" + nil + t + '((:name "username" :label "Username" :field-type "text" :required "required") + (:name "pwd" :label "Password" :field-type "password" :required "required") + (:label "Login" :field-type "button" :onclick "on_login_submit_clicked()"))))) + +(defmethod initialize-instance :after ((login-forgot-service login-forgot-service) &key) + (setf (title login-forgot-service) "Reset Password") + (setf (form login-forgot-service) (make-form "login-forgot-form" + nil + t + '((:name "username" :label "Username" :field-type "text" :required "required") + (:label "Send password reset email" :field-type "button" :onclick "on_login_forgot_submit_clicked()"))))) + +(defun login-json () + (with-noauth (instance login-service) + t)) + +(defun login-forgot-json () + (with-noauth (instance login-forgot-service) + t)) + +(defclass login-authenticate-service (rest-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun login-authenticate-json (username pwd) + (with-noauth (instance login-authenticate-service) + (if (or (org-ckons-core::null-or-empty-p username) + (org-ckons-core::null-or-empty-p pwd)) + (setf (session-value :errormsg) "Login failed.") + (with-resume-database + (let* ((auth-pkg (make-instance 'auth-pkg)) + (user (get-active-user-by-username-pwd auth-pkg username pwd))) + (cond (user + (set-user user) + (setf (session-value :message) "Successfully logged in.") + (setf (session-value :errormsg) nil)) + (t + (setf (session-value :message) nil) + (setf (session-value :errormsg) "Login failed.")))))) + (setf (message instance) (session-value :message)) + (setf (errormsg instance) (session-value :errormsg)))) diff --git a/lisp/service/logout-service.lisp b/lisp/service/logout-service.lisp new file mode 100644 index 0000000..a3c3948 --- /dev/null +++ b/lisp/service/logout-service.lisp @@ -0,0 +1,14 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass logout-service (rest-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun logout-json () + (with-noauth (instance logout-service) + (set-user (make-default-user)) + (setf (location instance) "/home") + (setf (message instance) "You are now logged out."))) diff --git a/lisp/service/menu-service.lisp b/lisp/service/menu-service.lisp new file mode 100644 index 0000000..e7af0c3 --- /dev/null +++ b/lisp/service/menu-service.lisp @@ -0,0 +1,96 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defparameter *menu-config* '((:id "a_menu_home" :label "Home" :handler "/home" :permissions "_Public") + (:id "a_menu_lessons" :label "About the Studio" :handler "/lessons" :permissions "_Public") + (:id "a_menu_gigs" :label "For Hire" :handler "/gigs" :permissions "_Public") + (:id "a_menu_programming" :label "Software Consulting" :handler "/programming" :permissions "_Public") + (:id "a_menu_contact_us" :label "Contact Me" :handler "/contact-us" :permissions "_Public") + (:id "a_menu_messages" :label "Messages" :handler "/messages" :permissions "messages-view") + (:id "a_menu_users" :label "Users" :handler "/users" :permissions "users-view"))) + +(defparameter *menu-user-config* '((:id "a_menu_login" :label "Login" :handler "/login" :permissions "_Public") + (:id "a_menu_profile" :label "Edit Profile" :handler "/profile" :permissions "_Public") + (:id "a_menu_password" :label "Change Password" :handler "/password" :permissions "_Public") + (:id "a_menu_logout" :label "Logout" :handler "/logout" :permissions "_Public"))) + +(defclass menuitem () + ((id :initarg :id + :initform nil + :accessor id) + (label :initarg :label + :initform nil + :accessor label) + (handler :initarg :handler + :initform nil + :accessor handler) + (permissions :initarg :permissions + :initform nil + :accessor permissions) + (children :initarg :children + :initform nil + :accessor children)) + (:documentation "")) + +(defclass menu-service (base-service) + ((menuitems :initarg :menuitems + :initform nil + :accessor menuitems) + (location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defclass menu-user-service (menu-service) + ((label :initarg :label + :initform nil + :accessor label) + (location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defmethod initialize-instance :after ((menu-service menu-service) &key user menu-config) + (with-resume-database + (let ((auth-pkg (make-instance 'auth-pkg)) + (user-logged-in-p (and user (not (= (id user) 0)))) + roles) + (setf roles (when user (get-all-roles auth-pkg user))) + (setf (menuitems menu-service) + (remove-if (lambda (menuitem) + (find-if (lambda (x) + (string= (id menuitem) x)) + (if user-logged-in-p + '("a_menu_login") + '("a_menu_logout" "a_menu_profile" "a_menu_password")))) + (mapcar (lambda (x) + (make-instance 'menuitem + :id (getf x :id) + :label (getf x :label) + :handler (getf x :handler) + :permissions (getf x :permissions))) + (remove-if 'null (mapcar (lambda (x) + (when (find-if (lambda (y) + (string= (getf x :permissions) y)) + (mapcar (lambda (z) + (role_name z)) + roles)) + x)) + menu-config)))))))) + +(defun menu-json () + (org-ckons-json::objects-to-json `(,(make-instance 'menu-service + :user (get-user) + :menu-config *menu-config*)))) + +(defun menu-user-json () + (let* ((user (get-user)) + (instance (make-instance 'menu-user-service + :user user + :menu-config *menu-user-config*))) + (setf (label instance) (if user + (format nil "~a ~a" (first_name user) (last_name user)) + "No User Found")) + (org-ckons-json::objects-to-json `(,instance)))) diff --git a/lisp/service/messages-service.lisp b/lisp/service/messages-service.lisp new file mode 100644 index 0000000..9dc047a --- /dev/null +++ b/lisp/service/messages-service.lisp @@ -0,0 +1,57 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass messages-service (auth-service) + ((title :initarg :title + :initform nil + :accessor title) + (form :initarg :form + :initform nil + :accessor form)) + (:documentation "")) + +(defun messages-json () + (with-auth (instance messages-service "messages-view") + (setf (title instance) "Messages Administration") + (setf (form instance) (make-form "messages-select-mode-form" + nil + nil + `((:name "read" :field-type "hidden" :required "required" :value ,(session-value :messages-read)) + (:label "View Unread" :field-type "button" :onclick "on_messages_mode_clicked('unread')") + (:label "View Read" :field-type "button" :onclick "on_messages_mode_clicked('read')")))))) + +(defclass messages/results-service (messages-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun messages-results-json (read) + (with-auth (instance messages/results-service "messages-view") + (when read (setf (session-value :messages-read) read)) + (with-resume-database + (let ((contact-pkg (make-instance 'contact-pkg))) + (setf (results instance) (get-contact-us-posts contact-pkg + (id (get-user)) + (string= (session-value :messages-read) "read"))))) + (sanitize-rest-json instance) + (loop for result in (results instance) + do (sanitize-json result)))) + +(defclass messages/mark-service (messages-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun messages-mark-json (read id) + (with-auth (instance messages/mark-service "messages-view") + (with-resume-database + (handler-case + (let ((contact-pkg (make-instance 'contact-pkg))) + (mark-contact-us-post contact-pkg id (id (get-user)) (string= read "read")) + (setf (session-value :message) (format nil "Message marked ~a successfully." read))) + (error (e) + (declare (ignore e)) + (setf (session-value :errormsg) (format nil "Error marking message ~a." read))))))) diff --git a/lisp/service/password-service.lisp b/lisp/service/password-service.lisp new file mode 100644 index 0000000..31b51b8 --- /dev/null +++ b/lisp/service/password-service.lisp @@ -0,0 +1,50 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass password-service (auth-service user) + ((form :initarg :form + :initform nil + :accessor form) + (title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defun password-json () + (with-auth (instance password-service "profile-modify") + (let ((user (get-user))) + (setf (title instance) "Change Password") + (setf (form instance) (make-form "password-form" + nil + t + `((:name "id" :label "" :field-type "hidden" :value ,(id user) :required "required") + (:name "pwd" :label "Password" :field-type "password" :required "required") + (:name "pwd2" :label "Password (again)" :field-type "password" :required "required") + (:label "Change Password" :field-type "button" :onclick "on_password_submit_clicked()"))))))) + +(defclass password/modify-service (password-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun password-submit-json (id pwd pwd2) + (declare (special pwd pwd2)) + (with-auth (instance password/modify-service "profile-modify") + (setf (title instance) "Change Password") + (with-resume-database + (let ((user (get-user))) + (if (and (= id (id user)) + (string= pwd pwd2)) + (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))) + (update-password auth-pkg user) + (set-user user) + (setf (session-value :message) "Password saved successfully.")) + (setf (session-value :errormsg) "An error occured.")))))) diff --git a/lisp/service/profile-service.lisp b/lisp/service/profile-service.lisp new file mode 100644 index 0000000..9e37bbf --- /dev/null +++ b/lisp/service/profile-service.lisp @@ -0,0 +1,61 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass profile-service (auth-service user) + ((title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defun profile-json () + (with-auth (instance profile-service "profile-modify") + (setf (title instance) "Profile") + (sanitize-rest-json instance))) + +(defun profile-view-json () + (with-auth (instance profile-service "profile-modify") + (let ((user (get-user))) + (copy-from-record instance user)) + (sanitize-rest-json instance))) + +(defclass profile/modify-service (profile-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun profile-modify-json () + (with-auth (instance profile/modify-service "profile-modify") + (let ((user (get-user))) + (sanitize-rest-json instance) + (setf (title instance) "Profile - Modify") + (setf (form instance) (make-form "profile-modify-form" + nil + t + `((:name "id" :label "" :field-type "hidden" :value ,(id user) :required "required") + (:name "username" :label "Username" :field-type "text" :value ,(username user) :required "required") + (:name "first_name" :label "First Name" :field-type "text" :value ,(first_name user) :required "required") + (:name "last_name" :label "Last Name" :field-type "text" :value ,(last_name user) :required "required") + (:name "email" :label "Email" :field-type "text" :value ,(email user) :required "required") + (:name "phone" :label "Phone" :field-type "text" :value ,(phone user)) + (:label "Modify Profile" :field-type "button" :onclick "on_profile_modify_submit_clicked()"))))))) + +(defun profile-modify-submit-json (id username first_name last_name email phone) + (declare (special username first_name last_name email phone)) + (with-auth (instance profile/modify-service "profile-modify") + (with-resume-database + (let ((user (get-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))) + (copy-from-record instance user) + (update-user auth-pkg user) + (set-user user) + (setf (session-value :message) "Profile saved successfully.")) + (setf (session-value :errormsg) "An error occured.")))))) diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp new file mode 100644 index 0000000..92274d6 --- /dev/null +++ b/lisp/service/rest-service.lisp @@ -0,0 +1,41 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass rest-service (base-service) + ((location :initarg :location + :initform nil + :accessor location) + (location-p :initarg :location-p + :initform t + :accessor location-p) + (errormsg :initarg :errormsg + :initform nil + :accessor errormsg) + (message :initarg :message + :initform nil + :accessor message)) + (:documentation "")) + +(defmethod initialize-instance :after ((rest-service rest-service) &key) + (when (location-p rest-service) + (if (message rest-service) + (setf (session-value :message) (message rest-service)) + (setf (message rest-service) (session-value :message))) + (if (errormsg rest-service) + (setf (session-value :errormsg) (errormsg rest-service)) + (setf (errormsg rest-service) (session-value :errormsg))) + (when (null (location rest-service)) + (setf (location rest-service) (type-to-path rest-service))))) + +(defun location-json (&optional (location "/home")) + (format nil "{\"location\":\"~a\"}" location)) + +(defun type-to-path (rest-type) + (concatenate 'string "/" (ppcre:regex-replace "-service$" (string-downcase (type-of rest-type)) ""))) + +(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))) diff --git a/lisp/service/users-service.lisp b/lisp/service/users-service.lisp new file mode 100644 index 0000000..a626971 --- /dev/null +++ b/lisp/service/users-service.lisp @@ -0,0 +1,282 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass users-service (auth-service) + ((title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defun users-json () + (with-auth (instance users-service "users-view") + (setf (title instance) "Users"))) + +(defclass users/view-service (users-service user) + ((users :initarg :users + :initform nil + :accessor users) + (location-p :initform nil)) + (:documentation "")) + +(defun users-view-json () + (with-auth (instance users/view-service "users-view") + (with-resume-database + (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)))) + +(defclass users/add-service (users/view-service) + ((form :initarg :form + :initform nil + :accessor form)) + (:documentation "")) + +(defun role-checkboxes (role-groups &optional active-role-groups) + (remove-if 'null + (mapcar (lambda (role-group) + (when (not (intersection `(,(name role-group)) `("_Public" "profile-admin") :test 'string=)) + (let ((checked (when (intersection `(,(name role-group)) + (mapcar (lambda (x) + (name x)) + active-role-groups) + :test 'string=) + '(:checked "checked" :value "on")))) + (remove-if 'null `(:name ,(format nil "chk_~a" (name role-group)) :label ,(name role-group) :field-type "checkbox" ,@checked))))) + role-groups))) + +(defun users-add-json () + (with-auth (instance users/add-service "users-modify") + (setf (title instance) "Users - Add") + (with-resume-database + (let* ((auth-pkg (make-instance 'auth-pkg)) + (user (get-user)) + (role-groups (get-all-role-groups auth-pkg user))) + (setf (form instance) (make-form "users-add-form" + nil + t + `((:name "first_name" :label "First Name" :field-type "text" :required "required") + (:name "last_name" :label "Last Name" :field-type "text" :required "required") + (:name "email" :label "Email" :field-type "text" :required "required") + ,@(role-checkboxes role-groups) + (:label "Add User" :field-type "button" :onclick "on_users_add_submit_clicked()")))))))) + +(defun users-add-submit-json (role_groups first_name last_name email) + (declare (special role_groups first_name last_name email)) + (with-auth (instance users/add-service "users-modify") + (with-resume-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))) + (let* ((auth-pkg (make-instance 'auth-pkg)) + (id (insert-registration auth-pkg registration))) + (setf registration (get-registration-by-id auth-pkg id))) + (handler-case + (let ((text-message (format nil + "Hello ~a ~a and welcome to the ~a website!~%~%A user account registration has been created for you. It expires in 3 days.~%~%Please click the following link to complete the registration:~%~%~a://~a/register?hash=~a~%" + (name *webapp*) + (first_name registration) + (last_name registration) + (scheme *webapp*) + (url *webapp*) + (hash registration))) + (html-message (org-ckons-http::html5 + `(html + ((p) + ,(format nil + "Hello ~a ~a and welcome to ~a!" + (name *webapp*) + (first_name registration) + (last_name registration))) + ((p) "A user account registration has been created for you. It expires in 3 days.") + ((p) "Please click the following link to complete the registration:") + ((p) + ((a :href ,(format nil + "~a://~a/register?hash=~a" + (scheme *webapp*) + (url *webapp*) + (hash registration))) + ,(format nil + "~a://~a/register?hash=~a" + (scheme *webapp*) + (url *webapp*) + (hash registration)))))))) + (org-ckons-core::sendmail (mail-mx *webapp*) + (mail-info *webapp*) + (email registration) + (format nil "~a website registration" (name *webapp*)) + text-message + :html-message html-message + :reply-to (mail-postmaster *webapp*) + :ssl (mail-ssl *webapp*) + :authentication (mail-authentication *webapp*)) + (setf (session-value :message) (format nil "Email sent successfully to ~a" (email registration)))) + (error (e) + (setf (session-value :errormsg) (format nil "Error sending email to ~a. Registration failed. ~a" (email registration) e)))))))) + +(defclass users/register-service (rest-service) + ((title :initarg :title + :initform nil + :accessor title) + (hash :initarg :hash + :initform nil + :accessor hash)) + (:documentation "")) + +(defun users-register-json (hash) + (with-noauth (instance users/register-service) + (setf (title instance) "New User Registration") + (setf (hash instance) hash))) + +(defclass users/register/form-service (rest-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defun users-register-form-json (hash) + (with-noauth (instance users/register/form-service) + (with-resume-database + (let* ((auth-pkg (make-instance 'auth-pkg)) + (registration (get-registration-by-hash auth-pkg hash))) + (registrations-gc auth-pkg) + (if registration + (progn + (setf (form instance) + (make-form "users-register-form" + nil + t + `((:name "hash" :field-type "hidden" :value ,(hash registration) :required "required") + (:name "username" :label "Username" :field-type "text" :required "required") + (:name "pwd" :label "Password" :field-type "password" :required "required") + (:name "pwd2" :label "Password (again)" :field-type "password" :required "required") + (:name "phone" :label "Phone" :field-type "text") + (:label "Register" :field-type "button" :onclick "on_users_register_submit_clicked()")))) + (setf (session-value :message) "Registered successfully.")) + (setf (session-value :errormsg) "Error: invalid registration.")))))) + +(defclass users/register/submit-service (rest-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun users-register-submit-json (hash username pwd pwd2 phone) + (with-noauth (instance users/register/submit-service) + (with-resume-database + (let ((auth-pkg (make-instance 'auth-pkg)) + registration) + (registrations-gc auth-pkg) + (setf registration (get-registration-by-hash auth-pkg hash)) + (org-ckons-json::objects-to-json + `(,(if registration + (if (string= pwd pwd2) + (let ((user (make-instance 'user + :username username + :pwd pwd + :first_name (first_name registration) + :last_name (last_name registration) + :email (email registration) + :phone phone + :active t))) + (if (insert-user auth-pkg user) + (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))) + (delete-registration auth-pkg hash) + (setf (session-value :message) "Registration completed successfully.")) + (setf (session-value :errormsg) "Error while completing registration."))) + (setf (session-value :errormsg) "Error: passwords do not match.")) + (setf (session-value :errormsg) "Error while completing registration.")))))))) + +(defclass users/modify-service (users/add-service) + () + (:documentation "")) + +(defun users-modify-json (id) + (with-auth (instance users/modify-service "users-modify") + (setf (title instance) "Users - Modify") + (with-resume-database + (let* ((auth-pkg (make-instance 'auth-pkg)) + (me (get-user)) + (user (get-user-by-id auth-pkg id)) + (role-groups (get-all-role-groups auth-pkg me)) + (active-role-groups (get-active-role-groups auth-pkg user))) + (if user + (setf (form instance) (make-form "users-modify-form" + nil + t + `((:name "id" :field-type "hidden" :value ,(id user) :required "required") + (:name "username" :label "Username" :field-type "text" :value ,(username user) :required "required") + (:name "first_name" :label "First Name" :field-type "text" :value ,(first_name user) :required "required") + (:name "last_name" :label "Last Name" :field-type "text" :value ,(last_name user) :required "required") + (:name "email" :label "Email" :field-type "text" :value ,(email user) :required "required") + (:name "phone" :label "Phone" :field-type "text" :value ,(phone user)) + ,@(role-checkboxes role-groups active-role-groups) + (:label "Modify User" :field-type "button" :onclick "on_users_modify_submit_clicked()")))) + (setf (session-value :errormsg) "Error: could not modify user. Not found.")))))) + +(defun users-modify-submit-json (id role_groups username first_name last_name email phone) + (declare (special role_groups username first_name last_name email phone)) + (with-auth (instance users/modify-service "users-modify") + (with-resume-database + (let* ((auth-pkg (make-instance 'auth-pkg)) + (user (get-active-user-by-id auth-pkg id))) + (if user + (progn + (loop for param in (remove-if (lambda (x) + (intersection `(,x) '(id role_groups))) + (sb-introspect:function-lambda-list #'users-modify-submit-json)) + do (setf (slot-value user param) (symbol-value param))) + (update-user auth-pkg user) + (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))) + (setf (session-value :message) "User saved successfully.")) + (setf (session-value :errormsg) "An error occured.")))))) + +(defclass users/toggle-service (users/add-service) + () + (:documentation "")) + +(defun users-toggle-active-json (id) + (with-auth (instance users/toggle-service "users-modify") + (with-resume-database + (let* ((auth-pkg (make-instance 'auth-pkg)) + (user (get-user-by-id auth-pkg id))) + (if user + (if (= (id user) (id (get-user))) + (setf (session-value :errormsg) "Error: you may not toggle your own active state.") + (progn + (user-toggle-active auth-pkg user) + (setf (session-value :errormsg) nil) + (setf (session-value :message) "User active state toggled successfully."))) + (setf (session-value :errormsg) "Error: could not toggle the active state of the user: not found.")))))) + +(defclass users/delete-service (users/add-service) + () + (:documentation "")) + +(defun users-delete-json (id) + (with-auth (instance users/delete-service "users-modify") + (with-resume-database + (let* ((auth-pkg (make-instance 'auth-pkg)) + (user (get-user-by-id auth-pkg id))) + (if user + (if (= (id user) (id (get-user))) + (setf (session-value :errormsg) "Error: you may not delete yourself.") + (progn + (deactivate-user auth-pkg user) + (setf (session-value :errormsg) nil) + (setf (session-value :message) "User deleted successfully."))) + (setf (session-value :errormsg) "Error: could not delete user: not found.")))))) diff --git a/lisp/sql/about-us.lisp b/lisp/sql/about-us.lisp new file mode 100644 index 0000000..43c7216 --- /dev/null +++ b/lisp/sql/about-us.lisp @@ -0,0 +1,18 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass about-us (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (category :initarg :category + :initform nil + :accessor category) + (content :initarg :content + :initform nil + :accessor content) + (*table :initform "general.about_us") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a general.about_us type.")) diff --git a/lisp/sql/auth-pkg.lisp b/lisp/sql/auth-pkg.lisp new file mode 100644 index 0000000..8bb6aef --- /dev/null +++ b/lisp/sql/auth-pkg.lisp @@ -0,0 +1,205 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defparameter *authenticated-user-session-key* "authenticated-user") + +(defclass auth-pkg (record-pkg) + () + (:documentation "")) + +(defmethod insert-user ((auth-pkg auth-pkg) user) + (setf (*table user) (format nil + "auth.insert_user('~a', '~a', '~a', '~a', '~a', '~a', '~a')" + (username user) + (pwd user) + (first_name user) + (last_name user) + (email user) + (phone user) + (active user))) + (setf (id user) (caar (call-pg-function auth-pkg user))) + (id user)) + +(defmethod update-user ((auth-pkg auth-pkg) user) + (setf (*table user) (format nil + "auth.update_user(~a, '~a', '~a', '~a', '~a', '~a')" + (id user) + (username user) + (first_name user) + (last_name user) + (email user) + (phone user))) + (caar (call-pg-function auth-pkg user))) + +(defmethod get-all-active-users ((auth-pkg auth-pkg)) + (let ((user (make-instance 'user))) + (setf (*table user) "auth.get_all_active_users()") + (get-records auth-pkg user "first_name asc, last_name asc"))) + +(defmethod get-all-users ((auth-pkg auth-pkg)) + (let ((user (make-instance 'user))) + (setf (*table user) "auth.get_all_users()") + (get-records auth-pkg user "first_name asc, last_name asc"))) + +(defmethod get-active-user-by-username-pwd ((auth-pkg auth-pkg) username pwd) + (let ((user (make-instance 'user))) + (setf (*table user) (format nil + "auth.get_active_user_by_username_pwd('~a', '~a')" + username + pwd)) + (get-record auth-pkg user))) + +(defmethod get-active-user-by-id ((auth-pkg auth-pkg) id) + (let ((user (make-instance 'user))) + (setf (*table user) (format nil "auth.get_active_user_by_id(~a)" id)) + (get-record auth-pkg user))) + +(defmethod get-user-by-id ((auth-pkg auth-pkg) id) + (let ((user (make-instance 'user))) + (setf (*table user) (format nil "auth.get_user_by_id(~a)" id)) + (get-record auth-pkg user))) + +(defmethod user-toggle-active ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil "auth.user_toggle_active(~a)" (id user))) + (call-pg-function auth-pkg user)) + +(defmethod deactivate-user ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil "auth.user_delete(~a)" (id user))) + (call-pg-function auth-pkg user)) + +(defmethod get-all-roles ((auth-pkg auth-pkg) (user user)) + (let ((user-role (make-instance 'user-role + :*table (format nil + "auth.get_all_roles_for_user(~a)" + (id user))))) + (get-records auth-pkg user-role nil))) + +(defmethod has-role ((auth-pkg auth-pkg) (user user) role) + (let ((user-role (make-instance 'user-role))) + (setf (*table user-role) (format nil (*table user-role) (id user) role)) + (get-record auth-pkg user-role))) + +(defmethod get-all-role-groups ((auth-pkg auth-pkg) (user user)) + (let ((role-group (make-instance 'role-group))) + (setf (*table role-group) (format nil (*table role-group) (id user))) + (get-records auth-pkg role-group nil))) + +(defmethod get-role-group-by-name ((auth-pkg auth-pkg) (user user) name) + (find-if (lambda (x) + (string= name (name x))) + (get-all-role-groups auth-pkg user))) + +(defmethod get-active-role-groups ((auth-pkg auth-pkg) (user user)) + (let ((role-group (make-instance 'role-group + :*table (format nil + "auth.get_active_role_groups_for_user(~a)" + (id user))))) + (get-records auth-pkg role-group nil))) + +(defmethod insert-user-role-group ((auth-pkg auth-pkg) (user-role user-role)) + (setf (*table user-role) (format nil + "auth.insert_user_role_group(~a, '~a')" + (user_id user-role) + (role_group_name user-role))) + (caar (call-pg-function auth-pkg user-role))) + +(defmethod insert-registration ((auth-pkg auth-pkg) (registration registration)) + (setf (*table registration) (format nil + "auth.insert_registration('~a', '~a', '~a', '~a')" + (first_name registration) + (last_name registration) + (email registration) + (role_groups registration))) + (setf (id registration) (caar (call-pg-function auth-pkg registration))) + (id registration)) + +(defmethod delete-role-groups ((auth-pkg auth-pkg) user) + (let ((role-group (make-instance 'role-group + :*table (format nil + "auth.delete_role_groups_for_user(~a)" + (id user))))) + (call-pg-function auth-pkg role-group))) + +(defmethod get-registration-by-id ((auth-pkg auth-pkg) id) + (let ((registration (make-instance 'registration + :*table (format nil "auth.get_registration_by_id(~a)" id)))) + (get-record auth-pkg registration))) + +(defmethod get-registration-by-hash ((auth-pkg auth-pkg) hash) + (let ((registration (make-instance 'registration + :*table (format nil "auth.get_registration_by_hash('~a')" hash)))) + (get-record auth-pkg registration))) + +(defmethod registrations-gc ((auth-pkg auth-pkg)) + (let ((registration (make-instance 'registration :*table "auth.registrations_gc()"))) + (call-pg-function auth-pkg registration))) + +(defmethod delete-registration ((auth-pkg auth-pkg) hash) + (let ((registration (make-instance 'registration + :*table (format nil "auth.delete_registration('~a')" hash)))) + (call-pg-function auth-pkg registration))) + +(defmethod update-profile ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil + "auth.update_profile(~a, '~a', '~a', '~a', '~a', '~a')" + (id user) + (username user) + (first_name user) + (last_name user) + (email user) + (phone user))) + (call-pg-function auth-pkg user)) + +(defmethod update-password ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil "auth.update_password(~a, '~a')" (id user) (pwd user))) + (call-pg-function auth-pkg user)) + +(defmacro with-valid-user ((session-name roles) error-body &body body) + "Runs `body' if there is a valid authenticated `user' in the +`user-session' whose roles match `roles', otherwise runs +`error-body'. If a valid `user' exists, it will be bound to +`session-name'." + `(let ((,session-name (get-session-object *authenticated-user-session-key*))) + (if ,session-name + (let* ((auth-pkg (make-instance 'auth-pkg)) + (has-all-roles-p (let ((has-all-roles-p t)) + (with-resume-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))) + has-all-roles-p)))) + (if has-all-roles-p + ,@body + ,error-body)) + ,error-body))) + +(defun make-default-user () + "Convenience function for making a new instance of `user' that has +its session key set to `authenticated-user', but has no privileges." + (make-instance 'user + :*session-key *authenticated-user-session-key* + :id 0 + :first_name "Guest" + :last_name "User")) + +(defun ensure-user-exists () + "Ensures that there is an `authenticated-user' in the user session, +even if it's just a guest user." + (let ((user (get-session-object *authenticated-user-session-key*))) + (unless user + (setf user (make-default-user)) + (set-user user)))) + +(defun get-user () + "Convenience function for getting the `authenticated-user' from the +user session." + (get-session-object *authenticated-user-session-key*)) + +(defun set-user (user) + "Convenience function for setting the `authenticated-user' into the +user session." + (setf (*table user) "auth.users") + (setf (pwd user) nil) + (set-session-object *authenticated-user-session-key* user)) diff --git a/lisp/sql/contact-pkg.lisp b/lisp/sql/contact-pkg.lisp new file mode 100644 index 0000000..dce6384 --- /dev/null +++ b/lisp/sql/contact-pkg.lisp @@ -0,0 +1,32 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass contact-pkg (record-pkg) + () + (:documentation "")) + +(defmethod get-contact-us-posts ((contact-pkg contact-pkg) user-id read-p) + (let ((contact-us-post (make-instance 'contact-us-post))) + (setf (*table contact-us-post) (format nil (*table contact-us-post) user-id (if read-p "t" "f"))) + (get-records contact-pkg contact-us-post nil))) + +(defmethod insert-contact-us-post ((contact-pkg contact-pkg) (contact-us-post contact-us-post)) + (setf (*table contact-us-post) (format nil + "contact.insert_contact_us_post('~a', '~a', '~a', '~a', '~a')" + (first_name contact-us-post) + (last_name contact-us-post) + (email contact-us-post) + (phone contact-us-post) + (comments contact-us-post))) + (caar (call-pg-function contact-pkg contact-us-post))) + +(defmethod mark-contact-us-post ((contact-pkg contact-pkg) contact-us-post-id user-id read-p) + (let ((contact-us-post (make-instance 'contact-us-post + :*table (format nil + "contact.mark_contact_us_post(~a, ~a, '~a')" + contact-us-post-id + user-id + (if read-p "t" "f"))))) + (call-pg-function contact-pkg contact-us-post))) diff --git a/lisp/sql/contact-us.lisp b/lisp/sql/contact-us.lisp new file mode 100644 index 0000000..07854bc --- /dev/null +++ b/lisp/sql/contact-us.lisp @@ -0,0 +1,50 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass contact-us (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (content :initarg :content + :initform nil + :accessor content) + (*table :initform "contact.contact_us") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a contact.contact_us type.")) + +(defclass contact-us-post (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (first_name :initarg :first_name + :initform nil + :accessor first_name) + (last_name :initarg :last_name + :initform nil + :accessor last_name) + (email :initarg :email + :initform nil + :accessor email) + (phone :initarg :phone + :initform nil + :accessor phone) + (submitted :initarg :submitted + :initform nil) + (comments :initarg :comments + :initform nil + :accessor comments) + (*table :initform "contact.get_contact_us_posts_by_id_and_read(~a, '~a')") + (*where-expression :initform nil)) + (:documentation "Holds the data for a contact.contact_us_posts type.")) + +(defmethod submitted ((contact-us-post contact-us-post)) + (slot-value contact-us-post 'submitted)) + +(defmethod (setf submitted) (value (contact-us-post contact-us-post)) + (handler-case + (setf (slot-value contact-us-post 'submitted) (simple-date-to-date value)) + (error (e) + (declare (ignore e)) + (setf (slot-value contact-us-post 'submitted) nil)))) diff --git a/lisp/sql/general-pkg.lisp b/lisp/sql/general-pkg.lisp new file mode 100644 index 0000000..0c7421c --- /dev/null +++ b/lisp/sql/general-pkg.lisp @@ -0,0 +1,11 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass general-pkg (record-pkg) + () + (:documentation "")) + +(defmethod get-about-us ((general-pkg general-pkg) category) + (get-record general-pkg (make-instance 'about-us :category category))) diff --git a/lisp/sql/generics.lisp b/lisp/sql/generics.lisp new file mode 100644 index 0000000..3118823 --- /dev/null +++ b/lisp/sql/generics.lisp @@ -0,0 +1,143 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defmacro with-resume-database (&body body) + `(with-database (getf (databases *webapp*) :db-resume) ,@body)) + +(defgeneric insert-user (auth-pkg user) + (:documentation "Inserts a new user into the database.")) + +(defgeneric update-user (auth-pkg user) + (:documentation "Updates a user in the database.")) + +(defgeneric get-all-active-users (record-pkg) + (:documentation "Calls `get_all_active_users'.")) + +(defgeneric get-all-users (record-pkg) + (:documentation "Calls `get_all_users'.")) + +(defgeneric get-active-user-by-username-pwd (record-pkg username pwd) + (:documentation "Calls `get_active_user_by_username_pwd'.")) + +(defgeneric get-active-user-by-id (record-pkg id) + (:documentation "Calls `get_active_user_by_id'.")) + +(defgeneric get-user-by-id (record-pkg id) + (:documentation "Calls `get_user_by_id'.")) + +(defgeneric user-toggle-active (record-pkg user) + (:documentation "Calls `user_toggle_active'.")) + +(defgeneric user-delete (record-pkg user) + (:documentation "Calls `user_delete'.")) + +(defgeneric get-all-roles (record-pkg record) + (:documentation "Returns all the roles for a `user'.")) + +(defgeneric has-role (record-pkg record role) + (:documentation "Returns `t' when the user exists and has the +specified `role', `nil' otherwise.")) + +(defgeneric get-all-role-groups (auth-pkg user) + (:documentation "Returns all the role-groups for a `user'.")) + +(defgeneric get-role-group-by-name (auth-pkg user name) + (:documentation "Returns a role-group by `name' for a `user'.")) + +(defgeneric get-active-role-groups (auth-pkg user) + (:documentation "Returns all the role-groups for a `user' that are +actually present in `auth.users_role_groups', in other words the +role-groups that are assigned to the user without any superuser +magic.")) + +(defgeneric insert-user-role-group (auth-pkg user-role) + (:documentation "Idempotently inserts a new record into +auth.user_role_groups based on the user ID and the role group name.")) + +(defgeneric delete-role-groups (auth-pkg user) + (:documentation "Delete all role-group assignments for a user.")) + +(defgeneric update-profile (record-pkg record) + (:documentation "")) + +(defgeneric update-password (auth-pkg user) + (:documentation "")) + +(defgeneric get-user-sessions (record-pkg) + (:documentation "Gets all user session records.")) + +(defgeneric get-user-session (record-pkg &optional sessionid) + (:documentation "")) + +(defgeneric update-timestamp (record-pkg record) + (:documentation "Updates the timestamp of the `user-session'.")) + +(defgeneric get-user-session-objects (record-pkg record) + (:documentation "Get all user session objects associated with a user +session.")) + +(defgeneric get-user-session-object (record-pkg session-key) + (:documentation "")) + +(defgeneric flush-user-session-object (record-pkg session-key) + (:documentation "")) + +(defgeneric create-user-session (record-pkg) + (:documentation "Creates a new user session and returns the +sessionid.")) + +(defgeneric get-about-us (record-pkg category) + (:documentation "Gets the one and only general.about_us record with the given +`category'.")) + +(defgeneric get-contact-us-posts (record-pkg user-id read-p) + (:documentation "Gets contact.contact_us_posts records.")) + +(defgeneric insert-contact-us-post (contact-pkg contact-us-post) + (:documentation "Inserts a new contact-us post into +contact.contact_us_posts. Returns the ID of the new record.")) + +(defgeneric mark-contact-us-post (contact-pkg contact-us-post-id user-id read-p) + (:documentation "Marks or unmarks a contact-us post as read.")) + +(defgeneric insert-registration (auth-pkg registration) + (:documentation "Inserts a new registration into +auth.registrations. Returns the ID of the new record.")) + +(defgeneric get-registration-by-id (auth-pkg id) + (:documentation "Gets the record from auth.registrations with the +given `id'.")) + +(defgeneric get-registration-by-hash (auth-pkg hash) + (:documentation "Gets the record from auth.registrations with the +given `hash'.")) + +(defgeneric registrations-gc (auth-pkg) + (:documentation "Garbage collects registrations that are more than 3 +days old.")) + +(defgeneric delete-registration (auth-pkg hash) + (:documentation "Deletes a registration with the given `hash'.")) + +(defgeneric event_date (record) + (:documentation "Reader for the event_date field. Converts a +local-time::timestamp to a SQL date string.")) + +(defgeneric (setf event_date) (value record) + (:documentation "Writer for the event_date field.")) + +(defgeneric submitted (record) + (:documentation "Reader for the submitted field. Converts a +local-time::timestamp to a SQL date string.")) + +(defgeneric (setf submitted) (value record) + (:documentation "Writer for the submitted field.")) + +(defgeneric created (record) + (:documentation "Reader for the created field. Converts a +local-time::timestamp to a SQL date string.")) + +(defgeneric (setf created) (value record) + (:documentation "Writer for the created field.")) diff --git a/lisp/sql/registration.lisp b/lisp/sql/registration.lisp new file mode 100644 index 0000000..5ca227c --- /dev/null +++ b/lisp/sql/registration.lisp @@ -0,0 +1,42 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass registration (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (hash :initarg :hash + :initform nil + :accessor hash) + (first_name :initarg :first_name + :initform nil + :accessor first_name) + (last_name :initarg :last_name + :initform nil + :accessor last_name) + (email :initarg :email + :initform nil + :accessor email) + (role_groups :initarg :role_groups + :initform nil + :accessor role_groups) + (created :initarg :created + :initform nil) + (valid_for :initarg :valid_for + :initform nil + :accessor valid_for) + (*table :initform "auth.registrations") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for an auth.registrations type.")) + +(defmethod created ((registration registration)) + (slot-value registration 'created)) + +(defmethod (setf created) (value (registration registration)) + (handler-case + (setf (slot-value registration 'created) (simple-date-to-date value)) + (error (e) + (declare (ignore e)) + (setf (slot-value registration 'created) nil)))) diff --git a/lisp/sql/role-group.lisp b/lisp/sql/role-group.lisp new file mode 100644 index 0000000..4cdc99b --- /dev/null +++ b/lisp/sql/role-group.lisp @@ -0,0 +1,24 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass role-group (postgres-record) + ((user_role_group_id :initarg :user_role_group_id + :initform nil + :accessor user_role_group_id) + (user_id :initarg :user_id + :initform nil + :accessor user_id) + (role_group_id :initarg :role_group_id + :initform nil + :accessor role_group_id) + (name :initarg :name + :initform nil + :accessor name) + (description :initarg :description + :initform nil + :accessor description) + (*table :initform "auth.get_all_role_groups_for_user(~a)") + (*where-expression :initform nil)) + (:documentation "Holds the data for an auth.role_group_t type.")) diff --git a/lisp/sql/user-role.lisp b/lisp/sql/user-role.lisp new file mode 100644 index 0000000..077f496 --- /dev/null +++ b/lisp/sql/user-role.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass user-role (postgres-record) + ((user_role_group_id :initarg :user_role_group_id + :initform nil + :accessor user_role_group_id) + (user_id :initarg :user_id + :initform nil + :accessor user_id) + (role_group_id :initarg :role_group_id + :initform nil + :accessor role_group_id) + (role_group_name :initarg :role_group_name + :initform nil + :accessor role_group_name) + (role_group_description :initarg :role_group_description + :initform nil + :accessor role_group_description) + (role_group_role_id :initarg :role_group_role_id + :initform nil + :accessor role_group_role_id) + (role_id :initarg :role_id + :initform nil + :accessor role_id) + (role_name :initarg :role_name + :initform nil + :accessor role_name) + (role_description :initarg :role_description + :initform nil + :accessor role_description) + (*table :initform "auth.has_role(~a, '~a')") + (*where-expression :initform nil)) + (:documentation "Holds the data for an auth.user_role_t type.")) diff --git a/lisp/sql/user-session-pkg.lisp b/lisp/sql/user-session-pkg.lisp new file mode 100644 index 0000000..45c47d2 --- /dev/null +++ b/lisp/sql/user-session-pkg.lisp @@ -0,0 +1,116 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defvar *user-session-mutex* (sb-thread:make-mutex :name "*user-session-mutex*")) + +(defclass user-session-pkg (record-pkg) + () + (:documentation "Database-backed user session API.")) + +(defmethod get-user-sessions ((user-session-pkg user-session-pkg)) + (get-records user-session-pkg (make-instance 'user-session) "sessionid ASC")) + +(defmethod get-user-session ((user-session-pkg user-session-pkg) &optional (sessionid *sessionid*)) + (when sessionid + (get-record user-session-pkg (make-instance 'user-session :sessionid sessionid)))) + +(defmethod update-timestamp ((user-session-pkg user-session-pkg) (user-session user-session)) + (setf (datetime user-session) (get-universal-time)) + (update-record user-session-pkg user-session)) + +(defmethod get-user-session-objects ((user-session-pkg user-session-pkg) (user-session user-session)) + (get-records user-session-pkg (make-instance 'user-session-object :user_session_id (id user-session)) "session_key ASC")) + +(defmethod get-user-session-object ((user-session-pkg user-session-pkg) session-key) + (when (and *sessionid* session-key) + (let ((user-session (get-user-session user-session-pkg))) + (when user-session + (get-record user-session-pkg (make-instance 'user-session-object :user_session_id (id user-session) :session_key session-key)))))) + +(defmethod flush-user-session-object ((user-session-pkg user-session-pkg) session-key) + (when (and *sessionid* session-key) + (let ((user-session-object (get-user-session-object user-session-pkg session-key))) + (when user-session-object + (delete-record user-session-pkg user-session-object))))) + +(defmethod create-user-session ((user-session-pkg user-session-pkg)) + (let* ((sessionid (org-ckons-session::generate-sessionid)) + (user-session (make-instance 'user-session :sessionid sessionid :datetime (get-universal-time)))) + (insert-record user-session-pkg user-session) + sessionid)) + +(defun get-session-object (session-key) + "Returns the object stored in the user session under the given +`session-key'." + (with-resume-database + (let* ((user-session-pkg (make-instance 'user-session-pkg)) + (user-session-object (get-user-session-object user-session-pkg session-key)) + object) + (when user-session-object + (setf object (org-ckons-serializable::deserialize (serialization user-session-object))) + (setf (org-ckons-session::*session-key object) session-key)) + object))) + +(defun set-session-object (session-key object) + "Sets the object into the user-session under the given +`session-key'. Will not write anything if the session given by +`*sessionid*' does not exist." + (with-resume-database + (let* ((user-session-pkg (make-instance 'user-session-pkg)) + (user-session-object (get-user-session-object user-session-pkg session-key))) + (if user-session-object + ;; overwrite existing session object with current serialization + (progn + (setf (serialization user-session-object) (org-ckons-serializable::serialize object :package-name (package-name #.*package*))) + (update-record user-session-pkg user-session-object)) + ;; insert a new object into the session + (let ((user-session (get-user-session user-session-pkg))) + (when user-session + (setf user-session-object (make-instance 'user-session-object + :user_session_id (id user-session) + :session_key session-key + :serialization (org-ckons-serializable::serialize object :package-name (package-name #.*package*)))) + (insert-record user-session-pkg user-session-object))))))) + +(defun flush-session-object (session-key) + "Removes the object from the user session under the given +`session-key'." + (with-resume-database + (let ((user-session-pkg (make-instance 'user-session-pkg))) + (flush-user-session-object user-session-pkg *sessionid* session-key)))) + +(defun ensure-user-session-exists (&optional force-new-sessionid-p) + "Ensures that the user has a valid sessionid cookie. Returns the +`sessionid'. If the session does exist, update its timestamp." + (sb-thread:with-mutex (*user-session-mutex*) + (run-garbage-collect-cycle) + (with-resume-database + (let* ((user-session-pkg (make-instance 'user-session-pkg)) + (sessionid (when (not force-new-sessionid-p) + (org-ckons-session::get-sessionid-from-request))) + (user-session (get-user-session user-session-pkg sessionid))) + (if user-session + (update-timestamp user-session-pkg user-session) + (progn + (setf sessionid (create-user-session user-session-pkg)) + (org-ckons-session::set-sessionid-cookie *header-register* sessionid))) + sessionid)))) + +(defun run-garbage-collect-cycle () + "Goes through all the user sessions, expiring any that have remained +inactive for a period of time determined by the `*session-timeout*' +variable." + (when (> (- (get-universal-time) org-ckons-session::*gc-last-cycle-timestamp*) org-ckons-session::*gc-interval*) + (setf org-ckons-session::*gc-last-cycle-timestamp* (get-universal-time)) + (with-resume-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)))))))) diff --git a/lisp/sql/user-session.lisp b/lisp/sql/user-session.lisp new file mode 100644 index 0000000..47ff31c --- /dev/null +++ b/lisp/sql/user-session.lisp @@ -0,0 +1,35 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass user-session (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (sessionid :initarg :sessionid + :initform nil + :accessor sessionid) + (datetime :initarg :datetime + :initform nil + :accessor datetime) + (*table :initform "auth.user_sessions") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a auth.user_session record.")) + +(defclass user-session-object (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (user_session_id :initarg :user_session_id + :initform nil + :accessor user_session_id) + (session_key :initarg :session_key + :initform nil + :accessor session_key) + (serialization :initarg :serialization + :initform nil + :accessor serialization) + (*table :initform "auth.user_session_objects") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a auth.user_session record.")) diff --git a/lisp/sql/user.lisp b/lisp/sql/user.lisp new file mode 100644 index 0000000..89d9c7d --- /dev/null +++ b/lisp/sql/user.lisp @@ -0,0 +1,50 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defclass user (org-ckons-session::session-object postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (username :initarg :username + :initform nil + :accessor username) + (pwd :initarg :pwd + :initform nil + :accessor pwd) + (first_name :initarg :first_name + :initform nil + :accessor first_name) + (last_name :initarg :last_name + :initform nil + :accessor last_name) + (email :initarg :email + :initform nil + :accessor email) + (phone :initarg :phone + :initform nil + :accessor phone) + (active :initarg :active + :initform nil + :accessor active) + (created :initarg :created + :initform nil) + (*table :initform "auth.users") + (*where-expression :initform "id = ~a") + (org-ckons-session::*session-key :initform "user")) + (:documentation "Holds the data for a user record.")) + +(defmethod created ((user user)) + (slot-value user 'created)) + +(defmethod (setf created) (value (user user)) + (handler-case + (setf (slot-value user 'created) (simple-date-to-date value)) + (error (e) + (declare (ignore e)) + (setf (slot-value user 'created) nil)))) + +(defmethod sanitize-json ((user user)) + (setf (pwd user) nil) + (call-next-method)) diff --git a/lisp/webapps/generics.lisp b/lisp/webapps/generics.lisp new file mode 100644 index 0000000..33145ba --- /dev/null +++ b/lisp/webapps/generics.lisp @@ -0,0 +1,12 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defgeneric get-site-file-path (webapp) + (:documentation "Builds a full filesystem path to a webapp's site +file.")) + +(defgeneric get-pages-file-paths (webapp) + (:documentation "")) + diff --git a/lisp/webapps/resume/cljs-out b/lisp/webapps/resume/cljs-out new file mode 120000 index 0000000..7f17999 --- /dev/null +++ b/lisp/webapps/resume/cljs-out @@ -0,0 +1 @@ +clojurescript/resume/resources/public/cljs-out
\ No newline at end of file diff --git a/lisp/webapps/resume/clojurescript/resume/.gitignore b/lisp/webapps/resume/clojurescript/resume/.gitignore new file mode 100644 index 0000000..77c3a20 --- /dev/null +++ b/lisp/webapps/resume/clojurescript/resume/.gitignore @@ -0,0 +1,16 @@ +target +classes +resources +checkouts +pom.xml +pom.xml.asc +*.jar +*.class +.lein-* +.nrepl-port +.rebel_readline_history +.hgignore +.hg +figwheel-main.edn +figwheel_server.log +.rebel_readline_history diff --git a/lisp/webapps/resume/clojurescript/resume/dev.cljs.edn b/lisp/webapps/resume/clojurescript/resume/dev.cljs.edn new file mode 100644 index 0000000..b2a7ff0 --- /dev/null +++ b/lisp/webapps/resume/clojurescript/resume/dev.cljs.edn @@ -0,0 +1,2 @@ +^{:watch-dirs ["src"]} +{:main resume.core} diff --git a/lisp/webapps/resume/clojurescript/resume/project.clj b/lisp/webapps/resume/clojurescript/resume/project.clj new file mode 100644 index 0000000..a19d784 --- /dev/null +++ b/lisp/webapps/resume/clojurescript/resume/project.clj @@ -0,0 +1,24 @@ +(defproject resume.core "0.1.0-SNAPSHOT" + :description "FIXME" + :url "FIXME" + :license "public domain" + :min-lein-version "2.7.1" + :dependencies [[org.clojure/clojure "LATEST"] + [org.clojure/clojurescript "LATEST"] + [cljs-ajax "LATEST"] + [prismatic/dommy "LATEST"] + [hiccups "LATEST"] + [cljsjs/showdown "LATEST"] + [com.andrewmcveigh/cljs-time "LATEST"] + [cljsjs/react "LATEST"] + [cljsjs/react-dom "LATEST"] + [cljsjs/react-dom-server "LATEST"] + [reagent "LATEST"]] + :source-paths ["src"] + :aliases {"fig:build" ["trampoline" "run" "-m" "figwheel.main" "-b" "dev" "-r"] + "fig:min" ["run" "-m" "figwheel.main" "-O" "advanced" "-bo" "dev"]} + :profiles {:dev {:dependencies [[com.bhauman/figwheel-main "LATEST"] + [org.slf4j/slf4j-nop "LATEST"] + [com.bhauman/rebel-readline-cljs "LATEST"]] + :resource-paths ["target"] + :clean-targets ^{:protect false} ["target"]}}) diff --git a/lisp/webapps/resume/clojurescript/resume/src/core.cljs b/lisp/webapps/resume/clojurescript/resume/src/core.cljs new file mode 100644 index 0000000..7010a88 --- /dev/null +++ b/lisp/webapps/resume/clojurescript/resume/src/core.cljs @@ -0,0 +1,1073 @@ +(ns resume.core + (:require-macros [hiccups.core :as hiccups :refer [html]]) + (:require [ajax.core :refer [GET POST PUT DELETE raw-response-format]] + [dommy.core :as dommy] + [hiccups.runtime :as hiccupsrt] + [cljsjs.showdown :as showdown] + [clojure.string :as str] + [cljs-time.format :as time-format] + [reagent.core :as r] + [reagent.dom :as rd] + [reagent.dom.client :as rdc] + [org-ckons-cljs.notifications.react :as ck-notifications] + [org-ckons-cljs.form.core :as ck-form])) + +;; declarations + +(declare date-sql-to-pretty) +(declare markdown-to-html) +(declare reduce-checkboxes) +(declare comp-app) +(declare start-render) +(declare start-location) +(declare reset-location) +(declare start) +(declare notifications) +(declare auth-notifications) +(declare comp-menu-main) +(declare comp-menu-user) +(declare handler-menu) +(declare handler-menu-user) +(declare render-menu) +(declare comp-home) +(declare handler-home) +(declare render-home) +(declare template-login) +(declare handler-login) +(declare render-login) +(declare on-login-submit-clicked) +(declare handler-login-authenticate) +(declare render-login-authenticate) +(declare handler-logout) +(declare render-logout) +(declare template-profile) +(declare handler-profile) +(declare render-profile) +(declare template-profile-view) +(declare handler-profile-view) +(declare render-profile-view) +(declare on-profile-modify-clicked) +(declare template-profile-modify) +(declare handler-profile-modify) +(declare render-profile-modify) +(declare on-profile-modify-submit-clicked) +(declare handler-profile-modify-submit) +(declare render-profile-modify-submit) +(declare template-password) +(declare handler-password) +(declare render-password) +(declare on-password-submit-clicked) +(declare handler-password-submit) +(declare render-password-submit) +(declare template-about-us) +(declare handler-about-us) +(declare render-lessons) +(declare template-about-us-view) +(declare handler-about-us-view) +(declare render-about-us-view) +(declare on-about-us-modify-clicked) +(declare template-about-us-modify) +(declare handler-about-us-modify) +(declare render-about-us-modify) +(declare on-about-us-modify-submit-clicked) +(declare handler-about-us-modify-submit) +(declare render-about-us-modify-submit) +(declare template-contact-us) +(declare handler-contact-us) +(declare render-contact-us) +(declare template-contact-us-view) +(declare handler-contact-us-view) +(declare render-contact-us-view) +(declare on-contact-us-email-submit-clicked) +(declare handler-contact-us-email-submit) +(declare render-contact-us-email-submit) +(declare template-messages) +(declare handler-messages) +(declare render-messages) +(declare on-messages-mode-clicked) +(declare template-messages-results) +(declare handler-messages-results) +(declare render-messages-results) +(declare on-messages-mark) +(declare handler-messages-mark) +(declare render-messages-mark) +(declare template-users) +(declare handler-users) +(declare render-users) +(declare template-users-view) +(declare handler-users-view) +(declare render-users-view) +(declare on-users-add-clicked) +(declare template-users-add) +(declare handler-users-add) +(declare render-users-add) +(declare on-users-add-submit-clicked) +(declare handler-users-add-submit) +(declare render-users-add-submit) +(declare template-users-register) +(declare handler-users-register) +(declare render-users-register) +(declare template-users-register-form) +(declare handler-users-register-form) +(declare handler-users-register-form-impl) +(declare render-users-register-form) +(declare on-users-register-submit-clicked) +(declare template-users-register-submit) +(declare handler-users-register-submit) +(declare render-users-register-submit) +(declare on-users-modify-clicked) +(declare template-users-modify) +(declare handler-users-modify) +(declare render-users-modify) +(declare on-users-modify-submit-clicked) +(declare handler-users-modify-submit) +(declare render-users-modify-submit) +(declare on-users-toggle-active-clicked) +(declare handler-users-toggle-active) +(declare render-users-toggle-active) +(declare on-users-delete-clicked) +(declare handler-users-delete) +(declare render-users-delete) +(declare on-menu-clicked) +(declare handler-location) +(declare goto-location) +(declare goto-register) +(declare reset-app) +(declare reset-about-us-category) + +(enable-console-print!) + +(defonce jquery (js* "$")) +(defonce sql-formatter (time-format/formatter "yyyy-MM-dd HH:mm:ss")) +(defonce pretty-formatter (time-format/formatters :rfc822)) +(defonce location-state (r/atom "/home")) +(defonce about-us-category-state (r/atom nil)) +(defonce menu-main-state (r/atom [])) +(defonce menu-user-state (r/atom [])) +(defonce menu-user-label (r/atom nil)) + +;; helper functions + +(defn date-sql-to-pretty [sql-date] + (first (str/split (time-format/unparse pretty-formatter (time-format/parse sql-formatter (first (str/split sql-date ".")))) " Z"))) + +(defn markdown-to-html [markdown] + (let [converter (js/showdown.Converter.)] + (.makeHtml converter markdown))) + +(defn reduce-checkboxes [selector] + "Reduces the names of all checked checkboxes to a pipe-separated + list. Assumes that the checkboxes are named via the convention + `chk_something-more'. The important thing is the underscore + separating the throwaway prefix and the remaining useful + bit. `selector' will likely be something like: [id^='chk_']" + (reduce (fn [x y] + (cond (and x y) (str x "|" y) + (and x (not y)) x + (and (not x) y) y + :else "")) + (map (fn [elem] + (let [this (jquery (str "#" (dommy/attr elem :id)))] + (when (-> this (.prop "checked")) + (second (str/split (-> this (.prop "id")) "_"))))) + (.toArray (jquery selector))))) + +;; body + +(defn comp-app [] + [:div {:class "container-fluid"} + [:div {:class "banner"} + [:table {:width "100%" :height "100%"} + [:tbody + [:tr + [:td {:class "banner-menu"} + [comp-menu-user]] + [:td {:class "banner-title"} "Bogen-" [:i "Herr"]] + [:td {:class "banner-menu"} " "]]]]] + [comp-menu-main] + [ck-notifications/comp-errormsg] + [ck-notifications/comp-message] + [:div {:id "body"}] + [:div {:id "footer"} + [:hr] + "Carlos Konstanski (970) 294-9708" + [:br] + [:a {:href "https://github.com/ckonstanski/resume/tree/master" + :target "_blank"} + "Source code on GitHub"]]]) + +;; start the react app + +(defn start-render [] + (let [app-root (rdc/create-root (js/document.getElementById "app"))] + (rdc/render app-root [comp-app]))) + +(defn start-location [] + (cond (str/starts-with? @location-state "/register/") + (goto-register (str/replace-first @location-state "/register/" "")) + :else + (goto-location @location-state))) + +(defn reset-location [url] + (reset! location-state url)) + +(defn reset-about-us-category [category] + (reset! about-us-category-state category)) + +(defn ^:dev/after-load start + ([] + (start-render) + (start-location)) + ([url] + (reset-location url) + (start-render) + (start-location))) + +;; notifications + +(defn notifications [jsonobj] + (ck-notifications/reset-message (get jsonobj "message")) + (ck-notifications/reset-errormsg (get jsonobj "errormsg"))) + +(defn auth-notifications [jsonobj] + (cond (empty? (get jsonobj "errormsg")) + (notifications jsonobj) + :else + (do + (render-home "" (get jsonobj "errormsg")) + (render-menu)))) + +;; menu + +(defn comp-menu-main [] + [:div {:class "well"} + [:ul {:class "nav nav-pills"} + (for [menuitem @menu-main-state] + [:li {:key (str "li_" (get menuitem "id")) + :class "nav-item"} + [:a {:class (cond (= (str/upper-case (get menuitem "handler")) + (str/upper-case @location-state)) + "nav-link active" + :else + "nav-link") + :key (get menuitem "id") + :on-click #(on-menu-clicked (get menuitem "handler"))} + (get menuitem "label")]])]]) + +(defn comp-menu-user [] + [:div {:class "dropdown"} + [:button {:class "btn btn-primary dropdown-toggle" + :type "button" + :id "button-menu-user" + :data-toggle "dropdown" + :aria-haspopup "true" + :aria-expanded "false"} + @menu-user-label] + [:div {:class "dropdown-menu" :aria-labelledby "button-menu-user"} + (for [menuitem @menu-user-state] + [:a {:key (get menuitem "id") + :class "dropdown-item" + :on-click #(on-menu-clicked (get menuitem "handler"))} + (get menuitem "label")])]]) + +(defn handler-menu [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (reset! menu-main-state (get jsonobj "menuitems")))) + +(defn handler-menu-user [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (reset! menu-user-state (get jsonobj "menuitems")) + (reset! menu-user-label (get jsonobj "label")))) + +(defn render-menu [] + (GET "/menu" {:handler handler-menu}) + (GET "/menu/user" {:handler handler-menu-user})) + +;; home + +(hiccups/defhtml template-home [jsonobj] + [:div + [:h2 {:style "text-align: center"} "Welcome To Carlos Konstanski's Music Studio"] + [:h3 {:style "text-align: center"} + [:i "a.k.a. der Bogenherr" [:br] "a.k.a. Dr. Divertimento"]] + [:h2 {:style "text-align: center"} "Study the Violin, Viola and Viola d'Amore With Me!"] + [:div {:style "text-align: center"} + [:img {:style "width: 100%" + :src "/static/images/instrument-cabinet.jpg"}]]]) + +(defn handler-home [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-home jsonobj)))) + +(defn render-home + ([] + (GET "/home" {:handler handler-home})) + ([message errormsg] + (POST "/home" + {:format :raw + :params {:message message + :errormsg errormsg} + :handler handler-home}))) + +;; login + +(hiccups/defhtml template-login [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)) + [:div {:style "text-align: center"} + [:a {:href ""} "Forgot password?"]]) + +(defn handler-login [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-login jsonobj)))) + +(defn render-login [] + (GET "/login" {:handler handler-login})) + +;; login-authenticate + +(defn on-login-submit-clicked [] + (when (-> (jquery "#login-form") + (.get "0") + (.checkValidity)) + (render-login-authenticate))) + +(defn handler-login-authenticate [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (cond (get jsonobj "errormsg") + (goto-location "/login") + (get jsonobj "message") + (do + (reset-location "/home") + (render-home) + (render-menu))))) + +(defn render-login-authenticate [] + (POST "/login/authenticate" + {:format :raw + :params {:username (dommy/value (dommy/sel1 :#username)) + :pwd (dommy/value (dommy/sel1 :#pwd))} + :handler handler-login-authenticate})) + +;; logout + +(defn handler-logout [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (render-home "You are now logged out" "") + (reset-location "/home") + (render-menu))) + +(defn render-logout [] + (GET "/logout" {:handler handler-logout})) + +;; profile + +(hiccups/defhtml template-profile [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + [:div {:id "content"}] + [:div {:id "modify" + :class "modal fade" + :role "dialog" + :tabindex "-1"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:h5 {:class "modal-title"} "Profile - Modify"] + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"]] + [:div {:id "modify-body" + :class "modal-body" + :style "height: 460px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]]) + +(defn handler-profile [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-profile jsonobj)) + (render-profile-view))) + +(defn render-profile [] + (GET "/profile" {:handler handler-profile})) + +;; profile-view + +(hiccups/defhtml template-profile-view [jsonobj] + [:div {:style "text-align: right"} + [:img {:src "/static/images/edit.png" + :style "cursor:pointer; cursor:hand" + :onclick (str (namespace ::x) ".on_profile_modify_clicked()")}]] + [:div {:class "container"} + [:div {:class "row"} + [:div {:class "col" :style "text-align: right"} "Username:"] + [:div {:class "col-10"} (get jsonobj "username")]] + [:div {:class "row"} + [:div {:class "col" :style "text-align: right"} "First Name:"] + [:div {:class "col-10"} (get jsonobj "first_name")]] + [:div {:class "row"} + [:div {:class "col" :style "text-align: right"} "Last Name:"] + [:div {:class "col-10"} (get jsonobj "last_name")]] + [:div {:class "row"} + [:div {:class "col" :style "text-align: right"} "Email:"] + [:div {:class "col-10"} (get jsonobj "email")]] + [:div {:class "row"} + [:div {:class "col" :style "text-align: right"} "Phone:"] + [:div {:class "col-10"} (get jsonobj "phone")]]]) + +(defn handler-profile-view [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#content) (template-profile-view jsonobj)))) + +(defn render-profile-view [] + (GET "/profile/view" {:handler handler-profile-view})) + +;; profile-modify + +(defn on-profile-modify-clicked [] + (render-profile-modify)) + +(hiccups/defhtml template-profile-modify [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-profile-modify [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#modify-body) (template-profile-modify jsonobj)) + (.modal (jquery "#modify")))) + +(defn render-profile-modify [] + (POST "/profile/modify" {:handler handler-profile-modify})) + +;; profile-modify-submit + +(defn on-profile-modify-submit-clicked [] + (when (-> (jquery "#profile-modify-form") + (.get "0") + (.checkValidity)) + (.modal (jquery "#modify") "hide") + (render-profile-modify-submit))) + +(defn handler-profile-modify-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/profile"))) + +(defn render-profile-modify-submit [] + (POST "/profile/modify/submit" + {:format :raw + :params {:id (dommy/value (dommy/sel1 :#id)) + :username (dommy/value (dommy/sel1 :#username)) + :first_name (dommy/value (dommy/sel1 :#first_name)) + :last_name (dommy/value (dommy/sel1 :#last_name)) + :email (dommy/value (dommy/sel1 :#email)) + :phone (dommy/value (dommy/sel1 :#phone))} + :handler handler-profile-modify-submit})) + +;; password + +(hiccups/defhtml template-password [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-password [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-password jsonobj)))) + +(defn render-password [] + (GET "/password" {:handler handler-password})) + +;; password-submit + +(defn on-password-submit-clicked [] + (when (-> (jquery "#password-form") + (.get "0") + (.checkValidity)) + (render-password-submit))) + +(defn handler-password-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/password"))) + +(defn render-password-submit [] + (POST "/password/submit" + {:format :raw + :params {:id (dommy/value (dommy/sel1 :#id)) + :pwd (dommy/value (dommy/sel1 :#pwd)) + :pwd2 (dommy/value (dommy/sel1 :#pwd2))} + :handler handler-password-submit})) + +;; about-us (lessons, gigs, programming) + +(hiccups/defhtml template-about-us [jsonobj] + [:h1 {:style "text-align: center"} + (cond (= @about-us-category-state "lessons") "About the Studio" + (= @about-us-category-state "gigs") "Hire Me to Play" + (= @about-us-category-state "programming") "Hire Me to Write Software")] + [:div {:id "content"}] + [:div {:id "modify" + :class "modal fade" + :role "dialog" + :tabindex "-1"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:h5 [:span {:id "modify-title"}]] + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"]] + [:div {:id "modify-body" + :class "modal-body" + :style "height: 460px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]]) + +(defn handler-about-us [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (reset-about-us-category (get jsonobj "category")) + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-about-us jsonobj)) + (render-about-us-view))) + +(defn render-lessons [] + (GET "/lessons" {:handler handler-about-us})) + +(defn render-gigs [] + (GET "/gigs" {:handler handler-about-us})) + +(defn render-programming [] + (GET "/programming" {:handler handler-about-us})) + +;; about-us-view + +(hiccups/defhtml template-about-us-view [jsonobj] + (when (get jsonobj "adminP") + [:div {:style "text-align: right;"} + [:img {:src "/static/images/edit.png" + :style "cursor:pointer; cursor:hand" + :onclick (str (namespace ::x) ".on_about_us_modify_clicked()")}]]) + [:div {:id "markdown"}]) + +(defn handler-about-us-view [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#content) (template-about-us-view jsonobj)) + (dommy/set-html! (dommy/sel1 :#markdown) (markdown-to-html (get jsonobj "content"))))) + +(defn render-about-us-view [] + (GET (str "/" @about-us-category-state "/view") + {:handler handler-about-us-view})) + +;; about-us-modify + +(defn on-about-us-modify-clicked [] + (render-about-us-modify)) + +(hiccups/defhtml template-about-us-modify [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-about-us-modify [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#modify-title) + (str (cond (= @about-us-category-state "lessons") "About the Studio" + (= @about-us-category-state "gigs") "For Hire" + (= @about-us-category-state "programming") "Software Consulting") + " - Modify")) + (dommy/set-html! (dommy/sel1 :#modify-body) (template-about-us-modify jsonobj)) + (.modal (jquery "#modify")))) + +(defn render-about-us-modify [] + (POST (str "/" @about-us-category-state "/modify") + {:handler handler-about-us-modify})) + +;; about-us-modify-submit + +(defn on-about-us-modify-submit-clicked [] + (when (-> (jquery "#about-us-modify-form") + (.get "0") + (.checkValidity)) + (.modal (jquery "#modify") "hide") + (render-about-us-modify-submit))) + +(defn handler-about-us-modify-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#content) (template-about-us-view jsonobj)) + (dommy/set-html! (dommy/sel1 :#markdown) (markdown-to-html (get jsonobj "content"))))) + +(defn render-about-us-modify-submit [] + (POST (str "/" @about-us-category-state "/modify/submit") + {:format :raw + :params {:content (dommy/value (dommy/sel1 :#txt-content))} + :handler handler-about-us-modify-submit})) + +;; contact-us + +(hiccups/defhtml template-contact-us [jsonobj] + [:h1 {:style "text-align: center"} "Reach out to me by filling out the form."] + [:div {:id "content"}] + [:table {:width "100%"} + [:tr + [:td {:style "width: 100%; text-align: center;"} + [:h3 "Located on the edge of the ISU campus!"]]] + [:tr + [:td {:style "width: 100%; text-align: center;"} + [:iframe {:src "https://www.google.com/maps/embed?pb=!1m18!1m12!1m3!1d3225.263770603599!2d-112.4266916!3d42.8635091!2m3!1f0!2f0!3f0!3m2!1i1024!2i768!4f13.1!3m3!1m2!1s0x53554f343c440407%3A0xf13bf897ecb4f7e0!2sBogenherr%20Violin%20and%20Viola%20Studio!5e1!3m2!1sen!2sus!4v1783097048097!5m2!1sen!2sus" + :style "width: 600px; height: 450px; border: 0px;" + :allowfullscreen "" + :loading "lazy" + :referrerpolicy "strict-origin-when-cross-origin"}]]]]) + +(defn handler-contact-us [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-contact-us jsonobj)) + (render-contact-us-view))) + +(defn render-contact-us [] + (GET "/contact-us" {:handler handler-contact-us})) + +;; contact-us-view + +(hiccups/defhtml template-contact-us-view [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-contact-us-view [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#content) (template-contact-us-view jsonobj)))) + +(defn render-contact-us-view [] + (GET "/contact-us/view" {:handler handler-contact-us-view})) + +;; contact-us-submit + +(defn on-contact-us-email-submit-clicked [] + (when (-> (jquery "#contact-us-form") + (.get "0") + (.checkValidity)) + (render-contact-us-email-submit))) + +(defn handler-contact-us-email-submit [response] + (on-menu-clicked "/contact-us")) + +(defn render-contact-us-email-submit [] + (POST "/contact-us/email" + {:format :raw + :params {:first_name (dommy/value (dommy/sel1 :#first_name)) + :last_name (dommy/value (dommy/sel1 :#last_name)) + :email (dommy/value (dommy/sel1 :#email)) + :phone (dommy/value (dommy/sel1 :#phone)) + :comments (dommy/value (dommy/sel1 :#comments))} + :handler handler-contact-us-email-submit})) + +;; messages + +(hiccups/defhtml template-messages [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)) + [:div {:id "results"}]) + +(defn handler-messages [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-messages jsonobj)) + (when (not (empty? (dommy/value (dommy/sel1 :#read)))) + (render-messages-results)))) + +(defn render-messages [] + (GET "/messages" {:handler handler-messages})) + +;; messages-results + +(defn on-messages-mode-clicked [read] + (dommy/set-value! (dommy/sel1 :#read) read) + (render-messages-results)) + +(hiccups/defhtml template-messages-results [jsonobj] + (let [results (get jsonobj "results") + keys (remove (fn [x] + (not (get (first results) x))) + (keys (first results)))] + (cond (empty? results) + [:h5 {:style "text-align: center"} "No results found."] + :else + [:table {:class "table table-hover"} + [:thead + [:tr + (for [key keys] + [:th key]) + [:th + (str "Mark " (cond (= (dommy/value (dommy/sel1 :#read)) "read") + "unread" + :else + "read"))]]] + [:tbody + (for [rec results] + (let [onclick "void()"] + [:tr + (for [key keys] + [:td {:onclick onclick} (get rec key)]) + [:td [:img {:src (str "/static/images/" + (cond (= (dommy/value (dommy/sel1 :#read)) "read") + "edit-undo.png" + :else + "edit-redo.png")) + :style "cursor: pointer; cursor: hand" + :onclick (str (namespace ::x) + ".on_messages_mark(" + (cond (= (dommy/value (dommy/sel1 :#read)) "read") + "'unread'" + :else + "'read'") + "," (get rec "id") ")")}]]]))]]))) + +(defn handler-messages-results [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#results) (template-messages-results jsonobj)))) + +(defn render-messages-results [] + (POST "/messages/results" + {:format :raw + :params {:read (dommy/value (dommy/sel1 :#read))} + :handler handler-messages-results})) + +;; messages-mark + +(defn on-messages-mark [read id] + (render-messages-mark read id)) + +(defn handler-messages-mark [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/messages"))) + +(defn render-messages-mark [read id] + (POST "/messages/mark" + {:format :raw + :params {:read read + :id id} + :handler handler-messages-mark})) + +;; users + +(hiccups/defhtml template-users [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + [:div {:id "content"}] + [:div {:id "modify" + :class "modal fade" + :role "dialog" + :tabindex "-1"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:h5 [:span {:id "modify-title"}]] + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"]] + [:div {:id "modify-body" + :class "modal-body" + :style "height: 450px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]]) + +(defn handler-users [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-users jsonobj)) + (render-users-view))) + +(defn render-users [] + (GET "/users" {:handler handler-users})) + +;; users-view + +(hiccups/defhtml template-users-view [jsonobj] + [:div {:style "text-align: right"} + [:img {:src "/static/images/add.png" + :style "cursor:pointer; cursor:hand" + :onclick (str (namespace ::x) ".on_users_add_clicked()")}]] + [:table {:class "table table-striped table-hover table-sm"} + [:thead + [:tr + [:th {:scope "col"} "Active?"] + [:th {:scope "col"} "Last Name"] + [:th {:scope "col"} "First Name"] + [:th {:scope "col"} "Username"] + [:th {:scope "col"} "Email"] + [:th {:scope "col"} "Phone"] + [:th {:scope "col"} "Del"]]] + [:tbody + (for [user (get jsonobj "users")] + (let [onclick (str (namespace ::x) ".on_users_modify_clicked(" (get user "id") ")") + toggle-active (str (namespace ::x) ".on_users_toggle_active_clicked(" (get user "id") ")")] + [:tr + [:td [:img {:src (cond (get user "active") + "/static/images/yes.png" + :else + "/static/images/no.png") + :onclick toggle-active}]] + [:td {:onclick onclick} (get user "last_name")] + [:td {:onclick onclick} (get user "first_name")] + [:td {:onclick onclick} (get user "username")] + [:td {:onclick onclick} (get user "email")] + [:td {:onclick onclick} (get user "phone")] + [:td [:img {:src "/static/images/delete.png" + :onclick (str (namespace ::x) ".on_users_delete_clicked(" (get user "id") ", '" (get user "first_name") "', '" (get user "last_name") "')")}]]]))]]) + +(defn handler-users-view [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#content) (template-users-view jsonobj)))) + +(defn render-users-view [] + (GET "/users/view" {:handler handler-users-view})) + +;; users-add + +(defn on-users-add-clicked [] + (render-users-add)) + +(hiccups/defhtml template-users-add [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-users-add [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#modify-title) (get jsonobj "title")) + (dommy/set-html! (dommy/sel1 :#modify-body) (template-users-add jsonobj)) + (.modal (jquery "#modify")))) + +(defn render-users-add [] + (POST "/users/add" {:handler handler-users-add})) + +;; users-add-submit + +(defn on-users-add-submit-clicked [] + (when (-> (jquery "#users-add-form") + (.get "0") + (.checkValidity)) + (.modal (jquery "#modify") "hide") + (render-users-add-submit))) + +(defn handler-users-add-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/users"))) + +(defn render-users-add-submit [] + (POST "/users/add/submit" + {:format :raw + :params {:role_groups (reduce-checkboxes "[id^='chk_']") + :first_name (dommy/value (dommy/sel1 :#first_name)) + :last_name (dommy/value (dommy/sel1 :#last_name)) + :email (dommy/value (dommy/sel1 :#email))} + :handler handler-users-add-submit})) + +;; users-register + +(hiccups/defhtml template-users-register [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + [:div {:id "content"}]) + +(defn handler-users-register [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#body) (template-users-register jsonobj)) + (render-users-register-form (get jsonobj "hash")))) + +(defn render-users-register [hash] + (POST "/users/register" + {:format :raw + :params {:hash hash} + :handler handler-users-register})) + +;; users-register-form + +(hiccups/defhtml template-users-register-form [jsonobj] + (cond (get jsonobj "errormsg") + [:a {:href (str "javascript:" (namespace ::x) ".reset_app()")} + "Click here to return to the home page."] + :else + (do + [:p (str "Welcome " (get jsonobj "firstName") " " (get jsonobj "lastName") " to the new user registration page. Please fill out the form below to complete your registration.")] + [:p "Create a new username and password for your login to the website. Phone number is optional."] + [:p (str "Your email address is recorded as " (get jsonobj "email") ". This is where notifications will be sent. If this is not the desired email address, you can change it later by visiting the Edit Profile page.")] + [:p (str "This registration will expire in " (get jsonobj "validFor") ". Please submit this form before that time.")] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))))) + +(defn handler-users-register-form [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#content) (template-users-register-form jsonobj)))) + +(defn render-users-register-form [hash] + (POST "/users/register/form" + {:format :raw + :params {:hash hash} + :handler handler-users-register-form})) + +;; users-register-submit + +(defn on-users-register-submit-clicked [] + (when (-> (jquery "#users-register-form") + (.get "0") + (.checkValidity)) + (render-users-register-submit))) + +(hiccups/defhtml template-users-register-submit [jsonobj] + [:a {:href (str "javascript:" (namespace ::x) ".reset_app()")} + "Click here to start using the website!"]) + +(defn handler-users-register-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (cond (get jsonobj "errormsg") + (do + (dommy/set-value! (dommy/sel1 :#pwd) "") + (dommy/set-value! (dommy/sel1 :#pwd2) "")) + :else + (dommy/set-html! (dommy/sel1 :#content) (template-users-register-submit jsonobj))))) + +(defn render-users-register-submit [] + (POST "/users/register/submit" + {:format :raw + :params {:hash (dommy/value (dommy/sel1 :#hash)) + :username (dommy/value (dommy/sel1 :#username)) + :pwd (dommy/value (dommy/sel1 :#pwd)) + :pwd2 (dommy/value (dommy/sel1 :#pwd2)) + :phone (dommy/value (dommy/sel1 :#phone))} + :handler handler-users-register-submit})) + +;; users-modify + +(defn on-users-modify-clicked [id] + (render-users-modify id)) + +(hiccups/defhtml template-users-modify [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-users-modify [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#modify-title) (get jsonobj "title")) + (dommy/set-html! (dommy/sel1 :#modify-body) (template-users-modify jsonobj)) + (.modal (jquery "#modify")))) + +(defn render-users-modify [id] + (POST "/users/modify" + {:format :raw + :params {:id id} + :handler handler-users-modify})) + +;; users-modify-submit + +(defn on-users-modify-submit-clicked [] + (when (-> (jquery "#users-modify-form") + (.get "0") + (.checkValidity)) + (.modal (jquery "#modify") "hide") + (render-users-modify-submit))) + +(defn handler-users-modify-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/users"))) + +(defn render-users-modify-submit [] + (POST "/users/modify/submit" + {:format :raw + :params {:id (dommy/value (dommy/sel1 :#id)) + :role_groups (reduce-checkboxes "[id^='chk_']") + :username (dommy/value (dommy/sel1 :#username)) + :first_name (dommy/value (dommy/sel1 :#first_name)) + :last_name (dommy/value (dommy/sel1 :#last_name)) + :email (dommy/value (dommy/sel1 :#email)) + :phone (dommy/value (dommy/sel1 :#phone))} + :handler handler-users-modify-submit})) + +;; users-toggle-active + +(defn on-users-toggle-active-clicked [id] + (render-users-toggle-active id)) + +(defn handler-users-toggle-active [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/users"))) + +(defn render-users-toggle-active [id] + (POST "/users/toggle-active" + {:format :raw + :params {:id id} + :handler handler-users-toggle-active})) + +;; users-delete + +(defn on-users-delete-clicked [id first-name last-name] + (when (js/confirm (str "Are you sure you want to delete " first-name " " last-name "? This action cannot be undone.")) + (render-users-delete id))) + +(defn handler-users-delete [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/users"))) + +(defn render-users-delete [id] + (DELETE (str "/users/delete/" id) + {:format :raw + :handler handler-users-delete})) + +;; location + +(defn on-menu-clicked [handler] + (reset-location handler) + (render-menu) + (cond (= handler "/home") (render-home) + (= handler "/login") (render-login) + (= handler "/logout") (render-logout) + (= handler "/profile") (render-profile) + (= handler "/password") (render-password) + (= handler "/lessons") (render-lessons) + (= handler "/gigs") (render-gigs) + (= handler "/programming") (render-programming) + (= handler "/contact-us") (render-contact-us) + (= handler "/messages") (render-messages) + (= handler "/users") (render-users))) + +(defn handler-location [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (on-menu-clicked (get jsonobj "location")) + (notifications jsonobj))) + +(defn goto-location [location] + (POST "/location" + {:format :raw + :params {:location location} + :handler handler-location})) + +(defn reset-app [] + (set! (.-location js/document) "/")) + +(defn goto-register [hash] + (reset-location "/users/register") + (render-menu) + (render-users-register hash)) diff --git a/lisp/webapps/resume/conf/.gitignore b/lisp/webapps/resume/conf/.gitignore new file mode 100644 index 0000000..14fa7a6 --- /dev/null +++ b/lisp/webapps/resume/conf/.gitignore @@ -0,0 +1 @@ +options.lisp diff --git a/lisp/webapps/resume/conf/options.lisp.example b/lisp/webapps/resume/conf/options.lisp.example new file mode 100644 index 0000000..dd570ee --- /dev/null +++ b/lisp/webapps/resume/conf/options.lisp.example @@ -0,0 +1,13 @@ +(:name "resume" + :url "resume.org" + :document-root "resume" + :title "Resume" + :meta-description "The Resume website written in Common Lisp/Hunchentoot and ClojureScript." + :databases (:db-resume ("127.0.0.1" "resume" "resume" "password")) + :mail-mx "mail.ckons.org" + :mail-from "postmaster@ckons.org" + :mail-postmaster "postmaster@ckons.org" + :mail-webmaster "webmaster@ckons.org" + :mail-info "info@ckons.org" + :mail-login-notify "me@ckons.org" + :mail-authentication ("me@ckons.org" "password")) diff --git a/lisp/webapps/resume/site.lisp b/lisp/webapps/resume/site.lisp new file mode 100644 index 0000000..3e31ac1 --- /dev/null +++ b/lisp/webapps/resume/site.lisp @@ -0,0 +1,206 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(defmacro .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 "resume.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"))))))) + +(defmacro .location () + `(location-json location)) + +(defmacro .home-get () + `(home-json)) + +(defmacro .home-post () + `(home-json message errormsg)) + +(defmacro .menu () + `(menu-json)) + +(defmacro .menu-user () + `(menu-user-json)) + +(defmacro .login () + `(login-json)) + +(defmacro .login-authenticate () + `(login-authenticate-json username pwd)) + +(defmacro .login-forgot () + `(login-forgot-json)) + +(defmacro .logout () + `(logout-json)) + +(defmacro .profile () + `(profile-json)) + +(defmacro .profile-view () + `(profile-view-json)) + +(defmacro .profile-modify () + `(profile-modify-json)) + +(defmacro .profile-modify-submit () + `(profile-modify-submit-json id username first_name last_name email phone)) + +(defmacro .password () + `(password-json)) + +(defmacro .password-submit () + `(password-submit-json id pwd pwd2)) + +(defmacro .lessons () + `(about-us-json "lessons")) + +(defmacro .lessons-view () + `(about-us-view-json "lessons")) + +(defmacro .lessons-modify () + `(about-us-modify-json "lessons")) + +(defmacro .lessons-modify-submit () + `(about-us-modify-submit-json "lessons" content)) + +(defmacro .gigs () + `(about-us-json "gigs")) + +(defmacro .gigs-view () + `(about-us-view-json "gigs")) + +(defmacro .gigs-modify () + `(about-us-modify-json "gigs")) + +(defmacro .gigs-modify-submit () + `(about-us-modify-submit-json "gigs" content)) + +(defmacro .programming () + `(about-us-json "programming")) + +(defmacro .programming-view () + `(about-us-view-json "programming")) + +(defmacro .programming-modify () + `(about-us-modify-json "programming")) + +(defmacro .programming-modify-submit () + `(about-us-modify-submit-json "programming" content)) + +(defmacro .contact-us () + `(contact-us-json)) + +(defmacro .contact-us-view () + `(contact-us-view-json)) + +(defmacro .contact-us-email () + `(contact-us-email-json first_name last_name email phone comments)) + +(defmacro .messages () + `(messages-json)) + +(defmacro .messages-results () + `(messages-results-json read)) + +(defmacro .messages-mark () + `(messages-mark-json read id)) + +(defmacro .users () + `(users-json)) + +(defmacro .users-view () + `(users-view-json)) + +(defmacro .users-add () + `(users-add-json)) + +(defmacro .users-add-submit () + `(users-add-submit-json role_groups first_name last_name email)) + +(defmacro .users-register () + `(users-register-json hash)) + +(defmacro .users-register-form () + `(users-register-form-json hash)) + +(defmacro .users-register-submit () + `(users-register-submit-json hash username pwd pwd2 phone)) + +(defmacro .users-modify () + `(users-modify-json id)) + +(defmacro .users-modify-submit () + `(users-modify-submit-json id role_groups username first_name last_name email phone)) + +(defmacro .users-toggle-active () + `(users-toggle-active-json id)) + +(defmacro .users-delete () + `(users-delete-json id)) + +(define-endpoint ("/" :method :get) () .base) +(define-endpoint ("/location" :method :post) (&post (location :parameter-type 'string)) .location) +(define-endpoint ("/home" :method :get) () .home-get) +(define-endpoint ("/home" :method :post) (&post (message :parameter-type 'string) (errormsg :parameter-type 'string)) .home-post) +(define-endpoint ("/menu" :method :get) () .menu) +(define-endpoint ("/menu/user" :method :get) () .menu-user) +(define-endpoint ("/login" :method :get) () .login) +(define-endpoint ("/login/authenticate" :method :post) (&post (username :parameter-type 'string) (pwd :parameter-type 'string)) .login-authenticate) +(define-endpoint ("/login/forgot" :method :get) () .login-forgot) +(define-endpoint ("/logout" :method :get) () .logout) +(define-endpoint ("/profile" :method :get) () .profile) +(define-endpoint ("/profile/view" :method :get) () .profile-view) +(define-endpoint ("/profile/modify" :method :post) () .profile-modify) +(define-endpoint ("/profile/modify/submit" :method :post) (&post (id :parameter-type 'integer) (username :parameter-type 'string) (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string) (phone :parameter-type 'string)) .profile-modify-submit) +(define-endpoint ("/password" :method :get) () .password) +(define-endpoint ("/password/submit" :method :post) (&post (id :parameter-type 'integer) (pwd :parameter-type 'string) (pwd2 :parameter-type 'string)) .password-submit) +(define-endpoint ("/lessons" :method :get) () .lessons) +(define-endpoint ("/lessons/view" :method :get) () .lessons-view) +(define-endpoint ("/lessons/modify" :method :post) () .lessons-modify) +(define-endpoint ("/lessons/modify/submit" :method :post) (&post (content :parameter-type 'string)) .lessons-modify-submit) +(define-endpoint ("/gigs" :method :get) () .gigs) +(define-endpoint ("/gigs/view" :method :get) () .gigs-view) +(define-endpoint ("/gigs/modify" :method :post) () .gigs-modify) +(define-endpoint ("/gigs/modify/submit" :method :post) (&post (content :parameter-type 'string)) .gigs-modify-submit) +(define-endpoint ("/programming" :method :get) () .programming) +(define-endpoint ("/programming/view" :method :get) () .programming-view) +(define-endpoint ("/programming/modify" :method :post) () .programming-modify) +(define-endpoint ("/programming/modify/submit" :method :post) (&post (content :parameter-type 'string)) .programming-modify-submit) +(define-endpoint ("/contact-us" :method :get) () .contact-us) +(define-endpoint ("/contact-us/view" :method :get) () .contact-us-view) +(define-endpoint ("/contact-us/email" :method :post) (&post (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string) (phone :parameter-type 'string) (comments :parameter-type 'string)) .contact-us-email) +(define-endpoint ("/messages" :method :get) () .messages) +(define-endpoint ("/messages/results" :method :post) (&post (read :parameter-type 'string)) .messages-results) +(define-endpoint ("/messages/mark" :method :post) (&post (read :parameter-type 'string) (id :parameter-type 'integer)) .messages-mark) +(define-endpoint ("/users" :method :get) () .users) +(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) (&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) +(define-endpoint ("/users/modify" :method :post) (&post (id :parameter-type 'integer)) .users-modify) +(define-endpoint ("/users/modify/submit" :method :post) (&post (id :parameter-type 'integer) (role_groups :parameter-type 'string) (username :parameter-type 'string) (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string) (phone :parameter-type 'string)) .users-modify-submit) +(define-endpoint ("/users/toggle-active" :method :post) (&post (id :parameter-type 'integer)) .users-toggle-active) +(define-endpoint ("/users/delete/:id" :method :delete) (&path (id 'integer)) .users-delete) diff --git a/lisp/webapps/resume/static/css/stylesheet.css b/lisp/webapps/resume/static/css/stylesheet.css new file mode 100644 index 0000000..659aa54 --- /dev/null +++ b/lisp/webapps/resume/static/css/stylesheet.css @@ -0,0 +1,117 @@ +body { + background-color: #161012; + color: white; + font-size: 14px; +} + +hr { + border: 1px #ffd081 solid; + width: 200px; +} + +a { + color: #ffd081; +} + +.container-fluid { + width: 100%; + margin: 20px auto; +} + +.table { + color: white; +} + +.nav-link { + color: white; + cursor: pointer; + cursor: hand; +} + +.nav-pills { + .nav-link.active, + .show > .nav-link { + background-color: #59200e; + } +} + +.well { + background-color: #2c180d; + border: 1px black solid; + text-align: center; +} + +.btn, +.btn-primary, +.dropdown-toggle { + color: white; + background-color: #59200e; + border-color: #59200e; + &:hover { + color: white; + background-color: #59200e; + border-color: #59200e; + } +} + +.show > .btn-primary.dropdown-toggle { + color: white; + background-color: #59200e; + border-color: #59200e; +} + +.dropdown-menu { + color: white; + background-color: #59200e; +} + +.dropdown-item { + color: white; + background-color: #59200e; +} + +.banner { + height: 90px; + background-image: url("/static/images/violin-strip.jpg"); + background-repeat: repeat; + background-position: left; +} + +.banner-title { + width: *; + color: #59200e; + font-size: 28px; + font-weight: bold; + text-align: center; +} + +.banner-menu { + width: 150px; + text-align: left; + vertical-align: top; +} + +.form-control { + width: 600px; + background-color: #ffd081; +} + +.contact-info { + color: #59200e; + font-size: 15px; + font-weight: bold; + line-height: 0.4; +} + +.modal-content { + background-color: #161012; +} + +#body { + min-height: 500px; +} + +#footer { + font-size: 14px; + text-align: center; +} diff --git a/lisp/webapps/resume/static/images/add.png b/lisp/webapps/resume/static/images/add.png Binary files differnew file mode 100644 index 0000000..1055df8 --- /dev/null +++ b/lisp/webapps/resume/static/images/add.png diff --git a/lisp/webapps/resume/static/images/classical-bow.jpg b/lisp/webapps/resume/static/images/classical-bow.jpg Binary files differnew file mode 100644 index 0000000..fce1392 --- /dev/null +++ b/lisp/webapps/resume/static/images/classical-bow.jpg diff --git a/lisp/webapps/resume/static/images/delete.png b/lisp/webapps/resume/static/images/delete.png Binary files differnew file mode 100644 index 0000000..ec140b7 --- /dev/null +++ b/lisp/webapps/resume/static/images/delete.png diff --git a/lisp/webapps/resume/static/images/document-open.png b/lisp/webapps/resume/static/images/document-open.png Binary files differnew file mode 100644 index 0000000..20b7ca8 --- /dev/null +++ b/lisp/webapps/resume/static/images/document-open.png diff --git a/lisp/webapps/resume/static/images/down.png b/lisp/webapps/resume/static/images/down.png Binary files differnew file mode 100644 index 0000000..e2d15bf --- /dev/null +++ b/lisp/webapps/resume/static/images/down.png diff --git a/lisp/webapps/resume/static/images/download.png b/lisp/webapps/resume/static/images/download.png Binary files differnew file mode 100644 index 0000000..3973b3c --- /dev/null +++ b/lisp/webapps/resume/static/images/download.png diff --git a/lisp/webapps/resume/static/images/edit-redo.png b/lisp/webapps/resume/static/images/edit-redo.png Binary files differnew file mode 100644 index 0000000..3d4db6c --- /dev/null +++ b/lisp/webapps/resume/static/images/edit-redo.png diff --git a/lisp/webapps/resume/static/images/edit-undo.png b/lisp/webapps/resume/static/images/edit-undo.png Binary files differnew file mode 100644 index 0000000..367fc5a --- /dev/null +++ b/lisp/webapps/resume/static/images/edit-undo.png diff --git a/lisp/webapps/resume/static/images/edit.png b/lisp/webapps/resume/static/images/edit.png Binary files differnew file mode 100644 index 0000000..550dacd --- /dev/null +++ b/lisp/webapps/resume/static/images/edit.png diff --git a/lisp/webapps/resume/static/images/emblem-favorite.png b/lisp/webapps/resume/static/images/emblem-favorite.png Binary files differnew file mode 100644 index 0000000..6535d5d --- /dev/null +++ b/lisp/webapps/resume/static/images/emblem-favorite.png diff --git a/lisp/webapps/resume/static/images/emblem-nowrite.png b/lisp/webapps/resume/static/images/emblem-nowrite.png Binary files differnew file mode 100644 index 0000000..997fedf --- /dev/null +++ b/lisp/webapps/resume/static/images/emblem-nowrite.png diff --git a/lisp/webapps/resume/static/images/instrument-cabinet.jpg b/lisp/webapps/resume/static/images/instrument-cabinet.jpg Binary files differnew file mode 100644 index 0000000..0500829 --- /dev/null +++ b/lisp/webapps/resume/static/images/instrument-cabinet.jpg diff --git a/lisp/webapps/resume/static/images/no.png b/lisp/webapps/resume/static/images/no.png Binary files differnew file mode 100644 index 0000000..1dc1b7c --- /dev/null +++ b/lisp/webapps/resume/static/images/no.png diff --git a/lisp/webapps/resume/static/images/sort-alpha.png b/lisp/webapps/resume/static/images/sort-alpha.png Binary files differnew file mode 100644 index 0000000..0e4a831 --- /dev/null +++ b/lisp/webapps/resume/static/images/sort-alpha.png diff --git a/lisp/webapps/resume/static/images/up.png b/lisp/webapps/resume/static/images/up.png Binary files differnew file mode 100644 index 0000000..55bab86 --- /dev/null +++ b/lisp/webapps/resume/static/images/up.png diff --git a/lisp/webapps/resume/static/images/violin-strip.jpg b/lisp/webapps/resume/static/images/violin-strip.jpg Binary files differnew file mode 100644 index 0000000..6149a87 --- /dev/null +++ b/lisp/webapps/resume/static/images/violin-strip.jpg diff --git a/lisp/webapps/resume/static/images/yes.png b/lisp/webapps/resume/static/images/yes.png Binary files differnew file mode 100644 index 0000000..b9cadf5 --- /dev/null +++ b/lisp/webapps/resume/static/images/yes.png diff --git a/lisp/webapps/webapp-loader.lisp b/lisp/webapps/webapp-loader.lisp new file mode 100644 index 0000000..41a00da --- /dev/null +++ b/lisp/webapps/webapp-loader.lisp @@ -0,0 +1,177 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :resume) + +(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* 3014) +(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 resume () + "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))))) |
