700 lines
33 KiB
Common Lisp
700 lines
33 KiB
Common Lisp
(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))))
|