commit 82a025dde0d646d497746d9ef2267538ea89bc22 Author: Decay <decay@todayiwilllaunchmyinfantsonintoorbit.com> Date: Mon, 21 Nov 2022 17:43:14 -0800 Initial checkin Diffstat:
| A | .gitignore | | | 9 | +++++++++ |
| A | LICENSE | | | 18 | ++++++++++++++++++ |
| A | README.markdown | | | 51 | +++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | cohost.asd | | | 27 | +++++++++++++++++++++++++++ |
| A | src/client-v1-impl.lisp | | | 152 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/client.lisp | | | 168 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/cohost.lisp | | | 4 | ++++ |
| A | src/file.lisp | | | 7 | +++++++ |
| A | src/packages.lisp | | | 50 | ++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/rpc.lisp | | | 81 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/util.lisp | | | 101 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | tests/main.lisp | | | 116 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
12 files changed, 784 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore @@ -0,0 +1,9 @@ +*.abcl +*.fasl +*.dx32fsl +*.dx64fsl +*.lx32fsl +*.lx64fsl +*.x86f +*~ +../#* diff --git a/LICENSE b/LICENSE @@ -0,0 +1,18 @@ +/* + * THE STRONGEST PUBLIC LICENSE + * Draft 1, November 2010 + * + * Everyone is permitted to copy and distribute verbatim or modified + * copies of this license document, and changing it is allowed as long + * as the name is changed. + * + * THE STRONGEST PUBLIC LICENSE + * TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + * + * ⑨. This license document permits you to DO WHAT THE FUCK YOU WANT TO + * as long as you APPRECIATE CIRNO AS THE STRONGEST IN GENSOKYO. + * + * This program is distributed in the hope that it will be THE STRONGEST, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * USEFULNESS or FITNESS FOR A PARTICULAR PURPOSE. + */ diff --git a/README.markdown b/README.markdown @@ -0,0 +1,51 @@ +# Cohost + +## Installation + +Fetch this into your ASDF system directory (typically ~/common-lisp/): + +``` +$ cd ~/common-lisp +$ git clone https://todayiwilllaunchmyinfantsonintoorbit.com/cohost.git +``` + +Then in your favorite CL implementation, load it and its dependencies via Quicklisp: + +``` +(ql:quickload 'cohost) +``` + +## Usage + +The COHOST package contains the main public interface: + +**(COHOST:INIT-CLIENT)** - Returns a client object +**(COHOST:LOGIN [client] [email address] [password])** - Logs the client in to Cohost +**(COHOST:SIMPLE-POST [logged-in client] [project name to post to] [headline of post] [Markdown post contents] &KEY (:SHARE-OF [post id]) (:ADULT-CONTENT [boolean]) (:DRAFT [boolean]) (:TAGS [list of post tags]) (:CONTENT-WARNINGS [list of CWs]))** - Simple interface to create Markdown/text-only posts without having to go through the more complex mechanisms in COHOST.CLIENT. Returns a COHOST.CLIENT:CHOST object identical to the one posted to Cohost. +**(COHOST:NEW-POST [logged-in client] [project name to post to] &KEY (:ID [post ID, if this models an existing post]) (:BLOCKS [list of constructed BLOCK objects specifying post components]) (:HEADLINE [headline of post]) (:SHARE-OF [post id]) (:ADULT-CONTENT [boolean]) (:DRAFT [boolean]) (:TAGS [list of post tags]) (:CONTENT-WARNINGS [list of CWs])** - Similar in many respects to COHOST:SIMPLE-POST but consumes a preconstructed list of CONTENT-BLOCKs instead of a simple Markdown string. This fully supports creating a CHOST object with attachments. +**(COHOST:NEW-ATTACHMENT [logged-in client] [attachment id] &KEY (:ALT-TEXT [attachment alt text]))** - Create a new object for an *existing* post attachment. Not generally useful for basic post-only cases; if you want to *upload* an attachment, see the next function. Returns an ATTACHMENT CONTENT-BLOCK object. +**(COHOST:NEW-FILE-ATTACHMENT [logged-in client] [Lisp PATHNAME to file to upload] &KEY (:ALT-TEXT [attachment alt text]) (:FILENAME [filename to use for the upload, defaults to (FILE-NAMESTRING [pathname])]) (:CONTENT-TYPE [content-type of file, defaults to file's MIME type as determined by the TRIVIAL-MIMES package]))** - Create a new object for a new file attachment. Will be automatically uploaded and attached to the associated post at post time. Typically it's not necessary or useful to specify CONTENT-TYPE or FILENAME; if you're doing complicatd things that require you pass these explicitly, you'll know. Returns a FILE-ATTACHMENT CONTENT-BLOCK object. +**(COHOST:NEW-MARKDOWN-BLOCK [logged-in client] [Markdown content])** - Returns a MARKDOWN CONTENT-BLOCK object containing the specified content. +**(COHOST:COPY-POST [client] [post object]) - Returns a full deep copy of the specified post object that shares no structure with the original object, including fresh copies of all CONTENT-BLOCKs. +**(COHOST:POST [logged-in client] [post object]) - Posts a fully constructed post object with all attachments. If the post object passed in has a post ID set, will update the specified post, otherwise creates a new one. Returns a new CHOST object with ID populated and with any FILE-ATTACHMENT CONTENT-BLOCKs transformed into ATTACHMENTs containing the correct ID. + +Every class has a full set of exported accessors that also serve as SETF places. Each accessor corresponds to a constructor parameter above but some have function names different from the parameters above intended to avoid collisions or ambiguity: + +**CHOST** - Accessors: POST-ID, PROJECT, ADULT-CONTENT, CONTENT-BLOCKS, CONTENT-WARNINGS, DRAFT, HEADLINE, TAGS, SHARE-OF +**ATTACHMENT** - Accessors: ALT-TEXT, ATTACHMENT-ID +**FILE-ATTACHMENT** - Accessors: ALT-TEXT, ATTACHMENT-PATHNAME, ATTACHMENT-FILENAME, ATTACHMENT-CONTENT-TYPE +**MARKDOWN** - Accessors: CONTENT + +### Example Usage + +## Author + +* Decay (decay@todayiwilllaunchmyinfantsonintoorbit.com) + +## Copyright + +Copyright (c) 2022 Decay (decay@todayiwilllaunchmyinfantsonintoorbit.com) + +## License + +Licensed under the Strongest Public License. diff --git a/cohost.asd b/cohost.asd @@ -0,0 +1,27 @@ +(defsystem "cohost" + :version "0.1.0" + :author "Decay" + :license "Strongest Public License" + :depends-on ("drakma" "cl-json" "cl-base64" "babel" "ironclad" "trivial-mimes") + :components ((:module "src" + :components + ((:file "packages") + (:file "util") + (:file "file") + (:file "client") + (:file "rpc") + (:file "client-v1-impl") + (:file "cohost")))) + :description "Unofficial Common Lisp client library for Cohost" + :in-order-to ((test-op (test-op "cohost/tests")))) + +(defsystem "cohost/tests" + :author "Decay" + :license "Strongest Public License" + :depends-on ("cohost" + "rove") + :components ((:module "tests" + :components + ((:file "main")))) + :description "Test system for cohost" + :perform (test-op (op c) (symbol-call :rove :run c))) diff --git a/src/client-v1-impl.lisp b/src/client-v1-impl.lisp @@ -0,0 +1,152 @@ +(in-package :cohost.client-v1-impl) + +(defclass cohost-client-v1 (cohost-client) ()) + +(defmethod init-client ((api-ver (eql :v1))) + (make-instance 'cohost-client-v1 :cookie-jar (make-instance 'drakma:cookie-jar))) + +(defun %salt (client email) + (assoc-val :salt (cohost-rpc client "login/salt" :get :email email))) + +(defun %login (client email client-hash) + (cohost-rpc client "login" :post :email email :client-hash client-hash)) + +(defmethod login ((client cohost-client-v1) email password) + (labels ((pad-base64 (salt) + (format nil "~A~v@{~A~:*~}" salt (mod (length salt) 4) #\.)) + (derive-client-hash (password salt) + (derive-key + (make-kdf :pbkdf2 :digest :sha384) + (string-to-octets password) + (base64-string-to-usb8-array + (pad-base64 salt) + :table base64:+uri-decode-table+) + 200000 + 128))) + (let* ((salt (%salt client email)) + (client-hash (usb8-array-to-base64-string (derive-client-hash password salt)))) + (%login client email client-hash)))) + +(defgeneric encode-block (block) + (:method ((block attachment)) + (json:with-object () + (json:encode-object-member :type "attachment") + (json:as-object-member (:attachment) + (json:with-object () + (json:encode-object-member :alt-text (or (alt-text block) "")) + (json:encode-object-member :attachment-id (attachment-id block)))))) + (:method ((block file-attachment)) + (json:with-object () + (json:encode-object-member :type "attachment") + (json:as-object-member (:attachment) + (json:with-object () + (json:encode-object-member :alt-text (or (alt-text block) "")) + (json:encode-object-member :attachment-id "00000000-0000-0000-0000-000000000000"))))) + (:method ((block markdown)) + (json:with-object () + (json:encode-object-member :type "markdown") + (json:as-object-member (:markdown) + (json:with-object () + (json:encode-object-member :content (or (content block) ""))))))) + +(defun upload-as-attachment-and-update (client project post-id block) + (if (typep block 'file-attachment) + (let* ((api-path-prefix (format nil "project/~a/posts/~a/attach" project post-id)) + (start (cohost-rpc client (strcat api-path-prefix "/start") :post + :filename (attachment-filename block) + :content_type (attachment-content-type block) + :content_length (filesize (attachment-pathname block)))) + (attachment-id (assoc-val :attachment-id start))) + (when attachment-id + (let* ((cdn-url (assoc-val :url start)) + (required-fields (assoc-val :required-fields start)) + ;; This is really weird, using this clunky APPEND instead of the nicer ACONS, but + ;; digitalocean barfs if the file field doesn't appear at the end of input, + ;; after the required fields! + (form-fields-raw (append required-fields + (list (list :file + (attachment-pathname block) + :content-type (attachment-content-type block) + :filename (attachment-filename block))))) + (form-fields (loop for pair in form-fields-raw + while pair + collect (cons (lisp-to-cdn-case (symbol-name (car pair))) (cdr pair))))) + + ;; Sort of breaking abstraction here, we should have a general method for CDN uploads + (multiple-value-bind (content http-code) + (funcall (http-request client) cdn-url :method :post + :parameters form-fields + :user-agent cohost.rpc::+user-agent+ + :content-length t) + (declare (ignore content)) + (if (eql http-code 204) + (let* ((finish (cohost-rpc client (strcat api-path-prefix "/finish/" attachment-id) :post)) + (attachment-id (assoc-val :attachment-id finish))) + (if finish + (new-attachment client attachment-id :alt-text (alt-text block)) + block)) + block))))) + block)) + +(defun post->json (post-obj) + (with-output-to-string (json:*json-output*) + (json:with-object () + (json:encode-object-member :post-state (if (draft post-obj) 0 1)) + (encode-json-boolean :adult-content (adult-content post-obj)) + (json:encode-object-member :headline (or (headline post-obj) "")) + (when (share-of post-obj) + (json:encode-object-member :share-of-post-id (share-of post-obj))) + (encode-json-array :cws (content-warnings post-obj)) + (encode-json-array :tags (tags post-obj)) + (json:as-object-member (:blocks) + (json:with-array () + (dolist (block (content-blocks post-obj)) + (json:as-array-member () + (encode-block block)))))))) + +(defun %post (client post-obj) + (cohost-json-rpc client + (format nil "project/~a/posts" (project post-obj)) + (post->json post-obj))) + +(defun %update (client post-obj) + (cohost-json-rpc client + (format nil "project/~a/posts/~a" (project post-obj) (post-id post-obj)) + (post->json post-obj) + :method :put)) + +(defmethod post ((client cohost-client-v1) post-obj) + (let* ((project (project post-obj)) + (old-post-id (post-id post-obj)) + (post-response (if old-post-id + (%update client post-obj) + (%post client post-obj))) + (post-id (assoc-val :post-id post-response)) + (attachmentsp (find-if (lambda (block) (typep block 'file-attachment)) (content-blocks post-obj)))) + (cond + ((and post-id attachmentsp) + (let ((new-post (copy-post client post-obj))) + (setf (post-id new-post) post-id) + (setf (content-blocks new-post) + (loop for block in (content-blocks post-obj) + collect (upload-as-attachment-and-update client project post-id block))) + ;; Just fire and forget for now + (%update client new-post) + new-post)) + (post-id + (let ((new-post (copy-post client post-obj))) + (setf (post-id new-post) post-id) + new-post)) + (t (values post-obj post-response))))) + +;;; tRPC primitive queries + +(define-trpc-request "projects.listEditedProjects" ()) +(define-trpc-request "projects.followingState" ("projectHandle")) +(define-trpc-request "login.loggedIn" ()) +(define-trpc-request "bookmarks.tags.list" ()) +(define-trpc-request "users.displayPrefs" ()) +(define-trpc-request "posts.isLiked" (:atom)) +(define-trpc-request "posts.getPost" (:atom)) +(define-trpc-request "posts.getPostsTagged" ("projectHandle" "tagSlug")) +(define-trpc-request "posts.byProject" ("projectHandle" "page")) diff --git a/src/client.lisp b/src/client.lisp @@ -0,0 +1,168 @@ +(in-package :cohost.client) + +(defclass cohost-client () + ((http-request + :initarg :http-request + :initform #'drakma:http-request + :accessor http-request) + (base-uri + :initarg :base-uri + :initform "https://cohost.org/api/v1/" + :accessor base-uri) + (cookie-jar + :initarg :cookie-jar + :initform nil + :accessor cookie-jar))) + +(defclass chost () + ((id + :initarg :id + :initform nil + :accessor post-id) + (project + :initarg :project + :initform nil + :accessor project) + (adult-content + :initarg :adult-content + :initform nil + :accessor adult-content) + (blocks + :initarg :blocks + :initform nil + :accessor content-blocks) + (content-warnings + :initarg :content-warnings + :initform nil + :accessor content-warnings) + (draft + :initarg :draft + :initform nil + :accessor draft) + (headline + :initarg :headline + :initform nil + :accessor headline) + (tags + :initarg :tags + :initform nil + :accessor tags) + (share-of + :initarg :share-of + :initform nil + :accessor share-of))) + +(defclass content-block () ()) + +(defclass attachment (content-block) + ((alt-text + :initarg :alt-text + :initform nil + :accessor alt-text) + (attachment-id + :initarg :attachment-id + :initform nil + :accessor attachment-id))) + +(defclass file-attachment (content-block) + ((alt-text + :initarg :alt-text + :initform nil + :accessor alt-text) + (pathname + :initarg :pathname + :initform nil + :accessor attachment-pathname) + (filename + :initarg :filename + :initform nil + :accessor attachment-filename) + (content-type + :initarg :content-type + :initform nil + :accessor attachment-content-type))) + +(defclass markdown (content-block) + ((content + :initarg :content + :initform nil + :accessor content))) + +(defgeneric init-client (api-ver) + (:documentation "Initialize client for given Cohost API version")) + +(defgeneric login (client email password) + (:documentation "Log in to Cohost with email and password")) + +(defgeneric new-markdown-block (client content) + (:documentation "Create new markdown block for posting") + (:method (client content) + (make-instance 'markdown :content content))) + +(defgeneric new-attachment (client attachment-id &key alt-text) + (:documentation "Create a new existing attachment block") + (:method (client attachment-id &key alt-text) + (make-instance 'attachment :attachment-id attachment-id + :alt-text alt-text))) + +(defgeneric new-file-attachment (client pathname &key alt-text filename content-type) + (:documentation "Create new attachment block from PATHNAME") + (:method (client pathname &key alt-text filename content-type) + (make-instance 'file-attachment :pathname pathname + :alt-text alt-text + :filename (or filename (file-namestring pathname)) + :content-type (or content-type (mimes:mime pathname))))) + +(defgeneric new-post (client project &key id draft adult-content blocks content-warnings headline tags share-of) + (:documentation "Create new post object") + (:method (client project &key id draft adult-content blocks content-warnings headline tags share-of) + (make-instance 'chost :id id + :project project + :draft draft + :adult-content adult-content + :share-of share-of + :blocks blocks + :content-warnings content-warnings + :headline headline + :tags tags))) + +(defgeneric clone-block (client block) + (:documentation "Clone a block object") + (:method (client (block attachment)) + (new-attachment client (attachment-id block) :alt-text (alt-text block))) + (:method (client (block file-attachment)) + (new-file-attachment client (attachment-pathname block) + :alt-text (alt-text block) + :filename (attachment-filename block) + :content-type (attachment-content-type block))) + (:method (client (block markdown)) + (new-markdown-block client (content block)))) + +(defun copy-post (client post) + "Clone a post object" + (labels ((clone-blocks (blocks) + (loop for block in blocks + for new-block = (clone-block client block) + collect new-block))) + (make-instance 'chost :id (post-id post) + :project (project post) + :draft (draft post) + :adult-content (adult-content post) + :share-of (share-of post) + :blocks (clone-blocks (content-blocks post)) + :content-warnings (copy-list (content-warnings post)) + :headline (headline post) + :tags (copy-list (tags post))))) + +(defgeneric post (client post-obj) + (:documentation "Post POST-OBJ, handling uploads for attachments as necessary.")) + +(defun simple-post (client project headline markdown &key share-of adult-content tags content-warnings draft) + (post client (new-post client project + :headline headline + :adult-content adult-content + :share-of share-of + :draft draft + :blocks (list (new-markdown-block client markdown)) + :content-warnings content-warnings + :tags tags))) diff --git a/src/cohost.lisp b/src/cohost.lisp @@ -0,0 +1,4 @@ +(in-package :cohost) + +(defun init-client () + (cohost.client:init-client :v1)) diff --git a/src/file.lisp b/src/file.lisp @@ -0,0 +1,7 @@ +(in-package #:cohost.file) + +(defun filesize (pathname) + (with-open-file (s pathname + :direction :input + :element-type '(unsigned-byte 8)) + (file-length s))) diff --git a/src/packages.lisp b/src/packages.lisp @@ -0,0 +1,50 @@ +(defpackage cohost.util + (:use :cl) + (:export #:sym->str #:strcat #:-> #:->> + #:encode-json-boolean #:encode-json-array #:sassoc #:assoc-val #:lisp-to-cdn-case)) + +(defpackage cohost.file + (:use :cl) + (:export #:filesize)) + +(defpackage cohost.client + (:use :cl :cohost.util) + (:export #:cohost-client #:init-client #:base-uri #:login #:http-request #:cookie-jar + #:new-post #:adult-content #:content-blocks #:content-warnings #:headline #:tags + #:attachment #:file-attachment #:markdown #:alt-text #:attachment-id #:pathname + #:filename #:content-type #:content #:copy-post #:clone-block #:attachment-pathname + #:attachment-filename #:attachment-content-type + #:new-markdown-block #:new-attachment #:new-file-attachment + #:project #:draft #:share-of #:post #:simple-post #:post-id)) + +(defpackage cohost.rpc + (:use :cl) + (:import-from :cohost.util #:sym->str) + (:import-from :cohost.client #:base-uri #:http-request #:cookie-jar) + (:import-from :json #:decode-json-from-string #:lisp-to-camel-case #:encode-json-alist-to-string) + (:export #:cohost-rpc #:cohost-json-rpc #:cohost-trpc-batch + #:define-trpc-request)) + +(defpackage cohost.client-v1-impl + (:use :cl :cohost.client :cohost.util :cohost.file) + (:import-from :cohost.rpc #:cohost-rpc #:cohost-json-rpc #:define-trpc-request) + (:import-from :babel #:string-to-octets) + (:import-from :base64 #:base64-string-to-usb8-array #:usb8-array-to-base64-string) + (:import-from :ironclad #:derive-key #:make-kdf)) + +(defpackage cohost + (:use :cl) + (:import-from :cohost.client #:base-uri #:login #:simple-post #:new-post #:new-attachment + #:new-file-attachment #:new-markdown-block + #:copy-post #:post + #:post-id #:project #:adult-content #:content-blocks + #:content-warnings #:draft #:headline #:tags #:share-of + #:alt-text #:attachment-id #:attachment-pathname + #:attachment-filename #:attachment-content-type #:content) + (:export #:init-client #:base-uri #:login #:simple-post #:new-post #:new-attachment + #:new-file-attachment #:new-markdown-block + #:copy-post #:post + #:post-id #:project #:adult-content #:content-blocks + #:content-warnings #:draft #:headline #:tags #:share-of + #:alt-text #:attachment-id #:attachment-pathname + #:attachment-filename #:attachment-content-type #:content)) diff --git a/src/rpc.lisp b/src/rpc.lisp @@ -0,0 +1,81 @@ +(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) 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))) + (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). " + (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 `(json:encode-json-to-string (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)))))) diff --git a/src/util.lisp b/src/util.lisp @@ -0,0 +1,101 @@ +(in-package :cohost.util) + +(defun sym->str (sym) + (json:lisp-to-camel-case (symbol-name sym))) + +(defun strcat (&rest strings) + (apply #'concatenate (cons 'string strings))) + +(defmacro -> (init &rest forms) + (let ((accum init)) + (loop for form in forms + do (if (consp form) + (setf accum (list (car form) accum (cadr form))) + (setf accum (list form accum)))) + accum)) + +(defmacro ->> (init &rest forms) + (let ((accum init)) + (loop for form in forms + do (if (consp form) + (setf accum (append form (list accum))) + (setf accum (append (list form) (list accum))))) + accum)) + +(defun encode-json-boolean (key val) + (json:as-object-member (key) (format json:*json-output* (if val "true" "false")))) + +(defun encode-json-array (key list) + (json:as-object-member (key) + (json:with-array () + (dolist (elem list) + (json:encode-array-member elem))))) + +(defun sassoc (key alist) + (assoc key alist :test (typecase key + (string #'string=) + (t #'eql)))) + +(defun assoc-val (key alist) + (cdr (sassoc key alist))) + +;;; The function below is derived from CL-JSON:LISP-TO-CAMEL-CASE. +;;; All code from CL-JSON is MIT licensed: +;;; +;;; Copyright (c) 2006-2012 Henrik Hjelte +;;; Copyright (c) 2008 Hans Hübner (code from the program YASON) +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;; +;;; Revisions are licensed as the rest of the package, see LICENSE at the root. +(defun lisp-to-cdn-case (string) + "Take a string with Lisp-style hyphenation as generated by CL-JSON:CAMEL-CASE-TO-LISP and +convert it back to camel case as consumed by Digital Ocean. WARNING: Stupid." + (loop with i = 0 and l = (length string) + with cc-string = (make-string l) and cc-i = 0 + with init = t and cap = nil and all-caps = nil + while (< i l) + do (let ((c (aref string i))) + (unless (case c + (#\* (if init (setq cap t))) + (#\+ (cond + (all-caps (setq all-caps nil init t)) + (init (setq all-caps t)))) + (#\- (progn + (setq init t) + (cond + ((or all-caps + (and (< (1+ i) l) + (char= (aref string (1+ i)) #\-) + (incf i))) + (setf (aref cc-string cc-i) #\_) + (incf cc-i)) + (t + (setf (aref cc-string cc-i) #\-) + (incf cc-i) + (setq cap t)))))) + (setf (aref cc-string cc-i) + (if (and (or cap all-caps) (alpha-char-p c)) + (char-upcase c) + (char-downcase c))) + (incf cc-i) + (setq cap nil init nil)) + (incf i)) + finally (return (subseq cc-string 0 cc-i)))) diff --git a/tests/main.lisp b/tests/main.lisp @@ -0,0 +1,116 @@ +(defpackage cohost/tests/main + (:use :cl + :cohost + :cohost.util + :rove)) +(in-package :cohost/tests/main) + +;; NOTE: To run this test file, execute +;; (asdf:test-system :cohost) +;; in your Lisp. + +(defparameter +test-email+ "test@test") +(defparameter +test-password+ "password") +(defparameter +test-salt+ "Ms7QhEwzfpoyQmLcUue-kA") +(defparameter +test-client-hash+ "taufN1mhG3w5kD4mT/RzKlMjI8llHXmus2lK9xTw2SRYi24K3In4nXyv8YtQ17sA1NWqdXxo5yky2kYFSe9UVBgQMftTJcUpmKkDd5cFCDAUkwxIZ16M6ZNxcmFPIOMhoAjbmH4v1mS8d67ALzvFpi1/pNQvR/vbAfw/YBK1suc=") +(defparameter +test-user-id+ 1337) +(defparameter +test-batch-input+ '(("projects.listEditedProjects" . NIL) ("login.loggedIn" . NIL) ("bookmarks.tags.list" . NIL) ("users.displayPrefs" . NIL) ("posts.isLiked" . 12345))) + +(defvar *type* :unit) + +(defun http-request-mock (uri &key method parameters &allow-other-keys) + (cond + ;; login/salt + ((and (string= uri "https://cohost.org/api/v1/login/salt") + (string= (assoc-val "email" parameters) +test-email+) + (eql method :get)) + (json:encode-json-plist-to-string `(:salt ,+test-salt+))) + ;; login + ((and (string= uri "https://cohost.org/api/v1/login") + (string= (assoc-val "email" parameters) +test-email+) + (string= (assoc-val "clientHash" parameters) +test-client-hash+) + (eql method :post)) + (json:encode-json-plist-to-string `(:user-id ,+test-user-id+ :email ,+test-email+))) + ;; Failed login + ((and (string= uri "https://cohost.org/api/v1/login") + (eql method :post)) + (json:encode-json-plist-to-string `(:status 422 :message "Login Failed"))) + ;; Batch input + ((and (string= uri "https://cohost.org/api/v1/trpc/projects.listEditedProjects,login.loggedIn,bookmarks.tags.list,users.displayPrefs,posts.isLiked") + (string= (assoc-val "input" parameters) "{\"4\":12345}") + (eql (assoc-val "batch" parameters) 1) + (eql method :get)) + "{\"foo\":1}"))) + +(defmacro with-test-client ((client) &rest body) + `(let ((,client (if (eql *type* :integration) + (cohost.client:init-client :v1) + (make-instance 'cohost.client-v1-impl::cohost-client-v1 :http-request #'http-request-mock)))) + ,@body)) + +(deftest cohost-primitive-tests + (with-test-client (client) + (testing "Can get client base URI" + (ok (cohost:base-uri client))) + (testing "Can perform basic RPC call (login/salt)" + (ok (multiple-value-bind (rpc) + (cohost.rpc:cohost-rpc client "login/salt" :get :email +test-email+) + (string= (assoc-val :salt rpc) +test-salt+)))) + (testing "Can perform tRPC batch call" + (ok (multiple-value-bind (rpc) + (cohost.rpc:cohost-trpc-batch client +test-batch-input+) + rpc))))) + +(cohost.rpc:define-trpc-request "test.zeroParams" ()) +(cohost.rpc:define-trpc-request "test.atomicParam" (:atom)) +(cohost.rpc:define-trpc-request "test.structuredParams" ("firstParam" "secondParam")) + +(deftest cohost-trpc-tests + (testing "Validate tRPC function definitions" + (ok (let ((result (test.zero-params))) + (and (string= (car result) "test.zeroParams") + (null (cdr result))))) + (ok (let ((result (test.atomic-param 42))) + (and (string= (car result) "test.atomicParam") + (eq (cdr result) 42)))) + (ok (let ((result (test.structured-params "foo" "bar"))) + (and (string= (car result) "test.structuredParams") + (string= (cdr result) "{\"firstParam\":\"foo\",\"secondParam\":\"bar\"}")))))) + +(deftest cohost-api-tests + (with-test-client (client) + (testing "Can call login successfully" + (ok (cohost.client:login client +test-email+ +test-password+))) + (testing "Can fail login" + (ok (let ((response (cohost.client:login client +test-email+ "foo"))) + (and (eql (assoc-val :status response) 422) + (string= (assoc-val :message response) "Login Failed"))))))) + +(deftest cohost-high-level-tests + (with-test-client (client) + (testing "Can create new post object with no parameters" + (ok (let ((chost (cohost.client:new-post client))) + (and (null (cohost.client:adult-content chost)) + (null (cohost.client:content-blocks chost)) + (null (cohost.client:content-warnings chost)) + (null (cohost.client:headline chost)) + (null (cohost.client:tags chost)))))) + (testing "Can create new post object with a full set of parameters" + (ok (let* ((adult t) + (content-block "test") + (cw "test-cw") + (headline "test") + (tag "test-tag") + (chost (cohost.client:new-post client :adult-content adult + :blocks (list content-block) + :content-warnings (list cw) + :headline headline + :tags (list tag)))) + (and (cohost.client:adult-content chost) + (eql (length (cohost.client:content-blocks chost)) 1) + (string= (car (cohost.client:content-blocks chost)) content-block) + (eql (length (cohost.client:content-warnings chost)) 1) + (string= (car (cohost.client:content-warnings chost)) cw) + (string= (cohost.client:headline chost) headline) + (eql (length (cohost.client:tags chost)) 1) + (string= (car (cohost.client:tags chost)) tag)))))))