diff options
| -rw-r--r-- | qkbox/toot.scm | 58 |
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)))) |