summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--qkbox/toot.scm58
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))))