client-v1-impl.lisp (11815B)
1 (in-package :cohost.client-v1-impl) 2 3 (defclass cohost-client-v1 (cohost-client) ()) 4 5 (defmethod init-client ((api-ver (eql :v1))) 6 (make-instance 'cohost-client-v1 :api-path "api/v1/" :cookie-jar (make-instance 'drakma:cookie-jar))) 7 8 (defun %salt (client email) 9 (assoc-val :salt (cohost-rpc client "login/salt" :get :email email))) 10 11 (defun %login (client email client-hash) 12 (cohost-rpc client "login" :post :email email :client-hash client-hash)) 13 14 (defun serialize-connect-token (cookie-jar) 15 (let ((cookie (find-if (lambda (cookie) (string= (drakma:cookie-name cookie) "connect.sid")) 16 (drakma:cookie-jar-cookies cookie-jar)))) 17 (format nil "~a;~a" (drakma:cookie-value cookie) (drakma:cookie-expires cookie)))) 18 19 (defun deserialize-connect-token (token) 20 (let* ((split-pos (position #\; token)) 21 (value (subseq token 0 split-pos)) 22 (expiration (parse-integer (subseq token (1+ split-pos))))) 23 (make-instance 'drakma:cookie 24 :name "connect.sid" 25 :value value 26 :expires expiration 27 :domain "cohost.org" 28 :securep t 29 :http-only-p t))) 30 31 (defmethod login ((client cohost-client-v1) email password) 32 (labels ((pad-base64 (salt) 33 (format nil "~A~v@{~A~:*~}" salt (mod (length salt) 4) #\.)) 34 (derive-client-hash (password salt) 35 (derive-key 36 (make-kdf :pbkdf2 :digest :sha384) 37 (string-to-octets password) 38 (base64-string-to-usb8-array 39 (pad-base64 salt) 40 :table base64:+uri-decode-table+) 41 200000 42 128))) 43 (let* ((salt (%salt client email)) 44 (client-hash (usb8-array-to-base64-string (derive-client-hash password salt)))) 45 (multiple-value-bind (json http-code) 46 (%login client email client-hash) 47 (when (eql http-code 200) 48 (serialize-connect-token (cookie-jar client))))))) 49 50 (defun logged-in-p (client) 51 (let ((result (assoc-val :result (car (cohost-trpc-batch client (list (login.logged-in))))))) 52 (assoc-val :logged-in (assoc-val :data result)))) 53 54 (defmethod login-with-token ((client cohost-client-v1) token) 55 (let ((cookie (deserialize-connect-token token))) 56 (setf (cookie-jar client) 57 (make-instance 'drakma:cookie-jar :cookies (list cookie))) 58 (when (logged-in-p client) 59 (serialize-connect-token (cookie-jar client))))) 60 61 (defgeneric encode-block (block) 62 (:method ((block attachment)) 63 (json:with-object () 64 (json:encode-object-member :type "attachment") 65 (json:as-object-member (:attachment) 66 (json:with-object () 67 (json:encode-object-member :alt-text (or (alt-text block) "")) 68 (json:encode-object-member :attachment-id (attachment-id block)))))) 69 (:method ((block file-attachment)) 70 (json:with-object () 71 (json:encode-object-member :type "attachment") 72 (json:as-object-member (:attachment) 73 (json:with-object () 74 (json:encode-object-member :alt-text (or (alt-text block) "")) 75 (json:encode-object-member :attachment-id "00000000-0000-0000-0000-000000000000"))))) 76 (:method ((block markdown)) 77 (json:with-object () 78 (json:encode-object-member :type "markdown") 79 (json:as-object-member (:markdown) 80 (json:with-object () 81 (json:encode-object-member :content (or (content block) ""))))))) 82 83 (defun upload-as-attachment-and-update (client project post-id block) 84 (if (typep block 'file-attachment) 85 (let* ((api-path-prefix (format nil "project/~a/posts/~a/attach" project post-id)) 86 (start (cohost-rpc client (strcat api-path-prefix "/start") :post 87 :filename (attachment-filename block) 88 :content_type (attachment-content-type block) 89 :content_length (filesize (attachment-pathname block)))) 90 (attachment-id (assoc-val :attachment-id start))) 91 (when attachment-id 92 (let* ((cdn-url (assoc-val :url start)) 93 (required-fields (assoc-val :required-fields start)) 94 ;; This is really weird, using this clunky APPEND instead of the nicer ACONS, but 95 ;; digitalocean barfs if the file field doesn't appear at the end of input, 96 ;; after the required fields! 97 (form-fields-raw (append required-fields 98 (list (list :file 99 (attachment-pathname block) 100 :content-type (attachment-content-type block) 101 :filename (attachment-filename block))))) 102 (form-fields (loop for pair in form-fields-raw 103 while pair 104 collect (cons (lisp-to-cdn-case (symbol-name (car pair))) (cdr pair))))) 105 106 ;; Sort of breaking abstraction here, we should have a general method for CDN uploads 107 (multiple-value-bind (content http-code) 108 (funcall (http-request client) cdn-url :method :post 109 :parameters form-fields 110 :user-agent cohost.rpc::+user-agent+ 111 :content-length t) 112 (declare (ignore content)) 113 (if (eql http-code 204) 114 (let* ((finish (cohost-rpc client (strcat api-path-prefix "/finish/" attachment-id) :post)) 115 (attachment-id (assoc-val :attachment-id finish))) 116 (if finish 117 (new-attachment client attachment-id :alt-text (alt-text block)) 118 block)) 119 block))))) 120 block)) 121 122 (defun post->json (post-obj) 123 (with-output-to-string (json:*json-output*) 124 (json:with-object () 125 (json:encode-object-member :post-state (if (draft post-obj) 0 1)) 126 (encode-json-boolean :adult-content (adult-content post-obj)) 127 (json:encode-object-member :headline (or (headline post-obj) "")) 128 (when (share-of post-obj) 129 (json:encode-object-member :share-of-post-id (share-of post-obj))) 130 (encode-json-array :cws (content-warnings post-obj)) 131 (encode-json-array :tags (tags post-obj)) 132 (json:as-object-member (:blocks) 133 (json:with-array () 134 (dolist (block (content-blocks post-obj)) 135 (json:as-array-member () 136 (encode-block block)))))))) 137 138 (defun %post (client post-obj) 139 (cohost-json-rpc client 140 (format nil "project/~a/posts" (project post-obj)) 141 (post->json post-obj))) 142 143 (defun %update (client post-obj) 144 (cohost-json-rpc client 145 (format nil "project/~a/posts/~a" (project post-obj) (post-id post-obj)) 146 (post->json post-obj) 147 :method :put)) 148 149 (defmethod post ((client cohost-client-v1) post-obj) 150 (let* ((project (project post-obj)) 151 (old-post-id (post-id post-obj)) 152 (post-response (if old-post-id 153 (%update client post-obj) 154 (%post client post-obj))) 155 (post-id (assoc-val :post-id post-response)) 156 (attachmentsp (find-if (lambda (block) (typep block 'file-attachment)) (content-blocks post-obj)))) 157 (cond 158 ((and post-id attachmentsp) 159 (let ((new-post (copy-post client post-obj))) 160 (setf (post-id new-post) post-id) 161 (setf (content-blocks new-post) 162 (loop for block in (content-blocks post-obj) 163 collect (upload-as-attachment-and-update client project post-id block))) 164 ;; Just fire and forget for now 165 (%update client new-post) 166 new-post)) 167 (post-id 168 (let ((new-post (copy-post client post-obj))) 169 (setf (post-id new-post) post-id) 170 new-post)) 171 (t (values post-obj post-response))))) 172 173 (defun json->block (client block-json) 174 (case (make-keyword (assoc-val :type block-json)) 175 (:attachment (new-attachment client (assoc-val :attachment-id block-json) 176 :alt-text (assoc-val :alt-text block-json))) 177 (:markdown (new-markdown-block client 178 (assoc-val :content (assoc-val :markdown block-json)))))) 179 180 (defun json->post (client post-json) 181 (new-post client (assoc-val :handle (assoc-val :posting-project post-json)) 182 :share-of (assoc-val :share-of-post-id post-json) 183 :tags (assoc-val :tags post-json) 184 :headline (assoc-val :headline post-json) 185 :content-warnings (assoc-val :cws post-json) 186 :adult-content (assoc-val :effective-adult-content post-json) 187 :draft (eql (assoc-val :state post-json) 0) 188 :id (assoc-val :post-id post-json) 189 :blocks (loop for block in (assoc-val :blocks post-json) 190 collect (json->block client block)))) 191 192 (defmethod get-post ((client cohost-client-v1) post-id) 193 (let* ((post-response (cohost-rpc client (format nil "/project_post/~a" post-id) :get)) 194 (post-id (assoc-val :post-id post-response)) 195 (links (when post-id (assoc-val :--links post-response))) 196 (project-link (find-if (lambda (alist) (string= (cdr (assoc :rel alist)) "project")) 197 links)) 198 (project-href (assoc-val :href project-link)) 199 ;; Just chop off "/api/v1/project/". Sloppy! 200 (project (when project-href (subseq project-href 16))) 201 (full-post-response (when (and post-id project) (cohost-trpc-batch client (list (posts.single-post project post-id)))))) 202 (when full-post-response 203 (json->post client (assoc-val :post (assoc-val :data (assoc-val :result (car full-post-response)))))))) 204 205 ;;; FIXME: This is awful! We scrape the loaded JSON off the front page, which also means 206 ;;; loading 60-some k of HTML. This needs to be replaced with something less shit ass as 207 ;;; soon as we have a better way. My apologies for all of this. 208 (defmethod get-dash ((client cohost-client-v1)) 209 (let* ((content (funcall (http-request client) 210 (base-uri client) 211 :cookie-jar (cookie-jar client))) 212 (base-dom (plump:parse content)) 213 (json-entity (plump:get-element-by-id base-dom "__COHOST_LOADER_STATE__"))) 214 ;; Only try to parse out the posts if we actually got the expected result 215 (when (and (plump:fulltext-element-p json-entity) 216 (string= (string-downcase (plump:tag-name json-entity)) "script")) 217 (let ((dash-json (json:decode-json-from-string (plump:text json-entity)))) 218 (loop for post in (assoc-val :posts (assoc-val :dashboard dash-json)) 219 collect (json->post client post)))))) 220 221 ;;; Event stream methods 222 (defmethod open-event-stream ((client cohost-client-v1)) 223 (funcall (http-request client) 224 (concatenate 'string (base-uri client) "rc/dashboard/event-stream") 225 :cookie-jar (cookie-jar client) :accept "text/event-stream" :want-stream t)) 226 227 ;;; tRPC primitive queries 228 (define-trpc-request "projects.listEditedProjects" ()) 229 (define-trpc-request "projects.followingState" ("projectHandle")) 230 (define-trpc-request "login.loggedIn" ()) 231 (define-trpc-request "bookmarks.tags.list" ()) 232 (define-trpc-request "users.displayPrefs" ()) 233 (define-trpc-request "posts.isLiked" (:atom)) 234 (define-trpc-request "posts.singlePost" ("handle" "postId")) 235 (define-trpc-request "posts.profilePosts" ("projectHandle" "page" "options")) 236 (define-trpc-request "posts.getPostsTagged" ("projectHandle" "tagSlug")) 237 (define-trpc-request "posts.byProject" ("projectHandle" "page"))