making the lisp server leaner
This commit is contained in:
parent
457a2815af
commit
0c692b3197
186
src/main.lisp
186
src/main.lisp
|
|
@ -313,46 +313,45 @@ with the image attached to us"
|
||||||
(defun mail-health-form (form attachment)
|
(defun mail-health-form (form attachment)
|
||||||
"Takes the form as an alist and sends a table formatted email
|
"Takes the form as an alist and sends a table formatted email
|
||||||
with the image attached"
|
with the image attached"
|
||||||
(let ((first-name (serapeum:trim-whitespace
|
(let* ((first-name (serapeum:trim-whitespace
|
||||||
(cdr (assoc "firstname" form
|
(cdr (assoc "firstname" form
|
||||||
|
:test 'string=))))
|
||||||
|
(last-name (serapeum:trim-whitespace
|
||||||
|
(cdr (assoc "lastname" form
|
||||||
:test 'string=))))
|
:test 'string=))))
|
||||||
(last-name (serapeum:trim-whitespace
|
(attachment (uiop:copy-file attachment (path-join hunchentoot:*tmp-directory* (format nil "~a_~a" "Frodo" "Braggins"))))
|
||||||
(cdr (assoc "lastname" form
|
(parent-name (concatenate 'string
|
||||||
:test 'string=))))
|
(serapeum:trim-whitespace
|
||||||
(parent-name (concatenate 'string
|
(cdr (assoc "parentfirstname" form
|
||||||
(serapeum:trim-whitespace
|
:test 'string=)))
|
||||||
(cdr (assoc "parentfirstname" form
|
" "
|
||||||
:test 'string=)))
|
(serapeum:trim-whitespace
|
||||||
" "
|
(cdr (assoc "parentlastname" form
|
||||||
(serapeum:trim-whitespace
|
:test 'string=))))))
|
||||||
(cdr (assoc "parentlastname" form
|
(not (cl-smtp:send-email
|
||||||
:test 'string=))))))
|
"mail.tfcconnection.org"
|
||||||
(let ((form (reverse form)))
|
"no-reply@mail.tfcconnection.org"
|
||||||
(not (cl-smtp:send-email
|
'("chris@tfcconnection.org")
|
||||||
"mail.tfcconnection.org"
|
(format nil "~a ~a filled out a Health Form!" first-name last-name)
|
||||||
"no-reply@mail.tfcconnection.org"
|
(format nil "Health Form for ~a ~a" first-name last-name)
|
||||||
'("chris@tfcconnection.org" "ethan@tfcconnection.org")
|
:display-name "TFC ADMIN"
|
||||||
(format nil "~a ~a filled out a Health Form!" first-name last-name)
|
:ssl :tls
|
||||||
(format nil "Health Form for ~a ~a" first-name last-name)
|
:authentication '(:login "no-reply@mail.tfcconnection.org" "r9f36mNZFtiW4f")
|
||||||
:display-name "TFC ADMIN"
|
:attachments attachment
|
||||||
:ssl :tls
|
:html-message
|
||||||
:authentication '(:login "no-reply@mail.tfcconnection.org" "r9f36mNZFtiW4f")
|
(with-html-string
|
||||||
:attachments attachment
|
(:doctype)
|
||||||
:html-message
|
(:html
|
||||||
(with-html-string
|
(:head (:title "TFC Health Form")
|
||||||
(:doctype)
|
(:style (apply #'lass:compile-and-write *mail-css*)))
|
||||||
(:html
|
(:body
|
||||||
(:head (:title "TFC Health Form")
|
(:h1 (format nil "Health Form for ~a ~a" first-name last-name))
|
||||||
(:style (apply #'lass:compile-and-write *mail-css*)))
|
(:hr)
|
||||||
(:body
|
(:table
|
||||||
(:h1 (format nil "Health Form for ~a ~a" first-name last-name))
|
(loop for row in form
|
||||||
(:hr)
|
do (:tr
|
||||||
(:table
|
(:th (car row))
|
||||||
(loop for row in form
|
(:td (cdr row))))))))))))
|
||||||
do (:tr
|
|
||||||
(:th (car row))
|
|
||||||
(:td (trim-whitespace
|
|
||||||
(cdr row))))))))))))))
|
|
||||||
|
|
||||||
(hunchentoot:define-easy-handler (respond :uri "/mt-form") ()
|
(hunchentoot:define-easy-handler (respond :uri "/mt-form") ()
|
||||||
(setf (hunchentoot:content-type*) "plain/text")
|
(setf (hunchentoot:content-type*) "plain/text")
|
||||||
|
|
@ -438,106 +437,19 @@ with the image attached"
|
||||||
|
|
||||||
(hunchentoot:define-easy-handler (respond :uri "/health-form") ()
|
(hunchentoot:define-easy-handler (respond :uri "/health-form") ()
|
||||||
(setf (hunchentoot:content-type*) "plain/text")
|
(setf (hunchentoot:content-type*) "plain/text")
|
||||||
(let ((request-type (hunchentoot:request-method hunchentoot:*request*)))
|
(let* ((request-type (hunchentoot:request-method hunchentoot:*request*))
|
||||||
|
(post-data (hunchentoot:post-parameters* hunchentoot:*request*))
|
||||||
|
(attachment nil))
|
||||||
(cond ((eq request-type :get) nil)
|
(cond ((eq request-type :get) nil)
|
||||||
((eq request-type :post)
|
((eq request-type :post)
|
||||||
(uiop:println hunchentoot:*request*)
|
(loop :for d :in post-data
|
||||||
(setq *last* hunchentoot:*request*)
|
:do (progn
|
||||||
(setq *stream* (hunchentoot::content-stream hunchentoot:*request*))
|
(uiop:println d)
|
||||||
(let* ((data (hunchentoot::get-post-data :request *last*))
|
(if (string= "image" (car d))
|
||||||
(content-type
|
(progn (setf attachment (cadr d))
|
||||||
(hunchentoot:header-in "content-type" hunchentoot:*request*))
|
(uiop:println attachment)))))
|
||||||
(boundary (let ((position (position #\= content-type)))
|
(if (mail-health-form post-data attachment)
|
||||||
(when position
|
(format nil "thankyou"))))))
|
||||||
(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-health-form *last-list-data* attachment)
|
|
||||||
(format nil "thankyou")))))))
|
|
||||||
|
|
||||||
(defun main ()
|
(defun main ()
|
||||||
(start-server 4242)
|
(start-server 4242)
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue