diff options
Diffstat (limited to 'qkbox')
| -rw-r--r-- | qkbox/.dir-locals.el | 4 | ||||
| -rw-r--r-- | qkbox/toot.scm | 882 |
2 files changed, 0 insertions, 886 deletions
diff --git a/qkbox/.dir-locals.el b/qkbox/.dir-locals.el deleted file mode 100644 index c5c5588..0000000 --- a/qkbox/.dir-locals.el +++ /dev/null @@ -1,4 +0,0 @@ -((scheme-mode - . - ((indent-tabs-mode . nil) - (eval . (put 'set-record-type-printer! 'scheme-indent-function 1))))) diff --git a/qkbox/toot.scm b/qkbox/toot.scm deleted file mode 100644 index 0043fb8..0000000 --- a/qkbox/toot.scm +++ /dev/null @@ -1,882 +0,0 @@ -;;; Qkbox --- TojoQK's toybox -;;; Copyright © 2020 Masaya Tojo <masaya@tojo.tokyo> -;;; -;;; This file is part of Qkbox. -;;; -;;; Qkbox 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. -;;; -;;; Qkbox 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 Qkbox. If not, see <http://www.gnu.org/licenses/>. - -(define-module (qkbox 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)) |