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 (srfi srfi-9)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (pict)
  #:use-module ((sxml simple)
                #:select (xml->sxml))
  #:use-module ((sxml fold)
                #:select (foldt))
  #:use-module ((sxml xpath)
                #:select (sxpath)))

(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)
  (define-values (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
   `(,@(if status
           `((status . ,(if (string? status)
                            status
                            (format #f "~y" status))))
           '())
     ,@(if spoiler-text
           `((spoiler_text . ,spoiler-text))
           '())
     ,@(if visibility
           (case visibility
             ((public unlisted private direct)
              `((visibility . ,visibility)))
             (else
              (error "post: invalid visibility (must be one of: public unlisted private direct)")))
           '())
     ,@(if sensitive? `((sensitive . (if sensitive? #t #f)))
           '())
     ,@(if reply-to
           `((in_reply_to_id . ,reply-to))
           '())
     ,@(if 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*-public (display-status status
                                #:key
                                (port (current-output-port))
                                display-cw?)
  (let ((account (status-account status)))
    (format port "~s ~a ~a ~s~@[ ~:@(~a~)~]~%"
            (fetch-avatar-static (account-avatar-static account))
            (account-display-name account)
            (account-acct account)
            (status-id status)
            (if (eq? 'public (status-visibility status))
                #f
                (status-visibility status)))
    (cond
     ((status-spoiler-text status)
      => (lambda (spoiler-text)
           (format port "[CW]: ~a~%" spoiler-text)
           (when display-cw?
             (display-content (status-content status)
                              port))))
     (else
      (display-content (status-content status)
                       port)))))

(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-content status)
  (assoc-ref (status-json status) "content"))

(define (content->sxml content)
  (xml->sxml
   (string-append
    "<status>"
    (regexp-substitute/global #f "<br>"
                              content
                              'pre "<br/>" 'post)
    "</status>")))

(define*-public (display-content content #:optional (port (current-output-port)))
  (for-each (lambda (x) (display x port))
            (flatten
             (foldt (lambda (xs)
                      (case (car xs)
                        ((*TOP* span status p a) (cdr xs))
                        ((br) #\newline)
                        ((@ class target rel href) '())
                        (else
                         (format #f "~%[DEBUG] UNEXPECTED ~a~%" xs))))
                    (lambda (obj) obj)
                    (content->sxml content))))
  (newline 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-public (status-media-attachments status)
  (let ((v (assoc-ref (status-json status) "media_attachments")))
    (if (zero? (vector-length v))
        #f
        (vector->list v))))

(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 avatar-static-hash (make-hash-table))

(define* (fetch-pict url #:key resize)
  (receive (res body)
      (http-get url)
    (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"
                                     `(,@(if resize
                                             `("-resize"
                                               ,(format #f "~d!x~d!"
                                                        (car resize)
                                                        (cadr resize)))
                                             '())
                                       ,(string-append tmp "[0]")
                                       ,(string-append "png:" tmp))))
                       (pict-from-file tmp))))
        (delete-file tmp)
        pict))))

(define* (fetch-avatar-static url)
  (cond
   ((hash-ref avatar-static-hash url) => identity)
   (else
    (let ((pict (fetch-pict url #:resize '(32 32))))
      (hash-set! avatar-static-hash url pict)
      pict))))

(define*-public (status id #:key (authorization? #t))
  (define-values (res body)
    (/api/v1/statuses/:id id #:authorization? authorization?))
  (case (response-code res)
    ((200) (make-status body))
    (else
     (error "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 (timeline #:key max-id since-id min-id limit local?)
  (define-values (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 "timeline: Home feed is regenerating"))
    (else
     (error "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
   `(,@(if max-id `((max_id . ,max-id)) '())
     ,@(if since-id `((since_id . ,since-id)) '())
     ,@(if min-id `((min_id . ,min-id)) '())
     ,@(if limit `((limit . ,limit)) '())
     ,@(if local? `((local . ,local?)) '()))
   #: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?)
  (receive (res body)
      (http-request (string-append "https://"
                                   (current-mastodon-host)
                                   path)
                    #:method method
                    #:headers `(,@headers
                                ,@(if authorization?
                                      `((authorization
                                         ,(string->symbol
                                           (string-append
                                            "Bearer "
                                            (current-mastodon-access-token)))))
                                      '()))
                    #:decode-body? #f
                    #:body body)
    (values res body)))

(define* (request method path
                  #:key
                  json
                  authorization?)
  (receive (res body)
      (raw-request method path
                   #:body (if json
                              (scm->json-string json)
                              #f)
                   #:headers (if 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 (account id)
  (define-values (res body)
    (/api/v1/accounts/:id id))
  (case (response-code res)
    ((200) (make-account body))
    ((401)
     (error "account: Unauthorized" id))
    ((404)
     (error "account: Not Found" id))
    ((410)
     (error "account: Account is suspended" id))
    (else
     (error "account: failed"
            (response-code res)
            (utf8->string body)))))

(define* (/api/v1/accounts/:id id)
  (request
   'GET
   (format #f "/api/v1/accounts/~a" id)))