cohost

Unofficial Common Lisp client library for Cohost
git clone https://todayiwilllaunchmyinfantsonintoorbit.com/cohost.git
Log | Files | Refs | LICENSE

commit 8b8d6cd20634208b9a466306110f77509805c2b3
parent 8560c6f5c603abbabe5ebe469fdf157760ca611b
Author: Decay <decay@todayiwilllaunchmyinfantsonintoorbit.com>
Date:   Mon,  6 Feb 2023 21:40:21 -0800

Implement major getters (get-post, get-dash, event-stream functionality)

A lot of this is highly unfinished; we're still slopping around parsed JSON
instead of structured CLOS objects.

Diffstat:
Mcohost.asd | 2+-
Msrc/client-v1-impl.lisp | 38++++++++++++++++++++++++++++++++++++--
Msrc/client.lisp | 46++++++++++++++++++++++++++++++++++++++++++++--
Msrc/packages.lisp | 13+++++++------
Msrc/rpc.lisp | 2+-
5 files changed, 89 insertions(+), 12 deletions(-)

diff --git a/cohost.asd b/cohost.asd @@ -2,7 +2,7 @@ :version "0.1.0" :author "Decay" :license "Strongest Public License" - :depends-on ("drakma" "cl-json" "cl-base64" "babel" "ironclad" "trivial-mimes") + :depends-on ("drakma" "plump" "cl-json" "cl-base64" "babel" "ironclad" "trivial-mimes" "bordeaux-threads") :components ((:module "src" :components ((:file "packages") diff --git a/src/client-v1-impl.lisp b/src/client-v1-impl.lisp @@ -3,7 +3,7 @@ (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))) + (make-instance 'cohost-client-v1 :api-path "api/v1/" :cookie-jar (make-instance 'drakma:cookie-jar))) (defun %salt (client email) (assoc-val :salt (cohost-rpc client "login/salt" :get :email email))) @@ -139,6 +139,40 @@ new-post)) (t (values post-obj post-response))))) +(defmethod get-post ((client cohost-client-v1) post-id) + (let* ((post-response (cohost-rpc client (format nil "/project_post/~a" post-id) :get)) + (post-id (assoc-val :post-id post-response)) + (links (when post-id (assoc-val :--links post-response))) + (project-link (find-if (lambda (alist) (string= (cdr (assoc :rel alist)) "project")) + links)) + (project-href (assoc-val :href project-link)) + ;; Just chop off "/api/v1/project/". Sloppy! + (project (when project-href (subseq project-href 16))) + (full-post-response (when (and post-id project) (cohost-trpc-batch client (list (posts.single-post project post-id)))))) + (when full-post-response + full-post-response))) + +;;; FIXME: This is awful! We scrape the loaded JSON off the front page, which also means +;;; loading 60-some k of HTML. This needs to be replaced with something less shit ass as +;;; soon as we have a better way. My apologies for all of this. +(defmethod get-dash ((client cohost-client-v1)) + (let* ((content (funcall (http-request client) + (base-uri client) + :cookie-jar (cookie-jar client))) + (base-dom (plump:parse content)) + (json-entity (plump:get-element-by-id base-dom "__COHOST_LOADER_STATE__"))) + ;; Only try to parse out the posts if we actually got the expected result + (when (and (plump:fulltext-element-p json-entity) + (string= (string-downcase (plump:tag-name json-entity)) "script")) + (json:decode-json-from-string (plump:text json-entity))))) + +;;; Event stream methods + +(defmethod open-event-stream ((client cohost-client-v1)) + (funcall (http-request client) + (concatenate 'string (base-uri client) "rc/dashboard/event-stream") + :cookie-jar (cookie-jar client) :accept "text/event-stream" :want-stream t)) + ;;; tRPC primitive queries (define-trpc-request "projects.listEditedProjects" ()) @@ -147,7 +181,7 @@ (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.singlePost" ("handle" "postId")) (define-trpc-request "posts.profilePosts" ("projectHandle" "page" "options")) (define-trpc-request "posts.getPostsTagged" ("projectHandle" "tagSlug")) (define-trpc-request "posts.byProject" ("projectHandle" "page")) diff --git a/src/client.lisp b/src/client.lisp @@ -7,12 +7,21 @@ :accessor http-request) (base-uri :initarg :base-uri - :initform "https://cohost.org/api/v1/" + :initform "https://cohost.org/" :accessor base-uri) + (api-path + :initarg :api-path + :accessor api-path) (cookie-jar :initarg :cookie-jar :initform nil - :accessor cookie-jar))) + :accessor cookie-jar) + (event-thread + :initform nil + :accessor %event-thread) + (end-event-thread + :initform nil + :accessor %end-event-thread))) (defclass chost () ((id @@ -166,3 +175,36 @@ :blocks (list (new-markdown-block client markdown)) :content-warnings content-warnings :tags tags))) + +(defgeneric get-post (client post-id) + (:documentation "Fetch POST-ID as a fully populated post object.")) + +(defgeneric get-dash (client) + (:documentation "Get the most recent posts from the user's dashboard.")) + +(defgeneric open-event-stream (client) + (:documentation "Open the dashboard event stream")) + +(defun attach-event-listener (client listener) + "Attach LISTENER to process events on the event stream. This starts a background thread that invokes LISTENER on each new event." + (setf (%end-event-thread client) nil) + (setf (%event-thread client) + (bt:make-thread + (lambda () + (let ((event-stream (open-event-stream client))) + (unwind-protect + (loop while (not (%end-event-thread client)) + for line = (string-trim '(#\Space #\Newline #\Linefeed) (read-line event-stream nil :eof)) + while (not (or (eql line :eof) (string= line ""))) + do (funcall listener line)) ; FIXME: parse the JSON here + (when (streamp event-stream) + (close event-stream))))) + :name "Cohost event listener thread"))) + +(defun detach-event-listener (client) + "Detach the current event listener and kill the listener thread." + (when (and (%event-thread client) (bt:threadp (%event-thread client)) (bt:thread-alive-p (%event-thread client))) + (setf (%end-event-thread client) t) + (bt:join-thread (%event-thread client))) + (setf (%end-event-thread client) nil) + (setf (%event-thread client) nil)) diff --git a/src/packages.lisp b/src/packages.lisp @@ -9,25 +9,26 @@ (defpackage cohost.client (:use :cl :cohost.util) - (:export #:cohost-client #:init-client #:base-uri #:login #:http-request #:cookie-jar + (:export #:cohost-client #:init-client #:base-uri #:api-path #: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 + #:filename #:content-type #:content #:copy-post #:clone-block #:get-post #:get-dash + #:attachment-pathname #:attachment-filename #:attachment-content-type #:new-markdown-block #:new-attachment #:new-file-attachment - #:project #:draft #:share-of #:post #:simple-post #:post-id)) + #:project #:draft #:share-of #:post #:simple-post #:post-id + #:%event-stream #:open-event-stream)) (defpackage cohost.rpc (:use :cl) (:import-from :cohost.util #:sym->str) - (:import-from :cohost.client #:base-uri #:http-request #:cookie-jar) + (:import-from :cohost.client #:base-uri #:api-path #: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 :cohost.rpc #:cohost-rpc #:cohost-json-rpc #:cohost-trpc-batch #: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)) diff --git a/src/rpc.lisp b/src/rpc.lisp @@ -5,7 +5,7 @@ (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))) + (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