diff --git a/src/main.lisp b/src/main.lisp index bfb21a2..d8bf02d 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -16,44 +16,99 @@ (defvar *last-data*) (defvar *last-list-data*) (defvar *stream*) -(defvar *auth-token* "boFFRM68vvXbO-DO7S9YDg86lHX027-hd07mn0dh") +(defvar *auth-token* "Basic Y2hyaXM6MlZIZUd4ZUNeWmY5S3FGS15HQFB0IXp1MnFeNkBi") (defvar *server*) (defun start-server (port) - (setq *server* (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 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 (car (assoc "Student Name" data-list :test 'string=) + "value"))) (defun post-health-form (data-list) "Takes the health form as an alist and posts it to nocodb" (let* ((student-name (concatenate 'string - (cdr (assoc "firstname" data-list :test 'string=)) + (cdr (assoc "firstname" data-list + :test 'string=)) " " - (cdr (assoc "lastname" data-list :test 'string=)))) + (cdr (assoc "lastname" data-list + :test 'string=)))) (parent-name (concatenate 'string - (cdr (assoc "parentfirstname" data-list :test 'string=)) + (cdr (assoc "parentfirstname" data-list + :test 'string=)) " " - (cdr (assoc "parentlastname" data-list :test 'string=)))) - (headers (list (cons "xc-token" *auth-token*) (cons "Content-Type" "application/json")))) + (cdr (assoc "parentlastname" data-list + :test 'string=)))) + (image (assoc "image" data-list)) + (headers (list (cons "Authorization" *auth-token*) + (cons "Content-Type" "application/json")))) - (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") + (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") + (setq data-list (loop :for entry :in data-list + :collect (format t "~&~A" entry))) + (format t "~&~A" "Let's print out the data") (format t "~&~A" data-list) + (setq *last-list-data* data-list) - (dex:post "https://tbl.tfcconnection.org/api/v1/db/data/v1/TFC/Health%20Forms/" - :headers headers - :content (stringify data-list) + (dex:post "https://staff.tfcconnection.org/apps/tables/api/1/tables/4/rows" + :basic-auth '("chris" . "2VHeGxeC^Zf9KqFK^G@Pt!zu2q^6@b") + :content `(("tableid" . 4) ("data" . ,(stringify data-list))) :verbose t))) (defun print-hash-entry (key value) - (format t "~S: ~S~%" key (if (hash-table-p value) (maphash 'print-hash-entry value) 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" @@ -77,7 +132,8 @@ (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*)) + (content-type + (hunchentoot:header-in "content-type" hunchentoot:*request*)) (boundary (let ((position (position #\= content-type))) (when position (subseq content-type (1+ position))))) @@ -87,63 +143,90 @@ (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)) + :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) + (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) - (setq form-list (acons name image-file-name form-list)) + (setq form-list + (acons name image-file-name form-list)) (save-string-file - (apply #'concatenate 'string content) image-file-name))) + (apply #'concatenate 'string content) + image-file-name))) - (setq *last-list-data* (append *last-list-data* form-list)))) + (setq *last-list-data* + (append *last-list-data* form-list)))) (post-health-form *last-list-data*) (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))) + (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