(require "hunchentoot") (require "dexador") ;; (require "drakma") (require "com.inuoe.jzon") (require "serapeum") (require "bordeaux-threads") (require "spinneret") (require "lass") (require "cl-smtp") (defpackage tfcserver (:use :cl :com.inuoe.jzon :spinneret :serapeum)) (in-package :tfcserver) (defvar *last*) (defvar *last-data*) (defvar *last-list-data*) (defvar *stream*) (defvar *auth-token* "Basic Y2hyaXM6MlZIZUd4ZUNeWmY5S3FGS15HQFB0IXp1MnFeNkBi") (defvar *server*) (defun start-server (port) (setq *server* (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port port)))) ;; (defun setup-for-nextcloud-tables (data-list) ;; "moving the list into a form that makes sense for ;; Nextcloud tables" ;; (setf idk (car (assoc "Student Name" data-list :test 'string=) ;; "value"))) (defparameter *mail-css* '((table :border-collapse "collapse" :width "100%") (("th," td) :padding "8px") (td :text-align "left" :width "70%") (th :text-align "right" :border-right "1px solid #ddd") (tr :border-bottom "1px solid #ddd") (h1 :text-align "center"))) (defun post-health-form (data-list) "Takes the health form as an alist and posts it to nocodb" (let* ((student-name (concatenate 'string (serapeum:trim-whitespace (cdr (assoc "firstname" data-list :test 'string=))) " " (serapeum:trim-whitespace (cdr (assoc "lastname" data-list :test 'string=))))) (parent-name (concatenate 'string (serapeum:trim-whitespace (cdr (assoc "parentfirstname" data-list :test 'string=))) " " (serapeum:trim-whitespace (cdr (assoc "parentlastname" data-list :test 'string=))))) (image (assoc "image" data-list)) (headers (list (cons "Authorization" *auth-token*) (cons "Content-Type" "application/json"))) (rows (parse (dex:get "https://staff.tfcconnection.org/apps/tables/api/1/tables/4/rows" :basic-auth '("chris" . "2VHeGxeC^Zf9KqFK^G@Pt!zu2q^6@b") :verbose t))) (lowid 0) (highest-id (loop for i in (loop for row across rows collect (gethash "id" row)) maximizing i))) (setq data-list (remove (assoc "lastname" *last-list-data* :test 'string=) data-list)) (setq data-list (remove (assoc "parentlastname" *last-list-data* :test 'string=) data-list)) (setq data-list (remove (assoc "image" *last-list-data* :test 'string=) data-list)) (setf (cdr (assoc "firstname" data-list :test 'string=)) student-name) (setf (car (assoc "firstname" data-list :test 'string=)) "Student Name") (setf (cdr (assoc "parentfirstname" data-list :test 'string=)) parent-name) (setf (car (assoc "parentfirstname" data-list :test 'string=)) "Parent Name") (setf (car (assoc "add-emergency-contact" data-list :test 'string=)) "emergency-contact") (setf (car (assoc "doctorname" data-list :test 'string=)) "doctor") (setf (car (assoc "doctorphone" data-list :test 'string=)) "doctor-phone") (setf (car (assoc "doctorcity" data-list :test 'string=)) "doctor-city") (setf (car (assoc "allergic-treatment" data-list :test 'string=)) "allergy-treatments") (setf (car (assoc "tetanus-shot" data-list :test 'string=)) "tetanus-shot-date") (loop :for entry :in data-list :do (format t "~&~A" entry)) (format t "~&~A" "Let's print out the data") (format t "~&~A" data-list) (uiop:println *last-list-data*) (setf data `#(("columnId" 37 "value" ,(serapeum:trim-whitespace (cdr (assoc "Student Name" *last-list-data* :test 'string=)))) ("columnId" 38 "value" ,(serapeum:trim-whitespace (cdr (assoc "Parent Name" *last-list-data* :test 'string=)))) ("columnId" 39 "value" ,(serapeum:trim-whitespace (cdr (assoc "birthdate" *last-list-data* :test 'string=)))) ("columnId" 40 "value" ,(serapeum:trim-whitespace (cdr (assoc "street" *last-list-data* :test 'string=)))) ("columnId" 41 "value" ,(serapeum:trim-whitespace (cdr (assoc "city" *last-list-data* :test 'string=)))) ("columnId" 42 "value" ,(serapeum:trim-whitespace (cdr (assoc "state" *last-list-data* :test 'string=)))) ("columnId" 43 "value" ,(serapeum:trim-whitespace (cdr (assoc "zip" *last-list-data* :test 'string=)))) ("columnId" 44 "value" ,(serapeum:trim-whitespace (cdr (assoc "cellphone" *last-list-data* :test 'string=)))) ("columnId" 45 "value" ,(serapeum:trim-whitespace (cdr (assoc "homephone" *last-list-data* :test 'string=)))) ("columnId" 46 "value" ,(serapeum:trim-whitespace (cdr (assoc "emergency-contact" *last-list-data* :test 'string=)))) ("columnId" 47 "value" ,(serapeum:trim-whitespace (cdr (assoc "doctor" *last-list-data* :test 'string=)))) ("columnId" 48 "value" ,(serapeum:trim-whitespace (cdr (assoc "doctor-city" *last-list-data* :test 'string=)))) ("columnId" 49 "value" ,(serapeum:trim-whitespace (cdr (assoc "doctor-phone" *last-list-data* :test 'string=)))) ("columnId" 50 "value" ,(serapeum:trim-whitespace (cdr (assoc "medical-coverage" *last-list-data* :test 'string=)))) ("columnId" 51 "value" ,(serapeum:trim-whitespace (cdr (assoc "insurance-name" *last-list-data* :test 'string=)))) ("columnId" 52 "value" ,(serapeum:trim-whitespace (cdr (assoc "policy-number" *last-list-data* :test 'string=)))) ("columnId" 53 "value" ,(serapeum:trim-whitespace (cdr (assoc "insurance-card" *last-list-data* :test 'string=)))) ("columnId" 54 "value" ,(serapeum:trim-whitespace (cdr (assoc "agreement" *last-list-data* :test 'string=)))) ("columnId" 55 "value" ,(serapeum:trim-whitespace (cdr (assoc "allergies" *last-list-data* :test 'string=)))) ("columnId" 56 "value" ,(serapeum:trim-whitespace (cdr (assoc "specific-allergies" *last-list-data* :test 'string=)))) ("columnId" 57 "value" ,(serapeum:trim-whitespace (cdr (assoc "allergy-treatment" *last-list-data* :test 'string=)))) ("columnId" 58 "value" ,(serapeum:trim-whitespace (cdr (assoc "conditions" *last-list-data* :test 'string=)))) ("columnId" 59 "value" ,(serapeum:trim-whitespace (cdr (assoc "tetanus-shot-date" *last-list-data* :test 'string=)))) ("columnId" 60 "value" ,(serapeum:trim-whitespace (cdr (assoc "medication-schedule" *last-list-data* :test 'string=)))) ("columnId" 61 "value" ,(serapeum:trim-whitespace (cdr (assoc "other-notes" *last-list-data* :test 'string=)))) ("columnId" 62 "value" ,(serapeum:trim-whitespace (cdr (assoc "swimming-ability" *last-list-data* :test 'string=)))))) (dex:post "https://staff.tfcconnection.org/apps/tables/api/1/tables/4/rows" :basic-auth '("chris" . "2VHeGxeC^Zf9KqFK^G@Pt!zu2q^6@b") :content `(("data" . ,(stringify special-data))) :verbose t) )) (defun print-hash-entry (key value) (format t "~S: ~S~%" key (if (hash-table-p value) (maphash 'print-hash-entry value) (if (simple-vector-p value) (loop :for item :in (setq value (coerce value 'list)) :do (maphash 'print-hash-entry item)) value)))) (defun process-form (form) "Processes the form and sends it on" (uiop:println "---") (maphash 'print-hash-entry form) (uiop:println "---")) (defun save-string-file (string file-path) "save a file that is represented as a string to disk that came from a multipart/form-data" (serapeum/bundle:write-string-into-file string file-path :if-exists :overwrite :if-does-not-exist :create :external-format :latin-1)) (defun mail-mt-form (form attachment) "Takes the form as an alist and sends a table formatted email with the image attached to us" (uiop:println form) (let ((first-name (cdr (assoc "firstname" form :test 'string=))) (last-name (cdr (assoc "lastname" form :test 'string=)))) (not (cl-smtp:send-email "mail.tfcconnection.org" "no-reply@mail.tfcconnection.org" "chris@cochrun.xyz" (format nil "~a ~a filled out a Mission Trip Form!" first-name last-name) (format nil "Mission Trip Form for ~a ~a" first-name last-name) :display-name "TFC ADMIN" :ssl :tls :authentication '(:login "no-reply@mail.tfcconnection.org" "r9f36mNZFtiW4f") :attachments attachment :html-message (with-html-string (:doctype) (:html (:head (:title "TFC Mission Trip Form") (:style (apply #'lass:compile-and-write *mail-css*))) (:body (:h1 (format nil "Mission Trip Form for ~a ~a" first-name last-name)) (:hr) (:table (loop for row in form do (:tr (:th (trim-whitespace (car row))) (:td (trim-whitespace (cdr row))))))))))))) (cl-smtp:send-email "mail.tfcconnection.org" "no-reply@mail.tfcconnection.org" "chris@cochrun.xyz" (format nil "~a ~a filled out a Mission Trip Form!" "Chris" "Ccohrun") "hi" :html-message (let ((form '(("age" . "150") ("registration" . "later") ("final-agreement" . "yes") ("relevant-notes" . "") ("attitude-toward-work" . "") ("previous-trip-info" . "") ("weaknesses" . "") ("strengths" . "") ("reasons-for-trip-choice" . "") ("involvement-with-group" . "") ("testimony" . "") ("relationship-with-jesus" . "") ("tripnotes" . "") ("trip" . "New Mexico") ("shirt" . "small") ("tfcgroup" . "Phillipsburg") ("churchattendanceother" . "") ("churchattendance" . "yes") ("church" . "") ("pastorphone" . "9991112222") ("pastorlastname" . "The White") ("pastorfirstname" . "Gandalf") ("grade" . "sophomore") ("school" . "A cool one") ("parentemail" . "bilbosmells@braggins.xyz") ("email" . "chris@cochrun.xyz") ("parentphone" . "8889990000") ("cellphone" . "7853021664") ("zip" . "67661") ("state" . "Middle Earth") ("city" . "The Shire") ("street" . "1234 Bag End, 98 Hobbiton") ("gender" . "Male") ("birthdate" . "1873-11-23") ("parentlastname" . "Braggins") ("parentfirstname" . "Bilbo") ("lastname" . "Braggins") ("firstname" . "Frodo")))) (with-html-string (:doctype) (:html (:head (:title "TFC Mission Trip Form") (:style (apply #'lass:compile-and-write *mail-css*))) (:body (:h1 (format nil "Mission Trip Form for ~a ~a" "Chris" "Ccohrun")) (:hr) (:table (loop for row in form do (:tr (:th (trim-whitespace (car row))) (:td (trim-whitespace (cdr row)))))))))) :ssl :tls :authentication '(:login "no-reply@mail.tfcconnection.org" "r9f36mNZFtiW4f") ) (defun mail-form (form attachment) "Takes the form as an alist and sends a table formatted email with the image attached" (let ((first-name (serapeum:trim-whitespace (cdr (assoc "firstname" form :test 'string=)))) (last-name (serapeum:trim-whitespace (cdr (assoc "lastname" form :test 'string=)))) (parent-name (concatenate 'string (serapeum:trim-whitespace (cdr (assoc "parentfirstname" form :test 'string=))) " " (serapeum:trim-whitespace (cdr (assoc "parentlastname" form :test 'string=))))) (birthdate (trim-whitespace (cdr (assoc "birthdate" form :test 'string=)))) (city (trim-whitespace (cdr (assoc "city" form :test 'string=)))) (street (trim-whitespace (cdr (assoc "street" form :test 'string=)))) (state (trim-whitespace (cdr (assoc "state" form :test 'string=)))) (zip (trim-whitespace (cdr (assoc "zip" form :test 'string=)))) (cellphone (trim-whitespace (cdr (assoc "cellphone" form :test 'string=)))) (homephone (trim-whitespace (cdr (assoc "homephone" form :test 'string=)))) (emergency-contact (trim-whitespace (cdr (assoc "emergency-contact" form :test 'string=)))) (additional-contact (trim-whitespace (cdr (assoc "add-emergency-contact-phone" form :test 'string=)))) (doctor (trim-whitespace (cdr (assoc "doctor" form :test 'string=)))) (doctor-city (trim-whitespace (cdr (assoc "doctor-city" form :test 'string=)))) (doctor-phone (trim-whitespace (cdr (assoc "doctor-phone" form :test 'string=)))) (medical-coverage (trim-whitespace (cdr (assoc "medical-coverage" form :test 'string=)))) (insurance (trim-whitespace (cdr (assoc "insurance-name" form :test 'string=)))) (policy-number (trim-whitespace (cdr (assoc "policy-number" form :test 'string=)))) (image (trim-whitespace (cdr (assoc "image" form :test 'string=)))) (agreement (trim-whitespace (cdr (assoc "agreement" form :test 'string=)))) (allergies (trim-whitespace (cdr (assoc "allergies" form :test 'string=)))) (allergies-other (trim-whitespace (cdr (assoc "allergies-other" form :test 'string=)))) (specific-allergies (trim-whitespace (cdr (assoc "specific-allergies" form :test 'string=)))) (allergy-treatments (trim-whitespace (cdr (assoc "allergy-treatments" form :test 'string=)))) (conditions (trim-whitespace (cdr (assoc "conditions" form :test 'string=)))) (tetanus (trim-whitespace (cdr (assoc "tetanus-shot-date" form :test 'string=)))) (swimming (trim-whitespace (cdr (assoc "swimming-ability" form :test 'string=)))) (medication (trim-whitespace (cdr (assoc "medication-schedule" form :test 'string=)))) (other (trim-whitespace (cdr (assoc "other-notes" form :test 'string=)))) (age (trim-whitespace (cdr (assoc "age" form :test 'string=))))) (not (cl-smtp:send-email "mail.tfcconnection.org" "no-reply@mail.tfcconnection.org" '("chris@tfcconnection.org" "ethan@tfcconnection.org") (format nil "~a ~a filled out a Health Form!" first-name last-name) (format nil "Health Form for ~a ~a" first-name last-name) :display-name "TFC ADMIN" :ssl :tls :authentication '(:login "no-reply@mail.tfcconnection.org" "r9f36mNZFtiW4f") :attachments attachment :html-message (with-html-string (:doctype) (:html (:head (:title "TFC Health Form") (:style (apply #'lass:compile-and-write *mail-css*))) (:body (:h1 (format nil "Health Form for ~a ~a" first-name last-name)) (:hr) (:table (loop for row in form do (:tr (:th (car row)) (:td (trim-whitespace (cdr row))))))))))))) (hunchentoot:define-easy-handler (respond :uri "/mt-form") () (setf (hunchentoot:content-type*) "plain/text") (let* ((request-type (hunchentoot:request-method hunchentoot:*request*)) (req hunchentoot:*request*) (content-type (hunchentoot:header-in "content-type" req)) (boundary (let ((position (position #\= content-type))) (when position (subseq content-type (1+ position))))) (string-data (flexi-streams:octets-to-string (hunchentoot:raw-post-data :request req))) (parts (ppcre:split boundary string-data)) (form-list nil) (attachment nil)) (cond ((eq request-type :get) nil) ((eq request-type :post) (loop :for i :in parts :do (let* ((content-disposition (nth 1 (serapeum:lines i :eol-style :crlf :honor-crlf t))) (start (if content-disposition (position #\" content-disposition))) (end (if start (position #\" content-disposition :start (1+ start)) nil)) (name (if end (if start (subseq content-disposition (1+ start) end) nil) nil)) (content (if (string= name "image") nil ;; (butlast ;; (rest ;; (rest ;; (rest ;; (rest ;; (serapeum:lines i ;; :eol-style ;; :crlf ;; :honor-crlf t ;; :keep-eols t)))))) (trim-whitespace (car (butlast (rest (rest (rest (serapeum:lines i :eol-style :crlf :honor-crlf t :keep-eols t))))))))) (file-start (if (string= name "image") (position #\" content-disposition :start 44))) (file-end (if file-start (position #\" content-disposition :start (1+ file-start)) nil)) (image-file-name (if (string= name "image") (subseq content-disposition (1+ file-start) file-end) nil))) (if name (if (string= name "image") (when (stringp content) (progn (if (not (uiop:file-exists-p image-file-name)) (save-string-file (apply #'concatenate 'string content) image-file-name)) (setf attachment image-file-name) (delete-file image-file-name))) (setq form-list (acons name content form-list)))))) (if (mail-mt-form form-list attachment) (progn (uiop:println "Mail sent") (format nil "thankyou"))))))) (hunchentoot:define-easy-handler (respond :uri "/health-form") () (setf (hunchentoot:content-type*) "plain/text") (let ((request-type (hunchentoot:request-method hunchentoot:*request*))) (cond ((eq request-type :get) nil) ((eq request-type :post) (uiop:println hunchentoot:*request*) (setq *last* hunchentoot:*request*) (setq *stream* (hunchentoot::content-stream hunchentoot:*request*)) (let* ((data (hunchentoot::get-post-data :request *last*)) (content-type (hunchentoot:header-in "content-type" hunchentoot:*request*)) (boundary (let ((position (position #\= content-type))) (when position (subseq content-type (1+ position))))) (string-data (flexi-streams:octets-to-string data)) (parts (ppcre:split boundary string-data)) (attachment nil)) (setq *last-data* parts) (setq *last-list-data* nil) (loop :for i :in *last-data* :do (let* ((content-disposition (nth 1 (serapeum:lines i :eol-style :crlf :honor-crlf t))) (start (if content-disposition (position #\" content-disposition))) (end (if start (position #\" content-disposition :start (1+ start)) nil)) (name (if end (if start (subseq content-disposition (1+ start) end) nil) nil)) (content (if (string= name "image") (butlast (rest (rest (rest (rest (serapeum:lines i :eol-style :crlf :honor-crlf t :keep-eols t)))))) (butlast (rest (rest (rest (serapeum:lines i :eol-style :crlf :honor-crlf t :keep-eols t))))))) (file-start (if (string= name "image") (position #\" content-disposition :start 44))) (file-end (if file-start (position #\" content-disposition :start (1+ file-start)) nil)) (image-file-name (if (string= name "image") (subseq content-disposition (1+ file-start) file-end) nil)) (form-list nil)) ;; This gets rid of beginning and ending NIL values (if (string/= name "image") (if (listp content) (setq content (serapeum:mapconcat (lambda (x) (if (string= x "") (coerce #\Newline 'string) x)) content "")))) (if name (if (string/= name "image") (progn (format t "~&~A: ~A" name content) (setq form-list (acons name content form-list)))) nil) (if (string= "image" name) (progn (format t "~&~A: ~A" name image-file-name) (if (uiop:file-exists-p image-file-name) (progn (setq form-list (acons name image-file-name form-list)) (save-string-file (apply #'concatenate 'string content) image-file-name) (setf attachment image-file-name))))) (setq *last-list-data* (append *last-list-data* form-list)))) (post-health-form *last-list-data*) (if (mail-form *last-list-data* attachment) (format nil "thankyou"))))))) (defun main () (start-server 4242) (format t "Server has started on port 4242~&") (handler-case (bt:join-thread (find-if (lambda (th) (search "hunchentoot" (bt:thread-name th))) (bt:all-threads))) (#+sbcl sb-sys:interactive-interrupt #+ccl ccl:interrupt-signal-condition #+clisp system::simple-interrupt-condition #+ecl ext:interactive-interrupt #+allegro excl:interrupt-signal () (progn (format *error-output* "Aborting.~&") (hunchentoot:stop *server*) (uiop:quit))) (error (c) (format t "Woops, an unknown error occured:~&~a~&" c))))