cohost

rpc.lisp (5482B)

---

 (in-package :cohost.rpc)
 
 (defparameter +user-agent+ (concatenate 'string "CL-Cohost/0.1 " (drakma::user-agent-string :drakma)))
 
 (defun %cohost-rpc (client rpc-fn method &key request-content params content-type)
   "Low-level implementation for RPC methods. Usage identical to COHOST-RPC but can take either PARAMS (prestructured alist) or REQUEST-CONTENT and CONTENT-TYPE (raw POST data) as request body."
   (let* ((drakma:*text-content-types* (acons :application :json drakma:*text-content-types*))
          (rpc-uri (concatenate 'string (base-uri client) (api-path client) rpc-fn)))
     (multiple-value-bind (content http-code headers uri)
         (funcall (http-request client) rpc-uri :method method
                                                :content request-content
                                                :content-type content-type
                                                :parameters params
                                                :user-agent +user-agent+
                                                :cookie-jar (cookie-jar client)
                                                :decode-content t)
       (values (decode-json-from-string content) http-code headers uri))))
 
 (defun cohost-rpc (client rpc-fn method &rest params)
   "JSON RPC primitive.
 
 Usage: (COHOST-RPC [initialized client object] [API function to call, eg \"login\"] [HTTP method (:GET or :POST)] (zero or more KEYWORD value pairs expressing parameters, eg :EMAIL \"foo@bar.baz\"))"
   (labels ((param-pairs (params)
              (loop for (key val) on params by #'cddr
                    while val
                    collect (cons (sym->str key) (if (numberp val)
                                                     (write-to-string val)
                                                     val)))))
     (let* ((param-alist (param-pairs params)))
       (%cohost-rpc client rpc-fn method :params param-alist))))
 
 (defun cohost-json-rpc (client rpc-fn json &key (method :post))
   "JSON RPC primitive for RPC calls that consume a JSON blob directly.
 
 Usage: (COHOST-JSON-RPC [initialized client object] [API function to call, eg \"post\"] [JSON POST data] (:METHOD :POST or :PUT (default is :POST))"
   (%cohost-rpc client rpc-fn method :request-content json :content-type "application/json"))
 
 (defun cohost-trpc-batch (client requests)
   "Consumes a set of tRPC request objects to construct a batch call.
 
 Usage: (COHOST-TRPC-BATCH [initialized client object] [alist or batch items])
 
 Each batch item is a CONS structured as ([request] . [input data]). For requests with no data, eg login.loggedIn, the CDR is left NIL."
   (multiple-value-bind (batch-items input-items)
       (loop for pair in requests
             for idx = 0 then (1+ idx)
             if (> idx 0)
               collect "," into batch-items
             collect (car pair) into batch-items
             if (cdr pair)
               collect (cons idx (cdr pair)) into input-items
             finally (return (values batch-items input-items)))
     (let* ((batch (apply #'concatenate (append (list 'string "trpc/") batch-items)))
            (json::+json-lisp-symbol-tokens+ '(("true" . T)
                                               ("null" . nil)
                                               ("false" . nil)
                                               ("false" . :false)))
            (batch-input (encode-json-alist-to-string input-items)))
       (cohost-rpc client batch :get :batch 1 :input batch-input))))
 
 (defmacro define-trpc-request (name (&rest lambda-list))
   "Macro for defining tRPC request objects.
 
 Usage: (DEFINE-TRPC-REQUEST [String name of request, eg \"login.loggedIn\"] ((NIL for requests with no parameters, :atom for requests that take a single atomic value, eg a post ID, or a list of string names of parameters for requests that take JSON input))
 
 As an example (DEFINE-TRPC-REQUEST \"foo.wibbleFrotz\" ()) would create a function named FOO.WIBBLE-FROTZ that takes no parameters and returns a CONS (\"foo.wibbleFrotz\" . NIL).
 
 Functions created this way that construct a JSON input can take keyword :FALSE to express JSON false unambiguously. For instance:
 (DEFINE-TRPC-REQUEST \"test.bool\" (\"booleanParam\"))
 would create a function TEST.BOOL that takes a single parameter. (TEST.BOOL NIL) will result in a null value, {\"booleanParam\":null}, while (TEST.BOOL :FALSE) will emit a Javascript false, {\"booleanParam\":false}. This is clunky but unfortunately necessary as Javascript has different ideas of falsity and nullity than CL."
   (labels ((bomb ()
              (error "Invalid lambda list for tRPC request (~A)" lambda-list))
            (create-ll-and-datum (raw-ll)
              (loop for param in raw-ll
                    for sym = (gensym)
                    collect sym into lambda-list
                    collect `(cons ,param ,sym) into a-list
                    if (not (stringp param))
                      do (bomb)
                    finally (return (cons lambda-list `(list ,@a-list))))))
     (let* ((lisp-name (intern (json:camel-case-to-lisp name)))
            (data-sym (gensym))
            (ll-and-datum (cond
                            ((eq (car lambda-list) :atom) (cons `(,data-sym) data-sym))
                            ((null lambda-list) '())
                            ((listp lambda-list) (create-ll-and-datum lambda-list))
                            (t (bomb)))))
       `(defun ,lisp-name ,(car ll-and-datum)
          (cons ,name ,(cdr ll-and-datum))))))