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