[isidorus-cvs] r701 - trunk/playground

[lgiessmann at common-lisp.net]

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