blob: 20b5e7e1c06fea2ac071156145b0417e94f20b00 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
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)
|