Author: lgiessmann Date: Tue Aug 2 00:54:16 2011 New Revision: 701
Log: trunk: playground: implemented an interface that returns all psis and a json fragment via usocket's tcp-sockets - instead of using hunchentoot
Modified: trunk/playground/tcp-connector.lisp
Modified: trunk/playground/tcp-connector.lisp ============================================================================== --- trunk/playground/tcp-connector.lisp Mon Aug 1 07:56:39 2011 (r700) +++ trunk/playground/tcp-connector.lisp Tue Aug 2 00:54:16 2011 (r701) @@ -9,8 +9,7 @@
;; source: http://mihai.bazon.net/blog/howto-multi-threaded-tcp-server-in-common-lisp
-(asdf:operate 'asdf:load-op :usocket) -(asdf:operate 'asdf:load-op :bordeaux-threads) +(asdf:operate 'asdf:load-op :isidorus)
(defun make-server (&key (hostname "localhost") (port 8000)) @@ -71,22 +70,33 @@ (usocket:socket-close client-socket))
-(defun task (client-socket mega-loops name) - (declare (String name) - (integer mega-loops) - (usocket:stream-usocket client-socket)) - (let ((loops (* 1000000 mega-loops))) - (dotimes (counter loops) - (/ (* loops loops) loops)) - (read-from-client client-socket) ;ignore cient data - (send-to-client client-socket (format nil "~a finished ~a loops" name loops)))) +(defvar *stop-listen* nil "if this variable is set to t, the listener stops to listen after the next client has been accepted")
-(defvar *stop-listen* nil "if tis variable is set to t, te listener stops to listen after the next client is accepted") +(defun stop-listen-for-clients (server) + (setf *stop-listen* t) + (usocket:socket-close server) + (base-tools:close-tm-store))
-(defun stop-listen-for-clients () - (setf *stop-listen* t)) +(defun client-task (client-socket) + (declare (usocket:stream-usocket client-socket)) + (handler-case + (let ((client-data (read-from-client client-socket))) + (let ((response + (cond ((string-starts-with (first (getf client-data :headers)) + "GET /json/psis") + (get-psis)) + ((string-starts-with (first (getf client-data :headers)) + "GET /json/get/") + (get-fragment (get-requested-psi-of-http-header + (first (getf client-data :headers))))) + (t + (concatenate 'string ">> bad request: ~a~%" + (first (getf client-data :headers))))))) + (send-to-client client-socket response))) + (condition () + (usocket:socket-close client-socket))))
(defun listen-for-clients (server) @@ -99,14 +109,78 @@ (let ((client (wait-for-client srv))) (format t "client # ~a connected~%" counter) (sb-thread:make-thread - (lambda() - (funcall (lambda(client-socket thread-name) - (declare (usocket:stream-usocket client-socket) - (String thread-name)) - (read-from-client client-socket) ;ignore client data - (send-to-client client-socket thread-name)) - client (format nil "thread-~a" counter))) + (lambda() (funcall #'client-task client)) :name (format nil "worker-thread: ~a" counter))) (incf counter) (setf stop-p *stop-listen*))) - server)))) + server)) + :name "server-listener")) + + +(defun get-psis () + (isidorus-threading:with-reader-lock + (json-exporter:get-all-topic-psis :revision 0))) + + +(defun get-fragment(psi) + (let ((fragment (isidorus-threading:with-reader-lock + (d:get-latest-fragment-of-topic psi)))) + (if (and fragment + (d:find-item-by-revision (d:topic fragment) 0)) + (json-exporter:export-construct-as-isidorus-json-string fragment :revision 0) + (concatenate 'string psi " not found")))) + + +(defun get-requested-psi-of-http-header (first-header-line) + (declare (String first-header-line)) + (when (and (string-starts-with first-header-line "GET /json/get/") + (or (string-ends-with first-header-line "HTTP/1.0") + (string-ends-with first-header-line "HTTP/1.1"))) + (let ((psi (subseq first-header-line + (length "GET /json/get/") + (- (length first-header-line) (length "HTTP/1.0"))))) + (hunchentoot:url-decode (string-trim '(#\space) psi))))) + + +(defun string-starts-with (str prefix &key (ignore-case nil)) + "Checks if string str starts with a given prefix." + (declare (String str prefix) + (Boolean ignore-case)) + (let ((str-i (if ignore-case + (string-downcase str :start 0 :end (min (length str) + (length prefix))) + str)) + (prefix-i (if ignore-case + (string-downcase prefix) + prefix))) + (string= str-i prefix-i :start1 0 :end1 + (min (length prefix-i) + (length str-i))))) + + +(defun string-ends-with (str suffix &key (ignore-case nil)) + "Checks if string str ends with a given suffix." + (declare (String str suffix) + (Boolean ignore-case)) + (let ((str-i (if ignore-case + (string-downcase str :start (max (- (length str) + (length suffix)) + 0) + :end (length str)) + str)) + (suffix-i (if ignore-case + (string-downcase suffix) + suffix))) + (string= str-i suffix-i :start1 (max (- (length str) + (length suffix)) + 0)))) + + +(defun main() + (format t ">> entered (main)") + (base-tools:open-tm-store "/home/lukas/.sbcl/site/isidorus/trunk/src/data_base") + (defvar *server* (make-server :port 8080)) + (listen-for-clients *server*)) + + +(main) \ No newline at end of file