path: root/toot.scm

;;; 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 (toot utils)
  #:use-module (toot statuses)
  #:use-module (toot accounts)
  #:use-module (toot notifications)
  #:use-module (toot emojis)
  #:use-module (toot attachments)
  #: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 (;; parameter
            mastodon-host
            mastodon-access-token
            pict-enabled?

            ;; get
            fetch-status
            fetch-account
            fetch-home-timeline
            fetch-public-timeline

            ;; post
            post
            favourite
            unfavourite
            reblog
            unreblog

            ;; streaming
            streaming-user
            streaming-public

            ;; display
            display-status
            display-notification))

(define mastodon-host
  (make-parameter (getenv "MASTODON_HOST")))

(define mastodon-access-token
  (make-parameter (getenv "MASTODON_ACCESS_TOKEN")))

(define pict-enabled?
  (make-parameter #f))

(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* (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~)~%~@[~s ~]~a ~a~%> "
            (notification-type notification)
            (and (pict-enabled?)
                 (fetch-avatar-static
                  (account-avatar-static account)))
            (account-to-string account)
            (creation-time->string time))
    (display-status (notification-status notification))))

(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~@?~@?~@?~@?~@?~%~@?~@?"
                (and (pict-enabled?)
                     (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
                               ((and (pict-enabled?)
                                     (fetch-attachment-preview-pict att))
                                => identity)
                               (else
                                "MEDIA: IMAGE")))
                             (else
                              =>
                              (lambda (type)
                                (format #f "MEDIA: ~:@(~a~)" type))))
                           (format #f "MEDIA: 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 (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 (fetch-attachment-preview-pict attachment)
  (fetch-pict (attachment-preview-url attachment)
              #:height> 128))

(define (fetch-attachment-pict attachment)
  (fetch-pict (attachment-url attachment)))

(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
                             ((emoji-find emojis shortcode)
                              =>
                              (lambda (emoji)
                                (or (and (pict-enabled?)
                                         (fetch-emoji-pict emoji))
                                    shortcode))))
                            (loop (match:suffix mat))))))
                (else
                 (list s))))
        (list x))))

(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) (status-from-json 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 status-from-json (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 status-from-json (vector->list body)))
      (else
       (error "fetch-public-timeline: failed" res body)))))

(define* (get-/api/v1/timelines/home #:key max-id since-id min-id limit local?)
  (request
   'GET
   "/api/v1/timelines/home"
   #:json
   `(,@(and/nil max-id `((max_id . ,max-id)))
     ,@(and/nil since-id `((since_id . ,since-id)))
     ,@(and/nil min-id `((min_id . ,min-id)))
     ,@(and/nil limit `((limit . ,limit)))
     ,@(and/nil local? `((local . ,local?))))
   #:authorization? #t))

(define* (get-/api/v1/timelines/public #:key max-id since-id min-id limit local? remote? only-media?)
  (request
   'GET
   "/api/v1/timelines/public"
   #:json
   `(,@(and/nil max-id `((max_id . ,max-id)))
     ,@(and/nil since-id `((since_id . ,since-id)))
     ,@(and/nil min-id `((min_id . ,min-id)))
     ,@(and/nil limit `((limit . ,limit)))
     ,@(and/nil local? `((local . ,local?)))
     ,@(and/nil remote? `((remote . ,remote?)))
     ,@(and/nil only-media? `((only_media . ,only-media?))))
   #:authorization? #t))

(define (favourite id)
  (define-values (res body)
    (post-/api/v1/statuses/:id/favourite id))
  (case (response-code res)
    ((200) #t)
    (else
     (error "favourite: failed" res body))))

(define (post-/api/v1/statuses/:id/favourite id)
  (request
   'POST
   (format #f "/api/v1/statuses/~a/favourite" id)
   #:authorization? #t))

(define (unfavourite id)
  (define-values (res body)
    (post-/api/v1/statuses/:id/unfavourite id))
  (case (response-code res)
    ((200) #t)
    (else
     (error "unfavourite: failed" res body))))

(define (post-/api/v1/statuses/:id/unfavourite id)
  (request
   'POST
   (format #f "/api/v1/statuses/~a/unfavourite" id)
   #:authorization? #t))

(define (reblog id)
  (define-values (res body)
    (post-/api/v1/statuses/:id/reblog id))
  (case (response-code res)
    ((200) #t)
    (else
     (error "reblog: failed" res body))))

(define (post-/api/v1/statuses/:id/reblog id)
  (request
   'POST
   (format #f "/api/v1/statuses/~a/reblog" id)
   #:authorization? #t))

(define (unreblog id)
  (define-values (res body)
    (post-/api/v1/statuses/:id/unreblog id))
  (case (response-code res)
    ((200) #t)
    (else
     (error "unreblog: failed" res body))))

(define (post-/api/v1/statuses/:id/unreblog id)
  (request
   'POST
   (format #f "/api/v1/statuses/~a/unreblog" id)
   #:authorization? #t))

(define* (raw-request method path #:key (headers '()) (body "") authorization? streaming?)
  (receive (res body)
      (http-request (string-append "https://"
                                   (mastodon-host)
                                   path)
                    #:method method
                    #:headers `(,@headers
                                ,@(and/nil
                                   authorization?
                                   `((authorization
                                      ,(string->symbol
                                        (string-append
                                         "Bearer "
                                         (mastodon-access-token)))))))
                    #:decode-body? #f
                    #:streaming? streaming?
                    #:body body)
    (values res body)))

(define* (request method path
                  #:key
                  json
                  authorization?)
  (receive (res body)
      (raw-request method path
                   #:body (and json
                               (scm->json-string json))
                   #:headers (and/nil json
                                      '((content-type application/json)))
                   #:authorization? authorization?)
    (if (= 200 (response-code res))
        (values res (json-string->scm (utf8->string body)))
        (values res body))))

(define* (fetch-account id)
  (receive (res body)
      (get-/api/v1/accounts/:id id)
    (case (response-code res)
      ((200) (account-from-json 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
                             (status-from-json
                              (json-string->scm data)))
                    (loop #f))
                   ((delete)
                    (handler event data)
                    (loop #f))
                   ((notification)
                    (handler event
                             (notification-from-json
                              (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))