path: root/echo.lsp

#!/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)