Merge branch 'master' of /home/dbane/public_repos/lsp

1 files changed, 65 insertions, 0 deletions

diff --git a/echo.lsp b/echo.lsp
new file mode 100755
index 0000000..20b5e7e
--- /dev/null
+++ b/echo.lsp
@@ -0,0 +1,65 @@
+#!/home/dbane/openlisp-10.9.0/uxlisp -shell
+(require "json")
+(defpackage #:echo
+  (:use #:openlisp #:json)
+  (:export
+   #:echo-server)
+  )
+(in-package #:echo)
+(defconstant +content-length+ "Content-Length: ")
+(defconstant +cr+ (convert 13 <character>))
+(defun println (x s)
+   (format s "~A~%" x))
+(defun read-chars (len)
+   (let ((s nil))
+        (for ((chars-left len (- chars-left 1)))
+             ((= chars-left 0) (apply #'string-append (mapcar (lambda (c)
+                                                                 (create-string 1 c))
+                                                              (reverse s))))
+             (setq s (cons (read-char) s)))))
+(defun subtract-proc (l r)
+   (- l r))
+(defun dispatch (params)
+   (let ((jsonrpc-ver (json-get-object params "jsonrpc")))
+        (if (not (string= jsonrpc-ver "2.0"))
+            (error "Bad JSON-RPC version -- ~S" jsonrpc-ver)))
+   (case-using #'string= (json-get-object params "method")
+               (("subtract") (subtract-proc (json-get-object params "params/l") (json-get-object params "params/r")))
+               (("quit") (progn (quit)
+                                0))))
+(defun marshal (parsed-json)
+  (let ((str (create-string-output-stream))
+         (content-length (create-string-output-stream)))
+    (format str "{\"jsonrpc\":\"2.0\",\"result\":~A,\"id\":~A}" (dispatch parsed-json) (json-get-object parsed-json "id"))
+    (let ((json (get-output-stream-string str))
+           (s (standard-output)))
+      (format content-length "Content-Length: ~A" (length json))
+      (mapc (lambda (v) (println v s))
+        (list (get-output-stream-string content-length)
+          "Content-Type: application/vscode-jsonrpc; charset=utf-8"
+          ""))
+      (format s "~A" json))))
+(defun echo-server ()
+   ;; Server side (server addr : 127.0.0.1)
+   (with-server-socket (server 8192 "tcp")
+        (let ((fds (create-vector 16 ()))
+              (fdr (create-vector 16 ()))
+              (fdw (create-vector 16 ())))
+             (select-clear fds)
+             (select-add server fds)
+             (while (eq (select 1 fds fdr fdw () 5.0) 0)
+                    (print "Waiting ...."))
+             (let ((client (accept server)))
+                  ;; Talk with client using standard I/O.
+                  (with-standard-input client
+                     (with-standard-output client
+                          (while t
+                                 (let* ((line1 (read-line))
+                                        (tag-len (length +content-length+))
+                                        (content-length (convert (subseq line1 (- tag-len 1) (length line1)) <integer>)))
+                                       (read-line)
+                                       (marshal (json-parse (read-chars content-length)))))))
+                  (close client))
+             (select-remove server fds))))
+(provide "echo")
+(echo-server)