qkbox: toot: Display media-attachment (only image type).

1 files changed, 51 insertions, 7 deletions

diff --git a/qkbox/toot.scm b/qkbox/toot.scm
index 025c7a7..6e00c18 100644
--- a/qkbox/toot.scm
+++ b/qkbox/toot.scm
@@ -134,6 +134,7 @@
                                 #:key
                                 (port (current-output-port))
                                 display-cw?
+                                display-sensitive?
                                 (display-id? #t))
   (let ((status (or (status-reblog status) status))
         (status/original status))
@@ -141,7 +142,7 @@
       (cond
        (else
         (format port
-                "~s ~a~@?~@?~@?~@?~@?~%~@?"
+                "~s ~a~@?~@?~@?~@?~@?~%~@?~@?"
                 (status-avatar-pict status/original)
                 (account-to-string account)
                 "~@[~%  * status-id: ~s~]"
@@ -161,7 +162,24 @@
                 (and (or (not (status-spoiler-text status))
                          display-cw?)
                      (content-filter
-                      (status-to-content-string status)))))))))
+                      (status-to-content-string status)))
+                "~{~a~%~}"
+                (map (lambda (att)
+                       (if (or (not (status-sensitive? status))
+                               display-sensitive?)
+                           (case (attachment-type att)
+                             ((image)
+                              (cond
+                               ((fetch-attachment-preview-pict att)
+                                => identity)
+                               (else
+                                "FAILED: IMAGE")))
+                             (else
+                              =>
+                              (lambda (type)
+                                (format #f "UNSUPPORTED: ~:@(~a~)" type))))
+                           (format #f "NSFW: ~:@(~a~)" (attachment-type att))))
+                     (status-media-attachments status))))))))
 
 (define (status-avatar-pict status)
   (let ((status-pict (or (fetch-avatar-static
@@ -190,6 +208,9 @@
         #f
         (make-status reblog/json))))
 
+(define-public (status-sensitive? status)
+  (assoc-ref (status-json status) "sensitive"))
+
 (define-public (status-content status)
   (assoc-ref (status-json status) "content"))
 
@@ -253,11 +274,30 @@
 (define-public (status-emojis status)
   (map make-emoji (vector->list (assoc-ref (status-json status) "emojis"))))
 
+(define-record-type <attachment>
+  (make-attachment json)
+  attachment?
+  (json attachment-json))
+
+(define (attachment-type attachment)
+  (string->symbol (assoc-ref (attachment-json attachment) "type")))
+
+(define (attachment-preview-url attachment)
+  (assoc-ref (attachment-json attachment) "preview_url"))
+
+(define (attachment-url attachment)
+  (assoc-ref (attachment-json attachment) "url"))
+
+(define (fetch-attachment-preview-pict attachment)
+  (fetch-pict (attachment-preview-url attachment)
+              #:height> 128))
+
+(define (fetch-attachment-pict attachment)
+  (fetch-pict (attachment-url attachment)))
+
 (define-public (status-media-attachments status)
   (let ((v (assoc-ref (status-json status) "media_attachments")))
-    (if (zero? (vector-length v))
-        #f
-        (vector->list v))))
+    (map make-attachment (vector->list v))))
 
 (define (status-in-reply-to-id status)
   (let ((id (assoc-ref (status-json status) "in_reply_to_id")))
@@ -335,7 +375,7 @@
 
 (define avatar-static-cache (make-hash-table))
 
-(define* (fetch-pict url #:key resize)
+(define* (fetch-pict url #:key resize height>)
   (receive (res body)
       (http-get url)
     (let ((tmp (tmpnam)))
@@ -347,9 +387,13 @@
          (let ((pict (and (zero? (apply system* "convert"
                                         `(,@(and/nil resize
                                                      `("-resize"
-                                                       ,(format #f "~d!x~d!"
+                                                       ,(format #f "~dx~d!"
                                                                 (car resize)
                                                                 (cadr resize))))
+                                          ,@(and/nil height>
+                                                     `("-resize"
+                                                       ,(format #f "x~d>"
+                                                                height>)))
                                           ,(string-append tmp "[0]")
                                           ,(string-append "png:" tmp))))
                           (pict-from-file tmp))))