From d7285203cb04d4e6625bcbf7222f012ba4f7cdb6 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Wed, 15 Jul 2020 06:10:14 +0900 Subject: Rename proejct from qkbox to toot. --- .dir-locals.el | 4 + Makefile.am | 12 +- README.org | 4 +- configure.ac | 4 +- guix.scm | 24 +- pre-inst-env.in | 10 +- qkbox/.dir-locals.el | 4 - qkbox/toot.scm | 882 --------------------------------------------------- toot.scm | 882 +++++++++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 913 insertions(+), 913 deletions(-) create mode 100644 .dir-locals.el delete mode 100644 qkbox/.dir-locals.el delete mode 100644 qkbox/toot.scm create mode 100644 toot.scm diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..c5c5588 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,4 @@ +((scheme-mode + . + ((indent-tabs-mode . nil) + (eval . (put 'set-record-type-printer! 'scheme-indent-function 1))))) diff --git a/Makefile.am b/Makefile.am index 3bffc0f..722d422 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,20 +1,20 @@ -## Qkbox --- TojoQK's toybox +## Toot --- Mastodon Client ## Copyright © 2020 Masaya Tojo ## -## This file is part of Qkbox. +## This file is part of Toot. ## -## Qkbox is free software; you can redistribute it and/or modify it +## 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. ## -## Qkbox is distributed in the hope that it will be useful, but +## 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 Qkbox. If not, see . +## along with Toot. If not, see . GOBJECTS = $(SOURCES:%.scm=%.go) @@ -42,7 +42,7 @@ godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache bin_SCRIPTS = SOURCES = \ - qkbox/toot.scm + toot.scm TESTS = diff --git a/README.org b/README.org index 0f33b2c..598e182 100644 --- a/README.org +++ b/README.org @@ -1,3 +1,3 @@ -* qkbox +* toot -Qkbox is TojoQK's toybox. +Toot is Mastodon Client. diff --git a/configure.ac b/configure.ac index 0cf3868..4ee9e56 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([qkbox], [0.1.0]) -AC_CONFIG_SRCDIR([qkbox]) +AC_INIT([toot], [0.1.0]) +AC_CONFIG_SRCDIR([toot.scm]) AC_CONFIG_AUX_DIR([build-aux]) AM_INIT_AUTOMAKE([-Wall -Werror foreign]) AM_SILENT_RULES([yes]) diff --git a/guix.scm b/guix.scm index 8cd9764..d398350 100644 --- a/guix.scm +++ b/guix.scm @@ -1,20 +1,20 @@ -;;; Qkbox --- TojoQK's toybox +;;; Toot --- Mastodon Client ;;; Copyright © 2020 Masaya Tojo ;;; -;;; This file is part of Qkbox. +;;; This file is part of Toot. ;;; -;;; Qkbox is free software; you can redistribute it and/or modify it +;;; 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. ;;; -;;; Qkbox is distributed in the hope that it will be useful, but +;;; 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 Qkbox. If not, see . +;;; along with Toot. If not, see . (use-modules (guix packages) ((guix licenses) #:prefix license:) @@ -28,11 +28,11 @@ (gnu packages texinfo) (gnu packages mastodon)) -(define guile-qkbox +(define guile-toot (package - (name "guile-qkbox") + (name "guile-toot") (version "0.1.0") - (source (string-append (getcwd) "/qkbox-" version ".tar.gz")) + (source (string-append (getcwd) "/toot-" version ".tar.gz")) (build-system gnu-build-system) (native-inputs `(("autoconf" ,autoconf) @@ -43,9 +43,9 @@ `(("guile" ,guile-3.0) ("gulie-json" ,guile-json-4) ("guile-picture-language" ,guile-picture-language))) - (synopsis "TojoQK's toybox") - (description "Qkbox is TojoQK's toybox.") - (home-page "https://gitlab.com/tojoqk/qkbox") + (synopsis "Mastodon Client") + (description "Toot is Mastodon Client.") + (home-page "https://gitlab.com/tojoqk/toot") (license license:gpl3+))) -guile-qkbox +guile-toot diff --git a/pre-inst-env.in b/pre-inst-env.in index 82b6e4d..e9652a8 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -1,22 +1,22 @@ #!/bin/sh -# Qkbox --- TojoQK's toybox +# Toot --- Mastodon Client # Copyright © 2020 Masaya Tojo # -# This file is part of Qkbox. +# This file is part of Toot. # -# Qkbox is free software; you can redistribute it and/or modify it +# 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. # -# Qkbox is distributed in the hope that it will be useful, but WITHOUT +# 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 Qkbox. If not, see . +# along with Toot. If not, see . abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" 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 -;;; -;;; 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 . - -(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 - (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://" - (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)) 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 +;;; +;;; 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 + 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 + (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://" + (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)) -- cgit v1.2.3