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:
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
