(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))))