TFC/tfcconnection
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

making server buildable

Browse source
This commit is contained in:
Chris Cochrun 2023-06-13 07:34:00 -05:00
parent bc15f05603
commit ec3bde1191
6 changed files with 85 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

149
src/main.lisp Normal file
View file

@ -0,0 +1,149 @@
(ql:quickload '(hunchentoot clack dexador com.inuoe.jzon serapeum bordeaux-threads))
(defpackage tfc-server
(:use :cl :uiop :com.inuoe.jzon :clack))
(in-package :tfc-server)
(defvar *last*)
(defvar *last-data*)
(defvar *last-list-data*)
(defvar *stream*)
(defvar *auth-token* "boFFRM68vvXbO-DO7S9YDg86lHX027-hd07mn0dh")
(defvar *server*)
(defun start-server (port)
(setq *server* (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port port))))
(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 "lastname" data-list :test 'string=))))
(parent-name (concatenate '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"))))
(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")
(format t "~&~A" data-list)
(dex:post "https://tbl.tfcconnection.org/api/v1/db/data/v1/TFC/Health%20Forms/"
:headers headers
:content (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)))
(defun process-form (form)
"Processes the form and sends it on"
(uiop:println "---")
(maphash 'print-hash-entry form)
(uiop:println "---"))
(defun save-string-file (string file-path)
"save a file that is represented as a string to disk that came from a multipart/form-data"
(serapeum/bundle:write-string-into-file string file-path
:if-exists :overwrite
:if-does-not-exist :create
:external-format :latin-1))
(hunchentoot:define-easy-handler (respond :uri "/health-form") ()
(setf (hunchentoot:content-type*) "plain/text")
(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* ((data (hunchentoot::get-post-data :request *last*))
(content-type (hunchentoot:header-in "content-type" hunchentoot:*request*))
(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)))
(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)
(setq form-list (acons name image-file-name form-list))
(save-string-file
(apply #'concatenate 'string content) image-file-name)))
(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)))
(#+sbcl sb-sys:interactive-interrupt
#+ccl ccl:interrupt-signal-condition
#+clisp system::simple-interrupt-condition
#+ecl ext:interactive-interrupt
#+allegro excl:interrupt-signal
() (progn
(format *error-output* "Aborting.~&")
(hunchentoot:stop *server*)
(uiop:quit)))
(error (c) (format t "Woops, an unknown error occured:~&~a~&" c))))