192 lines
10 KiB
Common Lisp
192 lines
10 KiB
Common Lisp
(load "~/quicklisp/setup.lisp")
|
|
(ql:quickload '(hunchentoot clack dexador com.inuoe.jzon serapeum))
|
|
|
|
(uiop:define-package tfc-server
|
|
(:use :cl :uiop :com.inuoe.jzon :clack))
|
|
|
|
(in-package :tfc-server)
|
|
|
|
;; (defun handler (env) '(200 nil ("Hello World, bleh!")))
|
|
|
|
;; (clack:stop (clack:clackup (lambda (env)
|
|
;; '(200 nil ("Hello, World!")))
|
|
;; (clack.handler:stop *clack-server*)
|
|
|
|
;; (defparameter *clack-server* (clack:clackup (lambda (env)
|
|
;; (funcall 'handler env))))
|
|
|
|
|
|
(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 4242))
|
|
|
|
(hunchentoot:define-easy-handler (say-yo :uri "/yo") (name)
|
|
(setf (hunchentoot:content-type*) "text/plain")
|
|
(format nil "Hey~@[ ~A~]!" name))
|
|
|
|
(setf hunchentoot:*default-connection-timeout* 160)
|
|
|
|
(hunchentoot:define-easy-handler (respond :uri "/health-form") ()
|
|
(setf (hunchentoot:content-type*) "application/json")
|
|
(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* ((stream (hunchentoot::content-stream hunchentoot:*request*))
|
|
(data (hunchentoot::get-post-data :request *last*))
|
|
(content-type (hunchentoot:header-in "content-type" *last*))
|
|
(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))
|
|
;; (multipart-parser (fast-http:make-multipart-parser content-type
|
|
;; (lambda (field-name field-headers field-metadata field-body-bytes)
|
|
;; (uiop:println field-name)
|
|
;; (uiop:println field-headers)
|
|
;; (uiop:println field-metadata)
|
|
;; (uiop:println field-body-bytes)
|
|
;; )))
|
|
)
|
|
|
|
;; (uiop:println (fast-http:http-multipart-parse multipart-parser (lambda (field-name field-headers field-metadata field-body-bytes)
|
|
;; (uiop:println field-name)
|
|
;; (uiop:println field-headers)
|
|
;; (uiop:println field-metadata)
|
|
;; (uiop:println field-body-bytes)
|
|
;; ) string-data))
|
|
;; (println multipart-parser)
|
|
(println content-type)
|
|
(println boundary)
|
|
;; (println string-data)
|
|
(setq *last-data* parts)
|
|
(uiop:println (hunchentoot::parse-multipart-form-data *last* *utf-8-external-format*))
|
|
|
|
(loop :for i :in *last-data*
|
|
:do (let* ((content-disposition (nth 1
|
|
(serapeum:lines i :eol-style :cr :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")
|
|
(rest (rest (rest
|
|
(serapeum:lines i :eol-style :cr :honor-crlf t))))
|
|
(nth 3 (serapeum:lines i :eol-style :cr :honor-crlf t))))
|
|
(image-content-type (if (string= name "image") (nth 2 (serapeum:lines i :eol-style :cr :honor-crlf 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))
|
|
(image-stream (if (string= name "image") (open image-file-name
|
|
:direction :output
|
|
:if-does-not-exist :create
|
|
:if-exists :overwrite))))
|
|
;; This gets rid of beginning and ending NIL values
|
|
;; (if name (if (string/= name "image") (format t "~&~A: ~A" name content)) nil)
|
|
|
|
(if (string= name "image") (setq content (butlast content)))
|
|
;; (uiop:println image-content-type)
|
|
;; (uiop:println content)
|
|
;; (uiop:println (string= "" image-file-name))
|
|
|
|
(if (string/= "" image-file-name)
|
|
(if (string= name "image")
|
|
(with-open-file (image-stream (pathname (truename image-file-name))
|
|
:direction :output
|
|
:element-type '(unsigned-byte 8)
|
|
:if-exists :overwrite
|
|
:if-does-not-exist :create)
|
|
(write-sequence (flex:string-to-octets (write-to-string content)) image-stream))))
|
|
;; (if (string= name "image") (format t "~A" (pathname (truename image-file-name))))
|
|
|
|
;; (if (string= name "image") (setq file-path (serapeum:write-stream-into-file
|
|
;; *image-stream*
|
|
;; (pathname (truename image-file-name))
|
|
;; :if-exists :overwrite
|
|
;; :if-does-not-exist :create)))
|
|
;; (if (string= name "image") (format t "~&~A:~A" name content))
|
|
))
|
|
|
|
|
|
|
|
;; This actually worked, but the ending is wrong
|
|
;; (loop :for i :in *last-data*
|
|
;; :do (let* ((content (nth 1
|
|
;; (serapeum:lines i :eol-style :cr :honor-crlf t)))
|
|
;; (start (position #\" content))
|
|
;; (end (position #\" content :from-end t))
|
|
;; (name (if start (subseq content (1+ start) end) nil)))
|
|
;; (uiop:println name)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; (uiop:println "OTHER")
|
|
;; (uiop:println (hunchentoot::get-request-data stream))
|
|
;; (uiop:println (rfc2388:parse-mime data boundary))
|
|
;; (let* ((data (hunchentoot:raw-post-data :force-text t))
|
|
;; (json-obj (com.inuoe.jzon:parse data))
|
|
;; )
|
|
;; ;; (print (format nil "Json: ~A" (com.inuoe.jzon:stringify json-obj)))
|
|
;; (uiop:println "Received Health Form")
|
|
;; (render-json json-obj)
|
|
;; (setq last json-obj)
|
|
;; (process-form json-obj)
|
|
;; data)
|
|
)))))
|
|
|
|
|
|
(defun display-stream (stream)
|
|
(loop for line = (read-line stream nil)
|
|
while line do (format t "~A~%" line)))
|
|
|
|
(defvar *last*)
|
|
(defvar *last-data*)
|
|
(defvar *stream*)
|
|
(defvar *token* "boFFRM68vvXbO-DO7S9YDg86lHX027-hd07mn0dh")
|
|
|
|
(defun print-hash-entry (key value)
|
|
(format t "~S: ~S~%" key value))
|
|
|
|
(defun process-form (form)
|
|
"Processes the form and sends it on"
|
|
(let ((firstname (gethash "firstname" form))
|
|
(lastname (gethash "lastname" form))
|
|
(parentfirstname (gethash "parentfirstname" form))
|
|
(parentlastname (gethash "parentlastname" form))
|
|
(street (gethash "street" form))
|
|
(city (gethash "city" form))
|
|
(state (gethash "state" form))
|
|
(zip (gethash "zip" form))
|
|
(cellphone (gethash "cellphone" form))
|
|
(homephone (gethash "homephone" form))
|
|
(add-emergency-contact (gethash "add-emergency-contact" form))
|
|
(add-emergency-contact-phone (gethash "add-emergency-contact-phone" form))
|
|
(doctorname (gethash "doctorname" form))
|
|
(doctorcity (gethash "doctorcity" form))
|
|
(doctorphone (gethash "doctorphone" form))
|
|
(medical-coverage (gethash "medical-coverage" form))
|
|
(insurance-name (gethash "insurance-name" form))
|
|
(policy-number (gethash "policy-number" form))
|
|
(image (gethash "image" form))
|
|
(agreement (gethash "agreement" form))
|
|
(allergies (gethash "allergies" form))
|
|
(allergies-other (gethash "allergies-other" form))
|
|
(specific-allergies (gethash "specific-allergies" form))
|
|
(allergic-treatment (gethash "allergic-treatment" form))
|
|
(conditions (gethash "conditions" form))
|
|
(tetanus-shot (gethash "tetanus-shot" form))
|
|
(swimming-ability (gethash "swimming-ability" form))
|
|
(medication-schedule (gethash "medication-schedule" form))
|
|
(other-notes (gethash "other-notes" form))
|
|
(age (gethash "age" form)))
|
|
(uiop:println "---")
|
|
(maphash 'print-hash-entry form)
|
|
(uiop:println "---")))
|
|
|
|
|
|
(defun render-json (object)
|
|
(uiop:println (format nil "Json: ~A" (com.inuoe.jzon:stringify object))))
|
|
|