;;; Toot --- Mastodon client. ;;; Copyright © 2020 Masaya Tojo ;;; ;;; 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 . (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 mastodon-host 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 mastodon-host (make-parameter (getenv "MASTODON_HOST"))) (define 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 (make-status json) 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-record-type (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 (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 (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://" (mastodon-host) path) #:method method #:headers `(,@headers ,@(and/nil authorization? `((authorization ,(string->symbol (string-append "Bearer " (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))