#!/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 )) (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)) ))) (read-line) (marshal (json-parse (read-chars content-length))))))) (close client)) (select-remove server fds)))) (provide "echo") (echo-server)