path: root/qkbox/toot.scm

;;; Qkbox --- TojoQK's toybox
;;; Copyright © 2020 Masaya Tojo <masaya@tojo.tokyo>
;;;
;;; This file is part of Qkbox.
;;;
;;; Qkbox is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Qkbox is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Qkbox.  If not, see <http://www.gnu.org/licenses/>.

(define-module (qkbox toot)
  #:use-module (ice-9 format)
  #:use-module (web response)
  #:use-module (web client)
  #:use-module (json builder)
  #:use-module (json parser)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 optargs)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (pict)
  #:use-module ((htmlprag)
                #:select (html->sxml))
  #:use-module ((sxml fold)
                #:select (foldt))
  #:use-module ((sxml xpath)
                #:select (sxpath)))

(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*-public (post text
                      #:key
                      spoiler-text
                      visibility
                      sensitive?
                      reply-to)
  (receive (res body)
      (/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* (/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-public (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*-public (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~@?~@?~@?~@?~@?~%~@?~@?"
                (status-avatar-pict status/original)
                (account-to-string account)
                "~@[~%  * 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-public (status-id status)
  (assoc-ref (status-json status) "id"))

(define-public (status-account status)
  (make-account (assoc-ref (status-json status) "account")))

(define-public (status-reblog status)
  (let ((reblog/json (assoc-ref (status-json status) "reblog")))
    (if (eq? reblog/json 'null)
        #f
        (make-status reblog/json))))

(define-public (status-sensitive? status)
  (assoc-ref (status-json status) "sensitive"))

(define-public (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-public (status-visibility status)
  (string->symbol (assoc-ref (status-json status) "visibility")))

(define-public (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-public (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-public (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 (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-public (account-id account)
  (assoc-ref (account-json account) "id"))

(define-public (account-avatar-static account)
  (assoc-ref (account-json account) "avatar_static"))

(define-public (account-acct account)
  (assoc-ref (account-json account) "acct"))

(define-public (account-display-name account)
  (assoc-ref (account-json account) "display_name"))

(define-public (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*-public (fetch-status id #:key (authorization? #t))
  (receive (res body)
      (/api/v1/statuses/:id id #:authorization? authorization?)
    (case (response-code res)
      ((200) (make-status body))
      (else
       (error "fetch-status: failed" res body)))))

(define* (/api/v1/statuses/:id id #:key (authorization? #t))
  (request
   'GET
   (format #f "/api/v1/statuses/~a" id)
   #:authorization? authorization?))

(define*-public (fetch-home-timeline #:key max-id since-id min-id limit local?)
  (receive (res body)
      (/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*-public (fetch-public-timeline #:key max-id since-id min-id limit local? remote? only-media?)
  (receive (res body)
      (/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* (/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* (/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-public (favourite id)
  (define-values (res body)
    (/api/v1/statuses/:id/favourite id))
  (case (response-code res)
    ((200) #t)
    (else
     (error "favourite: failed" res body))))

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

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

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

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

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

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

(define (/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*-public (fetch-account id)
  (receive (res body)
      (/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* (/api/v1/accounts/:id id)
  (request
   'GET
   (format #f "/api/v1/accounts/~a" id)))