(asdf:load-system 'hunchentoot) (asdf:load-system 'dexador) (asdf:load-system 'com.inuoe.jzon) (asdf:load-system 'serapeum) (asdf:load-system 'bordeaux-threads) (asdf:load-system 'spinneret) (asdf:load-system 'lass) (asdf:load-system 'cl-smtp) (asdf:load-system 'log4cl) (defpackage tfcserver (:use :cl :com.inuoe.jzon :spinneret :serapeum)) (in-package :tfcserver) (defvar *server*) (defun start-server (port) (setq *server* (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port port)))) (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=))) (form (reverse form))) (not (cl-smtp:send-email "mail.tfcconnection.org" "no-reply@mail.tfcconnection.org" '("chris@cochrun.xyz" "chris@tfcconnection.org") (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))))))))))))) (defun mail-camp-form (form attachment) "Takes the form as an alist and sends a table formatted email with the image attached" (let* ((first-name (trim-whitespace (cdr (assoc "firstname" form :test 'string=)))) (last-name (trim-whitespace (cdr (assoc "lastname" form :test 'string=)))) (parent-name (concatenate 'string (trim-whitespace (cdr (assoc "parentfirstname" form :test 'string=))) " " (trim-whitespace (cdr (assoc "parentlastname" form :test 'string=)))))) (not (cl-smtp:send-email "mail.tfcconnection.org" "no-reply@mail.tfcconnection.org" '("chris@tfcconnection.org" "chris@cochrun.xyz") (format nil "~a ~a filled out a Camp Form!" first-name last-name) (format nil "Camp 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 "Camp Form for ~a ~a" first-name last-name)) (:hr) (:table (loop for row in form do (:tr (:th (car row)) (:td (cdr row)))))))))))) (defun mail-health-form (form attachment) "Takes the form as an alist and sends a table formatted email with the image attached" (let* ((first-name (trim-whitespace (cdr (assoc "firstname" form :test 'string=)))) (last-name (trim-whitespace (cdr (assoc "lastname" form :test 'string=)))) (parent-name (concatenate 'string (trim-whitespace (cdr (assoc "parentfirstname" form :test 'string=))) " " (trim-whitespace (cdr (assoc "parentlastname" form :test 'string=)))))) (not (cl-smtp:send-email "mail.tfcconnection.org" "no-reply@mail.tfcconnection.org" '("chris@tfcconnection.org" "chris@cochrun.xyz") (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 (cdr row)))))))))))) (defun define-post-form-handler (uri mail-function) "Take a uri and a mailer function and define a handler in hunchentoot for forms to POST to." (hunchentoot:define-easy-handler (respond :uri uri) () (setf (hunchentoot:content-type*) "plain/text") (let* ((request-type (hunchentoot:request-method hunchentoot:*request*)) (post-data (hunchentoot:post-parameters* hunchentoot:*request*)) (attachment nil) (first-name nil) (last-name nil)) (cond ((eq request-type :get) nil) ((eq request-type :post) (loop :for d :in post-data :do (progn (uiop:println d) (if (string= "firstname" (car d)) (progn (uiop:println (cdr d)) (setf first-name (cdr d)))) (if (string= "lastname" (car d)) (progn (uiop:println (cdr d)) (setf last-name (cdr d)))) (if (string= "image" (car d)) (let ((path (path-join hunchentoot:*tmp-directory* (format nil "~a_~a.~a" first-name last-name (cadr (uiop:split-string (car (last d 2)) :separator ".")))))) (uiop:copy-file (cadr d) (path-join hunchentoot:*tmp-directory* (format nil "~a_~a.~a" first-name last-name (cadr (uiop:split-string (car (last d 2)) :separator "."))))) (setf attachment path) (uiop:println attachment))))) (if (funcall mail-function post-data attachment) (format nil "thankyou"))))))) (define-post-form-handler "/mt-form" 'mail-mt-form) (define-post-form-handler "/health-form" 'mail-health-form) (define-post-form-handler "/camp-form" 'mail-camp-form) (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))))