diff options
Diffstat (limited to 'toot.scm')
| -rw-r--r-- | toot.scm | 882 |
1 files changed, 882 insertions, 0 deletions
diff --git a/toot.scm b/toot.scm new file mode 100644 index 0000000..a752c40 --- /dev/null +++ b/toot.scm @@ -0,0 +1,882 @@ +;;; Toot --- Mastodon client. +;;; Copyright © 2020 Masaya Tojo <masaya@tojo.tokyo> +;;; +;;; This file is part of Toot. +;;; +;;; Toot is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Toot is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Toot. If not, see <http://www.gnu.org/licenses/>. + +(define-module (toot) + #:use-module (ice-9 format) + #:use-module (web response) + #:use-module (web client) + #:use-module (json builder) + #:use-module (json parser) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + #:use-module (ice-9 optargs) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-9 gnu) + #:use-module (pict) + #:use-module ((htmlprag) + #:select (html->sxml)) + #:use-module ((sxml fold) + #:select (foldt)) + #:use-module ((sxml xpath) + #:select (sxpath)) + #:use-module (rnrs io ports) + #:export (;; config + current-mastodon-host + current-mastodon-access-token + + ;; get + fetch-status + fetch-account + fetch-home-timeline + fetch-public-timeline + + ;; post + post + favourite + unfavourite + reblog + unreblog + + ;; streaming + streaming-user + streaming-public + + ;; status + status? + status-id + status-emojis + status-reblog + status-account + status-content + status-public? + status-sensitive? + status-visibility + status-spoiler-text + status-creation-time + status-in-reply-to-id + status-in-reply-to-account-id + display-status + + ;; notification + notification? + notification-id + notification-type + notification-status + notification-account + notification-creation-time + display-notification + + ;; emoji + emoji? + emoji-shortcode + emoji-static-url + emoji-visible-in-picker? + + ;; account + account? + account-id + account-acct + account-emojis + account-display-name + account-avatar-static + )) + +(define-syntax-rule (and/nil test expr) + (if test + expr + '())) + +(define current-mastodon-host + (make-parameter (getenv "MASTODON_HOST"))) + +(define current-mastodon-access-token + (make-parameter (getenv "MASTODON_ACCESS_TOKEN"))) + +(define (created-at-string->date str) + (time-utc->date + (date->time-utc + (string->date str "~Y-~m-~dT~H:~M:~S.~N~z")))) + +(define (creation-time->string date) + (date->string date "~4")) + +(define* (post text + #:key + spoiler-text + visibility + sensitive? + reply-to) + (receive (res body) + (post-/api/v1/statuses #:status text + #:spoiler-text spoiler-text + #:visibility visibility + #:sensitive? sensitive? + #:reply-to reply-to) + (case (response-code res) + ((200) + (assoc-ref body "id")) + (else + (error "post: failed" res body))))) + +(define* (post-/api/v1/statuses #:key + status + spoiler-text + visibility + sensitive? + reply-to + media-ids) + (request + 'POST + "/api/v1/statuses" + #:json + `(,@(and/nil status + `((status . ,(if (string? status) + status + (format #f "~y" status))))) + ,@(and/nil spoiler-text + `((spoiler_text . ,spoiler-text))) + ,@(and/nil visibility + (case visibility + ((public unlisted private direct) + `((visibility . ,visibility))) + (else + (error "post: invalid visibility (must be one of: public unlisted private direct)")))) + ,@(and/nil sensitive? + `((sensitive . (if sensitive? #t #f)))) + ,@(and/nil reply-to + `((in_reply_to_id . ,reply-to))) + ,@(and/nil media-ids + `((media_ids . ,(list->vector (map number->string media-ids)))))) + #:authorization? #t)) + +(define-record-type <status> + (make-status json) + status? + (json status-json)) + +(set-record-type-printer! <status> + (lambda (status port) + (format port + "#<status id: ~s ...>" + (status-id status)))) + +(define-record-type <account> + (make-account json) + account? + (json account-json)) + +(set-record-type-printer! <account> + (lambda (account port) + (format port "#<account id: ~s acct: ~s ...>" + (account-id account) + (account-acct account)))) + +(define-record-type <notification> + (make-notification json) + notification? + (json notification-json)) + +(define (notification-id notification) + (assoc-ref (notification-json notification) + "id")) + +(define (notification-status notification) + (make-status + (assoc-ref (notification-json notification) + "status"))) + +(define (notification-account notification) + (make-account + (assoc-ref (notification-json notification) + "account"))) + +(define (notification-type notification) + (string->symbol + (assoc-ref (notification-json notification) + "type"))) + +(define (notification-creation-time notification) + (created-at-string->date + (assoc-ref (notification-json notification) + "created_at"))) + +(define* (display-notification notification #:key (port (current-output-port))) + (let ((account (notification-account notification)) + (status (notification-status notification)) + (time (notification-creation-time notification))) + (format port + "[NOTIFICATION] ~:@(~a~)~%~a ~a ~a~%> " + (notification-type notification) + (fetch-avatar-static + (account-avatar-static account)) + (account-to-string account) + (creation-time->string time)) + (display-status (notification-status notification)))) + +(define (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) + (sanitize (account-display-name account))) + (account-acct account) + (account-id account))) + +(define* (display-status status + #:key + (port (current-output-port)) + display-cw? + display-sensitive? + (display-id? #t)) + (let ((status (or (status-reblog status) status)) + (status/original status)) + (let ((account (status-account status))) + (cond + (else + (format port + "~s ~a ~a~@?~@?~@?~@?~@?~%~@?~@?" + (status-avatar-pict status/original) + (account-to-string account) + (creation-time->string + (status-creation-time status/original)) + "~@[~% * 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?) + (sanitize + (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 + (account-avatar-static + (status-account status))) + no-image))) + (cond + ((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 (status-id status) + (assoc-ref (status-json status) "id")) + +(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"))) + (if (eq? reblog/json 'null) + #f + (make-status reblog/json)))) + +(define (status-sensitive? status) + (assoc-ref (status-json status) "sensitive")) + +(define (status-content status) + (assoc-ref (status-json status) "content")) + +(define (sanitize x) + (string-delete (char-set #\x202d #\x202e) x)) + +(define (content->sxml content) + (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 + ((list? x) + (append-map flatten x)) + (else (list x)))) + +(define (status-visibility status) + (string->symbol (assoc-ref (status-json status) "visibility"))) + +(define (status-spoiler-text status) + (let ((s (assoc-ref (status-json status) "spoiler_text"))) + (if (zero? (string-length s)) + #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 (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 (status-media-attachments status) + (let ((v (assoc-ref (status-json status) "media_attachments"))) + (map make-attachment (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 (status-creation-time status) + (created-at-string->date (assoc-ref (status-json status) + "created_at"))) + +(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 (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 (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 height>) + (receive (res body) + (http-get url) + (case (response-code res) + ((200) + (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" + `(,@(and/nil resize + `("-resize" + ,(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)))) + (delete-file tmp) + pict))) + (else #f)))) + +(define* (fetch-avatar-static url) + (cond + ((hash-ref avatar-static-cache url) => identity) + (else + (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* (fetch-status id #:key (authorization? #t)) + (receive (res body) + (get-/api/v1/statuses/:id id #:authorization? authorization?) + (case (response-code res) + ((200) (make-status body)) + (else + (error "fetch-status: failed" res body))))) + +(define* (get-/api/v1/statuses/:id id #:key (authorization? #t)) + (request + 'GET + (format #f "/api/v1/statuses/~a" id) + #:authorization? authorization?)) + +(define* (fetch-home-timeline #:key max-id since-id min-id limit local?) + (receive (res body) + (get-/api/v1/timelines/home #:max-id max-id + #:since-id since-id + #:min-id min-id + #:limit limit + #:local? local?) + (case (response-code res) + ((200) + (map make-status (vector->list body))) + ((206) + (error "fetch-home-timeline: Home feed is regenerating")) + (else + (error "fetch-home-timeline: failed" res body))))) + +(define* (fetch-public-timeline #:key max-id since-id min-id limit local? remote? only-media?) + (receive (res body) + (get-/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-public-timeline: failed" res body))))) + +(define* (get-/api/v1/timelines/home #:key max-id since-id min-id limit local?) + (request + 'GET + "/api/v1/timelines/home" + #: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?)))) + #:authorization? #t)) + +(define* (get-/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 (favourite id) + (define-values (res body) + (post-/api/v1/statuses/:id/favourite id)) + (case (response-code res) + ((200) #t) + (else + (error "favourite: failed" res body)))) + +(define (post-/api/v1/statuses/:id/favourite id) + (request + 'POST + (format #f "/api/v1/statuses/~a/favourite" id) + #:authorization? #t)) + +(define (unfavourite id) + (define-values (res body) + (post-/api/v1/statuses/:id/unfavourite id)) + (case (response-code res) + ((200) #t) + (else + (error "unfavourite: failed" res body)))) + +(define (post-/api/v1/statuses/:id/unfavourite id) + (request + 'POST + (format #f "/api/v1/statuses/~a/unfavourite" id) + #:authorization? #t)) + +(define (reblog id) + (define-values (res body) + (post-/api/v1/statuses/:id/reblog id)) + (case (response-code res) + ((200) #t) + (else + (error "reblog: failed" res body)))) + +(define (post-/api/v1/statuses/:id/reblog id) + (request + 'POST + (format #f "/api/v1/statuses/~a/reblog" id) + #:authorization? #t)) + +(define (unreblog id) + (define-values (res body) + (post-/api/v1/statuses/:id/unreblog id)) + (case (response-code res) + ((200) #t) + (else + (error "unreblog: failed" res body)))) + +(define (post-/api/v1/statuses/:id/unreblog id) + (request + 'POST + (format #f "/api/v1/statuses/~a/unreblog" id) + #:authorization? #t)) + +(define* (raw-request method path #:key (headers '()) (body "") authorization? streaming?) + (receive (res body) + (http-request (string-append "https://" + (current-mastodon-host) + path) + #:method method + #:headers `(,@headers + ,@(and/nil + authorization? + `((authorization + ,(string->symbol + (string-append + "Bearer " + (current-mastodon-access-token))))))) + #:decode-body? #f + #:streaming? streaming? + #:body body) + (values res body))) + +(define* (request method path + #:key + json + authorization?) + (receive (res body) + (raw-request method path + #:body (and json + (scm->json-string json)) + #:headers (and/nil json + '((content-type application/json))) + #:authorization? authorization?) + (if (= 200 (response-code res)) + (values res (json-string->scm (utf8->string body))) + (values res body)))) + +(define* (fetch-account id) + (receive (res body) + (get-/api/v1/accounts/:id id) + (case (response-code res) + ((200) (make-account body)) + ((401) + (error "fetch-account: Unauthorized" id)) + ((404) + (error "fetch-account: Not Found" id)) + ((410) + (error "fetch-account: Account is suspended" id)) + (else + (error "fetch-account: failed" + (response-code res) + (utf8->string body)))))) + +(define* (get-/api/v1/accounts/:id id) + (request + 'GET + (format #f "/api/v1/accounts/~a" id))) + +(define (streaming-health?) + (receive (res body) + (get-/api/v1/streaming/health) + (case (response-code res) + ((200) + (let ((result (utf8->string (get-bytevector-all body)))) + (close-input-port body) + (string=? "OK" result))) + (else + #f)))) + +(define (get-/api/v1/streaming/health) + (raw-request 'GET "/api/v1/streaming/health" #:streaming? #t)) + +(define (utf8-read-line in) + (call/cc + (lambda (k) + (utf8->string + (call-with-bytevector-output-port + (lambda (out) + (let loop ((b (get-u8 in))) + (cond + ((eof-object? b) + (k b)) + ((or (= b 10)) + 'done) + (else + (put-u8 out b) + (loop (get-u8 in))))))))))) + +(define (read-streaming port) + (let ((line (utf8-read-line port))) + (cond + ((eof-object? line) + (values (eof-object) "")) + (else + (let* ((i (string-index line #\:))) + (if (or (not i) + (<= i 1)) + (read-streaming port) + (values + (string-trim-both (substring line 0 i)) + (string-trim-both + (substring line (+ i 1)))))))))) + +(define (streaming-user handler) + (streaming get-/api/v1/streaming/user handler)) + +(define* (streaming-public handler #:key only-media?) + (streaming (if only-media? + get-/api/v1/streaming/public?only_media=true + get-/api/v1/streaming/public) + handler)) + +(define* (streaming-local handler #:key only-media?) + (streaming (if only-media? + get-/api/v1/streaming/local?only_media=true + get-/api/v1/streaming/local) + handler)) + +(define (streaming-hashtag hashtag handler) + (streaming (lambda () + (get-/api/v1/streaming/hashtag?tag=:hashtag hashtag)) + handler)) + +(define (streaming-local-hashtag hashtag handler) + (streaming (lambda () + (get-/api/v1/streaming/hashtag/local?tag=:hashtag hashtag)) + handler)) + +(define (streaming-list list-id handler) + (streaming (lambda () + (get-/api/v1/streaming/list?list=:list_id list-id)) + handler)) + +(define* (streaming-direct handler) + (streaming get-/api/v1/streaming/direct handler)) + +(define (streaming streamer handler) + (receive (res body) + (streamer) + (case (response-code res) + ((200) + (dynamic-wind + (lambda () 'ok) + (lambda () + (let loop ((event #f)) + (receive (type data) + (read-streaming body) + (cond + ((eof-object? type) 'end) + ((string=? type "event") + (loop (string->symbol data))) + ((string=? type "data") + (case event + ((update) + (handler event + (make-status + (json-string->scm data))) + (loop #f)) + ((delete) + (handler event data)) + ((notification) + (handler event + (make-notification + (json-string->scm data))) + (loop #f)) + (else + (handler event data) + (loop #f)))) + (else + (format #t "[DEBUG] ~a: ~a" event data) + (loop #f)))))) + (lambda () + (close-input-port body)))) + (else #f)))) + +(define (get-/api/v1/streaming/user) + (raw-request 'GET "/api/v1/streaming/user" + #:streaming? #t + #:authorization? #t)) + +(define (get-/api/v1/streaming/public) + (raw-request 'GET "/api/v1/streaming/public" + #:streaming? #t)) + +(define (get-/api/v1/streaming/public?only_media=true) + (raw-request 'GET "/api/v1/streaming/public?only_media=true" + #:streaming? #t)) + +(define (get-/api/v1/streaming/local) + (raw-request 'GET "/api/v1/streaming/local" + #:streaming? #t)) + +(define (get-/api/v1/streaming/local?only_media=true) + (raw-request 'GET "/api/v1/streaming/local?only_media=true" + #:streaming? #t)) + +(define (get-/api/v1/streaming/hashtag?tag=:hashtag hashtag) + (raw-request 'GET + (format #f "/api/v1/streaming/hashtag?tag=~a" hashtag) + #:streaming? #t)) + +(define (get-/api/v1/streaming/hashtag/local?tag=:hashtag hashtag) + (raw-request 'GET + (format #f "/api/v1/streaming/hashtag/local?tag=~a" hashtag) + #:streaming? #t)) + +(define (get-/api/v1/streaming/list?list=:list_id hashtag) + (raw-request 'GET + (format #f "/api/v1/streaming/list?list=~a" hashtag) + #:streaming? #t + #:authorization? #t)) + +(define (get-/api/v1/streaming/direct) + (raw-request 'GET + "/api/v1/streaming/direct" + #:streaming? #t + #:authorization? #t)) |