diff options
| -rw-r--r-- | qkbox/toot.scm | 284 |
1 files changed, 223 insertions, 61 deletions
diff --git a/qkbox/toot.scm b/qkbox/toot.scm index bb44a72..025c7a7 100644 --- a/qkbox/toot.scm +++ b/qkbox/toot.scm @@ -31,8 +31,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (pict) - #:use-module ((sxml simple) - #:select (xml->sxml)) + #:use-module ((htmlprag) + #:select (html->sxml)) #:use-module ((sxml fold) #:select (foldt)) #:use-module ((sxml xpath) @@ -123,29 +123,60 @@ (define-public (status-public? status) (eq? 'public (status-visibility status))) +(define (account-to-string account) + (format #f "~{~a~} <~a> (account-id: ~s)" + (insert-emoji-picts (account-emojis account) + (content-filter (account-display-name account))) + (account-acct account) + (account-id account))) + (define*-public (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))) + display-cw? + (display-id? #t)) + (let ((status (or (status-reblog status) status)) + (status/original status)) + (let ((account (status-account status))) + (cond + (else + (format port + "~s ~a~@?~@?~@?~@?~@?~%~@?" + (status-avatar-pict status/original) + (account-to-string account) + "~@[~% * status-id: ~s~]" + (and display-id? (status-id status/original)) + "~@[~% * visibility: ~:@(~a~)~]" + (and (not (status-public? status)) + (status-visibility status)) + "~@[~% * boosted-by: ~a~]" + (and (status-reblog status/original) + (account-to-string + (status-account status/original))) + "~@[~% * in-reply-to-id: ~s~]" + (status-in-reply-to-id status) + "~@[~% * content-warning: ~a~]" + (status-spoiler-text status) + "~@[~a~%~]" + (and (or (not (status-spoiler-text status)) + display-cw?) + (content-filter + (status-to-content-string status))))))))) + +(define (status-avatar-pict status) + (let ((status-pict (or (fetch-avatar-static + (account-avatar-static + (status-account status))) + no-image))) (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))))) + ((status-reblog status) + => + (lambda (reblog) + (let ((reblog-pict (status-avatar-pict reblog))) + (rb-superimpose + (lt-superimpose (ghost reblog-pict) (scale reblog-pict 0.8)) + (scale status-pict 0.5))))) + (else status-pict)))) (define-public (status-id status) (assoc-ref (status-json status) "id")) @@ -162,28 +193,36 @@ (define-public (status-content status) (assoc-ref (status-json status) "content")) +(define (content-filter x) + (string-delete (char-set #\x202d #\x202e) x)) + (define (content->sxml content) - (xml->sxml - (string-append - "<status>" - (regexp-substitute/global #f "<br>" - content - 'pre "<br/>" 'post) - "</status>"))) - -(define*-public (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)) + (html->sxml content)) + +(define (status-to-content-string status) + (let ((content (status-content status)) + (emojis (status-emojis status))) + (call-with-output-string + (lambda (port) + (for-each (lambda (x) (display x port)) + (append-map + (lambda (x) (insert-emoji-picts emojis x)) + (flatten + (foldt (lambda (xs) + (define (unexpected) + (format #f "~%[DEBUG] UNEXPECTED ~s~%" xs)) + (case (car xs) + ((*TOP* span status p a) (cdr xs)) + ((br) #\newline) + ((@ class target rel href) '()) + ((*ENTITY*) + (if (equal? '(*ENTITY* "additional" "nbsp") xs) + " " + (unexpected))) + (else (unexpected)))) + (lambda (obj) obj) + (content->sxml content))))) + (get-output-string port))))) (define (flatten x) (cond @@ -200,12 +239,85 @@ #f s))) +(define-record-type <emoji> + (make-emoji json) + emoji? + (json emoji-json)) + +(define (emojis->regexp emojis) + (string-append ":(" + (string-join (map (compose regexp-quote emoji-shortcode) emojis) + "|") + "):")) + +(define-public (status-emojis status) + (map make-emoji (vector->list (assoc-ref (status-json status) "emojis")))) + (define-public (status-media-attachments status) (let ((v (assoc-ref (status-json status) "media_attachments"))) (if (zero? (vector-length v)) #f (vector->list v)))) +(define (status-in-reply-to-id status) + (let ((id (assoc-ref (status-json status) "in_reply_to_id"))) + (if (eq? 'null id) + #f + id))) + +(define (status-in-reply-to-account-id status) + (let ((id (assoc-ref (status-json status) "in_reply_to_account_id"))) + (if (eq? 'null id) + #f + id))) + +(define (emoji-static-url emoji) + (assoc-ref (emoji-json emoji) "static_url")) + +(define (emoji-shortcode emoji) + (assoc-ref (emoji-json emoji) "shortcode")) + +(define (emoji-visible-in-picker? emoji) + (assoc-ref (emoji-json emoji) "visible_in_picker")) + +(define emoji-cache (make-hash-table)) + +(define (fetch-emoji-pict emoji) + (let ((url (emoji-static-url emoji))) + (cond + ((hash-ref emoji-cache url) => identity) + ((fetch-pict (emoji-static-url emoji) + #:resize '(24 24)) + => + (lambda (pict) + (hash-set! emoji-cache url pict) + pict)) + (else #f)))) + +(define (insert-emoji-picts emojis x) + (let ((r (emojis->regexp emojis))) + (if (string? x) + (let loop ((s x)) + (cond ((string-match r s) + => + (lambda (mat) + (let ((shortcode (match:substring mat 1))) + (cons* (match:prefix mat) + (cond + ((emojis-ref emojis shortcode) + => + (lambda (emoji) + (or (fetch-emoji-pict emoji) + shortcode)))) + (loop (match:suffix mat)))))) + (else + (list s)))) + (list x)))) + +(define (emojis-ref emojis shortcode) + (find (lambda (emoji) (equal? shortcode (emoji-shortcode emoji))) + emojis)) + (define-public (account-id account) (assoc-ref (account-json account) "id")) @@ -218,7 +330,10 @@ (define-public (account-display-name account) (assoc-ref (account-json account) "display_name")) -(define avatar-static-hash (make-hash-table)) +(define-public (account-emojis account) + (map make-emoji (vector->list (assoc-ref (account-json account) "emojis")))) + +(define avatar-static-cache (make-hash-table)) (define* (fetch-pict url #:key resize) (receive (res body) @@ -227,25 +342,43 @@ (let ((in (open tmp (logior O_WRONLY O_CREAT O_EXCL)))) (put-bytevector in body) (close in)) - (let ((pict (and (zero? (apply system* "convert" - `(,@(and/nil 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)))) + (case (response-code res) + ((200) + (let ((pict (and (zero? (apply system* "convert" + `(,@(and/nil 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)) + (else + (display (response-code res)) + (newline) + #f))))) (define* (fetch-avatar-static url) (cond - ((hash-ref avatar-static-hash url) => identity) + ((hash-ref avatar-static-cache url) => identity) (else - (let ((pict (fetch-pict url #:resize '(32 32)))) - (hash-set! avatar-static-hash url pict) - pict)))) + (cond + ((fetch-pict url #:resize '(32 32)) + => + (lambda (pict) + (hash-set! avatar-static-cache url pict) + pict)) + (else #f))))) + +(define no-image + (cc-superimpose + (filled-rectangle 32 32 + #:color "white" + #:border-width 0) + (line 0 0 32 32 #:color "red") + (line 0 32 32 0 #:color "red"))) (define*-public (fetch-status id #:key (authorization? #t)) (receive (res body) @@ -261,7 +394,7 @@ (format #f "/api/v1/statuses/~a" id) #:authorization? authorization?)) -(define*-public (fetch-timeline #:key max-id since-id min-id limit local?) +(define*-public (fetch-home-timeline #:key max-id since-id min-id limit local?) (receive (res body) (/api/v1/timelines/home #:max-id max-id #:since-id since-id @@ -272,9 +405,24 @@ ((200) (map make-status (vector->list body))) ((206) - (error "fetch-timeline: Home feed is regenerating")) + (error "fetch-home-timeline: Home feed is regenerating")) + (else + (error "fetch-home-timeline: failed" res body))))) + +(define*-public (fetch-public-timeline #:key max-id since-id min-id limit local? remote? only-media?) + (receive (res body) + (/api/v1/timelines/public #:max-id max-id + #:since-id since-id + #:min-id min-id + #:limit limit + #:local? local? + #:remote? remote? + #:only-media? only-media?) + (case (response-code res) + ((200) + (map make-status (vector->list body))) (else - (error "fetch-timeline: failed" res body))))) + (error "fetch-public-timeline: failed" res body))))) (define* (/api/v1/timelines/home #:key max-id since-id min-id limit local?) (request @@ -288,6 +436,20 @@ ,@(and/nil local? `((local . ,local?)))) #:authorization? #t)) +(define* (/api/v1/timelines/public #:key max-id since-id min-id limit local? remote? only-media?) + (request + 'GET + "/api/v1/timelines/public" + #:json + `(,@(and/nil max-id `((max_id . ,max-id))) + ,@(and/nil since-id `((since_id . ,since-id))) + ,@(and/nil min-id `((min_id . ,min-id))) + ,@(and/nil limit `((limit . ,limit))) + ,@(and/nil local? `((local . ,local?))) + ,@(and/nil remote? `((remote . ,remote?))) + ,@(and/nil only-media? `((only_media . ,only-media?)))) + #:authorization? #t)) + (define-public (favourite id) (define-values (res body) (/api/v1/statuses/:id/favourite id)) |