qkbox: toot: Update.

1 files changed, 175 insertions, 75 deletions

diff --git a/qkbox/toot.scm b/qkbox/toot.scm
index 3a8c784..6d83e92 100644
--- a/qkbox/toot.scm
+++ b/qkbox/toot.scm
@@ -25,9 +25,17 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (pict)
+  #:use-module ((sxml simple)
+                #:select (xml->sxml))
+  #:use-module ((sxml fold)
+                #:select (foldt))
+  #:use-module ((sxml xpath)
+                #:select (sxpath))
   #:export (post
             timeline
             favourite
@@ -100,16 +108,55 @@
   status?
   (json status-json))
 
+(set-record-type-printer! <status>
+  (lambda (status port)
+    (format port
+            "#<status id: ~s ...>"
+            (status-id status))))
+
+(define-record-type <account>
+  (make-account json)
+  account?
+  (json account-json))
+
+(set-record-type-printer! <account>
+  (lambda (account port)
+    (format port "#<account id: ~s acct: ~s ...>"
+            (account-id account)
+            (account-acct account))))
+
+(define (status-public? status)
+  (eq? 'public (status-visibility status)))
+
+(define* (display-status status
+                         #:key
+                         (port (current-output-port))
+                         display-cw?)
+  (let ((account (status-account status)))
+    (format port "~s ~a ~a ~s~@[ ~:@(~a~)~]~%"
+            (fetch-avatar-static (account-avatar-static account))
+            (account-display-name account)
+            (account-acct account)
+            (status-id status)
+            (if (eq? 'public (status-visibility status))
+                #f
+                (status-visibility status)))
+    (cond
+     ((status-spoiler-text status)
+      => (lambda (spoiler-text)
+           (format port "[CW]: ~a~%" spoiler-text)
+           (when display-cw?
+             (display-content (status-content status)
+                              port))))
+     (else
+      (display-content (status-content status)
+                       port)))))
+
 (define (status-id status)
   (assoc-ref (status-json status) "id"))
 
-(define (status-avatar-static status)
-  (assoc-ref (assoc-ref (status-json status) "account")
-             "avatar_static"))
-
-(define (status-acct status)
-  (assoc-ref (assoc-ref (status-json status) "account")
-             "acct"))
+(define (status-account status)
+  (make-account (assoc-ref (status-json status) "account")))
 
 (define (status-reblog status)
   (let ((reblog/json (assoc-ref (status-json status) "reblog")))
@@ -120,6 +167,35 @@
 (define (status-content status)
   (assoc-ref (status-json status) "content"))
 
+(define (content->sxml content)
+  (xml->sxml
+   (string-append
+    "<status>"
+    (regexp-substitute/global #f "<br>"
+                              content
+                              'pre "<br/>" 'post)
+    "</status>")))
+
+(define* (display-content content #:optional (port (current-output-port)))
+  (for-each (lambda (x) (display x port))
+            (flatten
+             (foldt (lambda (xs)
+                      (case (car xs)
+                        ((*TOP* span status p a) (cdr xs))
+                        ((br) #\newline)
+                        ((@ class target rel href) '())
+                        (else
+                         (format #f "~%[DEBUG] UNEXPECTED ~a~%" xs))))
+                    (lambda (obj) obj)
+                    (content->sxml content))))
+  (newline port))
+
+(define (flatten x)
+  (cond
+   ((list? x)
+    (append-map flatten x))
+   (else (list x))))
+
 (define (status-visibility status)
   (string->symbol (assoc-ref (status-json status) "visibility")))
 
@@ -135,65 +211,55 @@
         #f
         (vector->list v))))
 
+(define (account-id account)
+  (assoc-ref (account-json account) "id"))
+
+(define (account-avatar-static account)
+  (assoc-ref (account-json account) "avatar_static"))
+
+(define (account-acct account)
+  (assoc-ref (account-json account) "acct"))
+
+(define (account-display-name account)
+  (assoc-ref (account-json account) "display_name"))
+
 (define avatar-static-hash (make-hash-table))
 
-(define* (avatar-static->pict url)
+(define* (fetch-pict url #:key resize)
+  (receive (res body)
+      (http-get url)
+    (let ((tmp (tmpnam)))
+      (let ((in (open tmp (logior O_WRONLY O_CREAT O_EXCL))))
+        (put-bytevector in body)
+        (close in))
+      (let ((pict (and (zero? (apply system* "convert"
+                                     `(,@(if resize
+                                             `("-resize"
+                                               ,(format #f "~d!x~d!"
+                                                        (car resize)
+                                                        (cadr resize)))
+                                             '())
+                                       ,(string-append tmp "[0]")
+                                       ,(string-append "png:" tmp))))
+                       (pict-from-file tmp))))
+        (delete-file tmp)
+        pict))))
+
+(define* (fetch-avatar-static url)
   (cond
    ((hash-ref avatar-static-hash url) => identity)
    (else
-    (receive (res body)
-        (http-get url)
-      (let ((tmp (tmpnam)))
-        (let ((in (open tmp (logior O_WRONLY O_CREAT O_EXCL))))
-          (put-bytevector in body)
-          (close in))
-        (let ((pict (and (zero? (system* "convert" "-resize" "32!x32!"
-                                         tmp
-                                         (string-append "png:" tmp)))
-                         (pict-from-file tmp))))
-          (delete-file tmp)
-          (hash-set! avatar-static-hash url pict)
-          pict))))))
+    (let ((pict (fetch-pict url #:resize '(32 32))))
+      (hash-set! avatar-static-hash url pict)
+      pict))))
 
-(set-record-type-printer! <status>
-  (lambda (status port)
-    (cond
-     ((status-reblog status) =>
-      (lambda (reblog)
-        (format port "#<~s ~s BT: ~s>"
-                (avatar-static->pict (status-avatar-static status))
-                (status-id status)
-                reblog)))
-     (else
-      (format port
-              "#<~s ~s ~a~@[ ~:@(~a~)~] ~a>"
-              (avatar-static->pict (status-avatar-static status))
-              (status-id status)
-              (status-acct status)
-              (case (status-visibility status)
-                ((public) #f)
-                (else
-                 (status-visibility status)))
-              (cond
-               ((status-spoiler-text status) =>
-                (lambda (spoiler-text)
-                  (format #f "CW: ~s" spoiler-text)))
-               ((status-media-attachments status) =>
-                (lambda (media-attachments)
-                  (format #f "MEDIA(~a) ~s"
-                          (length media-attachments)
-                          (status-content status))))
-               (else
-                (format #f "~s"
-                        (status-content status)))))))))
-
-(define* (id->status id #:key (authorization? #t))
+(define* (status id #:key (authorization? #t))
   (define-values (res body)
     (/api/v1/statuses/:id id #:authorization? authorization?))
   (case (response-code res)
     ((200) (make-status body))
     (else
-     (error "timeline: failed" res body))))
+     (error "status: failed" res body))))
 
 (define* (/api/v1/statuses/:id id #:key (authorization? #t))
   (request
@@ -284,24 +350,58 @@
    (format #f "/api/v1/statuses/~a/unreblog" id)
    #:authorization? #t))
 
-(define* (request method path #:key json authorization?)
+(define* (raw-request method path #:key (headers '()) (body "") authorization?)
+  (receive (res body)
+      (http-request (string-append "https://"
+                                   (current-mastodon-host)
+                                   path)
+                    #:method method
+                    #:headers `(,@headers
+                                ,@(if authorization?
+                                      `((authorization
+                                         ,(string->symbol
+                                           (string-append
+                                            "Bearer "
+                                            (current-mastodon-access-token)))))
+                                      '()))
+                    #:decode-body? #f
+                    #:body body)
+    (values res body)))
+
+(define* (request method path
+                  #:key
+                  json
+                  authorization?)
+  (receive (res body)
+      (raw-request method path
+                   #:body (if json
+                              (scm->json-string json)
+                              #f)
+                   #:headers (if json
+                                 '((content-type application/json))
+                                 '())
+                   #:authorization? authorization?)
+ (if (= 200 (response-code res))
+        (values res (json-string->scm (utf8->string body)))
+        (values res body))))
+
+(define* (account id)
   (define-values (res body)
-    (http-request (string-append "https://"
-                                 (current-mastodon-host)
-                                 path)
-                  #:method method
-                  #:headers `((content-type application/json)
-                              ,@(if authorization?
-                                    `((authorization
-                                       ,(string->symbol
-                                         (string-append
-                                          "Bearer "
-                                          (current-mastodon-access-token)))))
-                                    '()))
-                  #:decode-body? #t
-                  #:body (if json
-                             (scm->json-string json)
-                             #f)))
-  (if (= 200 (response-code res))
-      (values res (json-string->scm (utf8->string body)))
-      (values res body)))
+    (/api/v1/accounts/:id id))
+  (case (response-code res)
+    ((200) (make-account body))
+    ((401)
+     (error "account: Unauthorized" id))
+    ((404)
+     (error "account: Not Found" id))
+    ((410)
+     (error "account: Account is suspended" id))
+    (else
+     (error "account: failed"
+            (response-code res)
+            (utf8->string body)))))
+
+(define* (/api/v1/accounts/:id id)
+  (request
+   'GET
+   (format #f "/api/v1/accounts/~a" id)))