qkbox: toot: Update post procedure.

1 files changed, 78 insertions, 11 deletions

diff --git a/qkbox/toot.scm b/qkbox/toot.scm
index 94de0ad..d52314d 100644
--- a/qkbox/toot.scm
+++ b/qkbox/toot.scm
@@ -1,15 +1,82 @@
 (define-module (qkbox toot)
   #:use-module (ice-9 format)
+  #:use-module (web response)
+  #:use-module (web client)
+  #:use-module (json builder)
+  #:use-module (json parser)
+  #:use-module (rnrs bytevectors)
   #:export (post))
 
-(define* (post x #:key spoiler-text)
-  (apply system*
-         "toot"
-         "post"
-         (cond
-          ((string? x) x)
-          (else
-           (format #f "~y" x)))
-         `(,@(if spoiler-text
-                 `("-p" ,spoiler-text)
-                 '()))))
+(define current-mastodon-host
+  (make-parameter (getenv "MASTODON_HOST")))
+
+(define current-mastodon-access-token
+  (make-parameter (getenv "MASTODON_ACCESS_TOKEN")))
+
+(define* (post status
+               #:key
+               spoiler-text
+               visibility
+               sensitive
+               reply-to)
+  (define-values (res body)
+    (/api/v1/statuses #:status status
+                      #:spoiler-text spoiler-text
+                      #:visibility visibility
+                      #:sensitive sensitive
+                      #:reply-to reply-to))
+  (case (response-code res)
+    ((200)
+     (assoc-ref body "id"))
+    (else
+     (error "post: failed" res body))))
+
+(define* (/api/v1/statuses #:key
+                           status
+                           spoiler-text
+                           visibility
+                           sensitive
+                           reply-to
+                           media-ids)
+  (post-json
+   "/api/v1/statuses"
+   `(,@(if status
+           `(status . ,(if (string? status)
+                           status
+                           (format #f "~y" status)))
+           '())
+     ,@(if spoiler-text
+           `((spoiler_text . ,spoiler-text))
+           '())
+     ,@(if visibility
+           (case visibility
+             ((public unlisted private direct)
+              `((visibility . ,visibility)))
+             (else
+              (error "post: invalid visibility (must be one of: public unlisted private direct)")))
+           '())
+     ,@(if sensitive `((sensitive . (if sensitive #t #f)))
+           '())
+     ,@(if reply-to
+           `((in_reply_to_id . ,reply-to))
+           '())
+     ,@(if media-ids
+           `((media_ids . ,(list->vector (map number->string media-ids))))
+           '()))))
+
+(define (post-json path json)
+  (define-values (res body)
+    (http-post (string-append "https://"
+                              (current-mastodon-host)
+                              path)
+               #:headers `((content-type application/json)
+                           (authorization
+                            ,(string->symbol
+                              (string-append
+                               "Bearer "
+                               (current-mastodon-access-token)))))
+               #:decode-body? #t
+               #:body (scm->json-string json)))
+  (if (= 200 (response-code res))
+      (values res (json-string->scm (utf8->string body)))
+      (values res body)))