tinmop/src/json-rpc2.lisp

;; tinmop: a multiprotocol client
;; Copyright © cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].

(in-package :json-rpc2)

(define-constant +protocol-version+               "2.0" :test #'string=)

(define-constant +key-name+                   "jsonrpc" :test #'string=)

(define-constant +key-method+                  "method" :test #'string=)

(define-constant +key-params+                  "params" :test #'string=)

(define-constant +key-id+                          "id" :test #'string=)

(define-constant +key-error+                    "error" :test #'string=)

(define-constant +key-error-code+                "code" :test #'string=)

(define-constant +key-error-message+          "message" :test #'string=)

(define-constant +key-error-data+                "data" :test #'string=)

(define-constant +key-result+                 "result" :test #'string=)

(define-constant +error-reserved-min+            -32099 :test #'=)

(define-constant +error-reserved-max+            -32000 :test #'=)

(define-constant +error-reserved-method-name+ "^rpc\\." :test #'string=)

(defun invalid-method-name-p (n)
  (cl-ppcre:scan +error-reserved-method-name+ n))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-response-error (code message &optional (data nil))
    (list (cons +key-error-code+    code)
          (cons +key-error-message+ message)
          (cons +key-error-data+    data)))

  (defun response-error-code (err)
    (cdar err))

  (defun response-error-message (err)
    (cdadr err)))

(defmacro define-error-code (name number message &key (customp nil))
  (if (and customp
           (not (<= +error-reserved-min+ number +error-reserved-max+)))
      (error (format nil "implementation defined error bust be between ~a  and ~a"
                     +error-reserved-min+ +error-reserved-max+))
      `(define-constant ,(misc:format-fn-symbol t "+error-~a+" name)
           (make-response-error ,number ,message)
         :test #'equalp)))

(define-error-code parse                -32700  "Parse error")

(define-error-code invalid-request      -32600  "Invalid Request")

(define-error-code method-not-found     -32601  "Method not found")

(define-error-code invalid-params       -32602  "Invalid params")

(define-error-code unsupported-protocol -32098  "Only protocol version 2.0 is supported"
                   :customp t)

(defun make-internal-error-message (msg data)
  (make-response-error -32603 (format nil "Internal error: ~a" msg) data))

(defun make-failed-function-call-error-message (msg &optional (data nil))
  (make-response-error -32001
                       (format nil "Failed function call: ~a" msg)
                       data))

(defclass function-param ()
  ((name
    :initarg  :name
    :initform ""
    :accessor name
    :type     string)
   (pos
    :initarg  :pos
    :initform -1
    :accessor pos
    :type     integer)))

(defmethod print-object ((object function-param) stream)
  (format stream "[~s @ ~a]" (name object) (pos object)))

(defparameter *request-id*  1)

(defun generate-request-id ()
  (incf *request-id*)
  *request-id*)

(define-condition json-rpc-error (error)
  ((transaction-id
    :initform nil
    :initarg :transaction-id
    :reader  transaction-id)
   (code
    :initarg :code
    :reader  code)
   (text
    :initarg :text
    :reader text))
  (:report (lambda (condition stream)
             (format stream "~a" (text condition))))
  (:documentation "Error for all jsonrpc related problems"))

(defmacro make-json-rpc-error (code message)
  `(progn
     (assert (< -32000 ,code -32099))
     (error 'json-rpc-error  :text ,message :code ,code)))

(defparameter *function-db* '())

(defun make-fun-params (name position)
  (cond
    ((not (stringp name))
     (error 'json-rpc-error
            :text (format nil "Name of a function parameter must be a string not ~a" name)))
    ((or (not (integerp position))
         (<   position 0))
     (error 'json-rpc-error
            :text (format nil
                          "The position of a function parameter must be positive integer not ~a"
                          position)))
    (t
     (make-instance 'function-param  :name name :pos position))))

(defun find-function (sym)
  (conditions:with-default-on-error (nil)
    (symbol-function sym)))

(defun register-function (function-id fun &optional params)
  (let* ((actual-params (loop for param in params collect
                             (make-fun-params (car param)
                                              (cdr param))))
         (fun           (make-instance 'rpc-function
                                       :function-id function-id
                                       :fun-symbol  fun
                                       :params      actual-params)))
    (push fun *function-db*)))

(defun compare-functions-fn (function-id)
  (lambda (a)
    (string= function-id (function-id a))))

(defun unregister-function (function-id)
  (setf *function-db* (remove-if (compare-functions-fn function-id) *function-db*)))

(defun lookup-function (function-id)
  (find-if (compare-functions-fn function-id) *function-db*))

(defclass identificable ()
  ((id
    :initarg  :id
    :initform -1
    :accessor id
    :type     integer)))

(defclass fun-symbol-box ()
  ((fun-symbol
    :initarg  :fun-symbol
    :initform nil
    :accessor fun-symbol
    :type     symbol)))

(defmethod initialize-instance :after ((object fun-symbol-box) &key &allow-other-keys)
  (with-accessors ((fun-symbol fun-symbol)) object
    (cond
      ((not (symbolp fun-symbol))
       (error 'json-rpc-error
              :text (format nil "function symbol of a function must be a symbol not ~a"
                            fun-symbol)))
      ((not (find-function fun-symbol))
       (error 'json-rpc-error
              :text (format nil "~a is not a function" fun-symbol))))))

(defclass fun-box ()
  ((function-id
    :initarg  :function-id
    :initform ""
    :accessor function-id
    :type     string)
   (params
    :initarg  :params
    :initform '()
    :accessor params
    :type     list)))

(defmethod initialize-instance :after ((object fun-box) &key &allow-other-keys)
  (with-accessors ((function-id function-id)) object
    (cond
      ((not (stringp function-id))
       (error 'json-rpc-error
              :text (format nil "ID of a function must be a string not ~a" function-id)))
      ((invalid-method-name-p function-id)
       (error 'json-rpc-error
              :text (format nil
                            "function ID invalid, starts with a reserved prefix ~s"
                            +error-reserved-method-name+))))))

(defmethod print-object ((object fun-box) stream)
  (format stream "function-id: ~s params ~s" (function-id object) (params object)))

(defclass rpc-function (fun-symbol-box fun-box) ())

(defmethod print-object ((object rpc-function) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "symbol ~s " (fun-symbol object))
    (call-next-method)))

(defclass rpc-request (fun-box identificable) ())

(defclass rpc-request-batch ()
  ((requests
    :initform '()
    :initarg  :requests
    :accessor requests)))

(defun make-batch (&rest requests)
  (make-instance 'rpc-request-batch :requests requests))

(defun %make-request (method id  &rest params)
  (let ((req (make-instance 'rpc-request
                            :function-id method
                            :id          id
                            :params      params)))
    req))

(defun make-request (method id &rest params)
  (apply #'%make-request method id params))

(defun make-request* (method id param)
  (if (typep param 'proper-list)
      (apply #'%make-request method id param)
      (apply #'%make-request method id (list param))))

(defun make-notification (method &rest params)
  (apply #'%make-request method nil params))

(defun make-notification* (method params)
  (apply #'%make-request method nil params))

(defclass rpc-response (identificable)
  ((payload
    :initform nil
    :initarg :payload
    :accessor payload)
   (error-response
    :initform nil
    :initarg :error-response
    :accessor error-response)))

(defmethod yason:encode ((object rpc-response) &optional (stream *standard-output*))
  (with-accessors ((payload        payload)
                   (error-response error-response)
                   (request-id     id)) object
    (yason:with-output (stream)
      (let ((yason:*list-encoder* #'yason:encode-alist)
            (yason:*symbol-encoder* #'yason:encode-symbol-as-lowercase))
        (if error-response
            (yason:encode (list (cons +key-name+   +protocol-version+)
                                (cons +key-error+  error-response)
                                (cons +key-id+     request-id))
                          stream)
            (progn
              (yason:with-object ()
               (yason:with-object-element (+key-name+)
                 (yason:encode +protocol-version+ stream))
                (yason:with-object-element (+key-result+)
                  (yason:encode payload stream))
                (yason:with-object-element (+key-id+)
                  (let ((yason:*list-encoder* #'yason:encode-plist))
                  (yason:encode request-id stream))))))))))

(defmethod yason:encode ((object rpc-request) &optional (stream *standard-output*))
  (let ((yason:*list-encoder* #'yason:encode-alist))
    (yason:encode (render-as-list object) stream)))

(defmethod yason:encode ((object rpc-request-batch) &optional (stream *standard-output*))
  (yason:with-output (stream)
    (yason:with-array ()
      (loop for request in (requests object) do
        (yason:encode-array-element request)))))

(defun encode-to-string (object)
  (with-output-to-string (stream)
    (yason:encode object stream)))

(defgeneric render-as-list (object))

(defmethod render-as-list (object)
  object)

(defmethod render-as-list ((object rpc-request-batch))
  (loop for i in (requests object) collect (render-as-list i)))

(defmethod render-as-list ((object rpc-response))
  (payload object))

(defmethod render-as-list ((object rpc-request))
  (with-accessors ((id          id)
                   (function-id function-id)
                   (params      params)) object
    (let ((default  (list (cons +key-name+   +protocol-version+)
                          (cons +key-method+ function-id))))
      (when (not (null (first params)))
        (setf default (append default (list (cons +key-params+ params)))))
      (if id
          (append default
                  (list (cons +key-id+ id)))
          default))))

(defun make-response (results request-id &key (error-object nil))
  (make-instance 'rpc-response
                 :id      request-id
                 :payload results
                 :error-response error-object))

(defun supported-version-p (v)
  (and v
       (stringp v)
       (string= v +protocol-version+)))

(defun called-by-name-p (fun params)
  (let ((names          (loop for i in params when (consp i) collect (car i)))
        (template-names (loop for i in (params fun) collect (name i))))
    (and names
         (every (lambda (a) (or (symbolp a) (stringp a))) names)
         (null (set-difference names template-names :test #'string-equal)))))

(defun call-function (request)
  (flet ((call-fun (fn params)
           (apply (symbol-function (fun-symbol fn)) params)))
    (let ((fun (lookup-function (function-id request))))
      (cond
        ((not fun)
         (error 'json-rpc-error
                :code           (response-error-code +error-method-not-found+)
                :transaction-id (id request)
                :text           (format nil
                                        "~a: ~s"
                                        (response-error-message +error-method-not-found+)
                                        (function-id request))))
        ((/= (length (params request))
             (length (params fun)))
         (error 'json-rpc-error
                :code (response-error-code +error-invalid-params+)
                :transaction-id (id request)
                :text
                (format nil
                        "Number of parameters (arity) not compatible with function: expected ~a got ~a."
                        (length (params fun))
                        (length (params request)))))
        (t
         (let* ((params           (params request))
                (called-by-name-p (called-by-name-p fun params)))
           (if called-by-name-p
               (let ((params-list (make-list (length (params fun)))))
                 (loop for p in (params fun) do
                      (let* ((param-name  (name p))
                             (param-pos   (pos p))
                             (param-value (cdr (assoc param-name params
                                                      :test #'string-equal))))
                        (setf (elt params-list param-pos) param-value)))
                 (call-fun fun params-list))
               (call-fun fun params))))))))

(defun displace-single-request (request)
  (flet ((lookup (k)
           (and (consp request)
                (every #'consp request)
                (cdr (assoc k request :test #'string-equal)))))
    (let ((protocol-version (lookup +key-name+))
          (method           (lookup +key-method+))
          (params           (lookup +key-params+))
          (id               (lookup +key-id+)))
      (cond
        ((null protocol-version)
         (error 'json-rpc-error
                :transaction-id id
                :code (response-error-code    +error-invalid-request+)
                :text (response-error-message +error-invalid-request+)))
        ((not (supported-version-p protocol-version))
         (error 'json-rpc-error
                :transaction-id id
                :code (response-error-code    +error-unsupported-protocol+)
                :text (response-error-message +error-unsupported-protocol+)))
        ((not (listp params))
         (error 'json-rpc-error
                :transaction-id id
                :code (response-error-code    +error-invalid-request+)
                :text (response-error-message +error-invalid-request+)))
        (t
         (values method id params))))))

(defun maybe-log-message (m)
  (declare (ignorable m))
  #+debug-json-rpc
  (misc:dbg m))

(defun elaborate-single-request (request)
  (flet ((make-rpc-error (e id &optional (data nil))
           (maybe-log-message (format nil "jsonrpc request failed: ~a" e))
           (make-response nil
                          (or (transaction-id e)
                              id)
                          :error-object (make-response-error (or (code e)
                                                                 (response-error-code +error-invalid-request+))
                                                             (text e)
                                                             data)))
         (make-internal-error (e &optional (data nil))
           (make-response nil
                          nil
                          :error-object (make-internal-error-message (format nil "~a" e)
                                                                     data)))
         (make-failed-function-error (e id &optional (data nil))
           (make-response nil
                          id
                          :error-object (make-failed-function-call-error-message (format nil
                                                                                         "~a"
                                                                                         e)
                                                                                 data))))
  (handler-case
      (multiple-value-bind (method id params)
          (displace-single-request request)
        (handler-case
            (let* ((request      (apply #'make-request method id params))
                   (elaborated   (call-function request)))
              (maybe-log-message (format nil
                                         "jsonrpc request ~s results ~s"
                                         request
                                         elaborated))
              (when id
                ;; if id is null is  a notification (i.e. the client
                ;; does not care about an answer)
                (make-response elaborated id :error-object nil)))
          (json-rpc-error (e)
            (make-rpc-error e id request))
          (error (e)
            (maybe-log-message (format nil "jsonrpc request failed: ~a" e))
            (make-failed-function-error e id request))))
    (json-rpc-error (e)
      (make-rpc-error e nil request))
    (error (e)
      (maybe-log-message (format nil "jsonrpc request failed with internal error!: ~a" e))
      (make-internal-error e request)))))

(defun likely-not-batch-p (request)
  (and (every (lambda (a) (and (consp a)
                               (car   a)
                               (cdr   a)))
              request)
       (assoc +key-name+   request :test #'string-equal)
       (assoc +key-method+ request :test #'string-equal)
       (assoc +key-params+ request :test #'string-equal)))

(defun request-batch-p (request)
  (handler-case
      (progn
        (displace-single-request request)
        nil)
    (json-rpc-error    ()
      (if (likely-not-batch-p request)
          nil
          t))
    (error             () t)))

(defun elaborate-request (raw-request)
  (handler-case
      (with-input-from-string (stream raw-request)
        (maybe-log-message (format nil "jsonrpc2 raw request~a" raw-request))
        (let ((decoded (yason:parse stream :object-as :alist)))
          (maybe-log-message (format nil "decoded request ~a~%" decoded))
          (if (request-batch-p decoded)
              (if (null decoded)
                  (elaborate-single-request decoded) ;; will build an error response
                  (remove-if #'null
                             (mapcar #'elaborate-single-request decoded)))
              (let ((results (elaborate-single-request decoded)))
                results))))
    (error (e)
      (maybe-log-message (format nil "request parse error: ~a" e))
      (make-response nil nil :error-object +error-parse+))))

(defgeneric make-json-extract-key (object))

(defmethod make-json-extract-key ((object string))
  (make-json-extract-key (make-keyword (string-upcase object))))

(defmethod make-json-extract-key ((object symbol))
  object)

(defun extract-results (response)
  (getf response (make-json-extract-key +key-result+)))

(defun error-response-p (response)
  (getf response (make-json-extract-key +key-error+)))

(defun extract-error (response)
  (let ((error-field (getf response (make-json-extract-key +key-error+))))
    (values (getf error-field (make-json-extract-key +key-id+))
            (getf error-field (make-json-extract-key +key-error-message+))
            (getf error-field (make-json-extract-key +key-error-code+))
            (getf error-field (make-json-extract-key +key-error-data+)))))