Rename proejct from qkbox to toot.

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))