From c50929cc93774a2d1a7c7e567cbb47cb586881bc Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Fri, 10 Jul 2020 10:18:51 +0900 Subject: qkbox: toot: Update. --- qkbox/toot.scm | 250 ++++++++++++++++++++++++++++++++++++++++----------------- 1 file 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! + (lambda (status port) + (format port + "#" + (status-id status)))) + +(define-record-type + (make-account json) + account? + (json account-json)) + +(set-record-type-printer! + (lambda (account port) + (format port "#" + (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 + "" + (regexp-substitute/global #f "
" + content + 'pre "
" 'post) + ""))) + +(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! - (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))) -- cgit v1.2.3