some working updates to lisp server
This commit is contained in:
parent
7f8799dc0c
commit
dfaa3872ad
209
src/main.lisp
209
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue