jungle-server/data-app.lisp

(in-package :server)

(defvar *data-connections* (make-hash-table))

(defun handle-new-data-connection (con env)
  (setf (gethash con *data-connections*)
	(current-id env)))

(defun handle-close-data-connection (con)
  (remhash con *data-connections*))

(defun broadcast-data (data)
  (loop :for con :being :the :hash-key :of *data-connections* :do
       (websocket-driver:send con data)))


(defun data-server (env)
  (let ((ws (websocket-driver:make-server env)))
    (websocket-driver:on :open ws
			 (lambda () (handle-new-data-connection ws env)))
    (websocket-driver:on :message ws
			 (lambda (msg) msg))
    (websocket-driver:on :close ws
			 (lambda (&key code reason)
			   (declare (ignore code reason))
			   (handle-close-data-connection ws)))
    (lambda (responder)
      (declare (ignore responder))
      (websocket-driver:start-connection ws))))


(defparameter *data-app*
  (lack:builder
   ;;;;editors
   
   (:mount "/add"
	   (lambda (env)
	     (let ((parsed-json (parse-json env)))
	       (data:with-transaction ()
		 (let ((object (make-instance (intern
					       (string-upcase (gethash "type" parsed-json))
					       (find-package :data)))))
		   (data:set-from-parsed-json object parsed-json)
		   (broadcast-data (data:data-json object))
		   `(200 (:content-type "text/plain") (,(format nil "~a" (data:id object)))))))))

   
   (:mount "/set"
	   (lambda (env)
	     (let* ((parsed-json (parse-json env))
		    (old-data (data:data-with-id (gethash "id" parsed-json))))
	       
	       (cond (old-data
		      (data:with-transaction ()
			(data:set-from-parsed-json old-data parsed-json))
		      (broadcast-data (data:data-json old-data))
		      `(200 (:content-type "text/plain") ("set")))
		     (t `(200 (:content-type "text/plain") ("no longer exists")))))))

   (:mount "/delete"
	   (lambda (env)
	     (let ((object (data:data-with-id (parse-integer
					       (subseq (getf env :path-info) 1)))))
	       
	       (cond ((> (length (data:all-of object)) 1)
		      (let ((msg (format nil "{\"delete\":true,\"data\":~a}"
					 (data:data-json object))))
			(broadcast-data msg))
		      (data:delete-data object)
		      `(200 (:content-type "text/plain") ("deleted")))
		     (t `(200 (:content-type "text/plain") ("saved last of kind")))))))

   
   ;;;;all of type

   (:mount "/all"
	   (lambda (env)
	     (let* ((type (intern (string-upcase (subseq (getf env :path-info) 1))
				  (find-package :data)))
		    (json (data:data-type-json type)))
	       `(200 (:content-type "application/json")
		     (,json)))))


   ;;;;by id

   (:mount "/get"
	   (lambda (env)
	     (let* ((path (getf env :path-info))
		    (object  (data:data-with-id (parse-integer path))))
	       
	       `(200 (:content-type "application/json") (,(data:data-json object))))))
   

   (:mount "/highest-id"
	   (lambda (env)
	     (declare (ignore env))
	     (let ((highest-id (format nil "~a"
				       (apply #'max (mapcar #'data:id (data:all-data))))))
	       `(200 (:content-type "application/json")
		     (,highest-id)))))
   

   ;;;;denizen specific

   
   (:mount "/current-configuration"
	   (lambda (env)
	     `(200
	       (:content-type "application/json")
	       (,(current-configuration-json env)))))

   
   (:mount "/current-denizen"
	   (lambda (env)
	     `(200
	       (:content-type "application/json")
	       (,(data:data-json (denizenp env))))))

   


   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   (lambda (env)
     
     (let ((path-info (getf env :path-info)))
       (princ "bad data path-info: ")
       (princ path-info)
       
       (cond (t '(404 (:content-type "text/plain") ("no such data"))))))))