(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 (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (pict)
  #:export (post
            timeline
            favourite
            unfavourite
            reblog
            unreblog))

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

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

(define* (post status
               #:key
               spoiler-text
               visibility
               sensitive?
               reply-to)
  (define-values (res body)
    (/api/v1/statuses #:status status
                      #: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))

(define (status-id status)
  (assoc-ref (status-json status) "id"))

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

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

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

(define (status-visibility status)
  (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 (status-media-attachments status)
  (let ((v (assoc-ref (status-json status) "media_attachments")))
    (if (zero? (vector-length v))
        #f
        (vector->list v))))

(define avatar-static-hash (make-hash-table))

(define* (avatar-static->pict url)
  (cond
   ((hash-ref avatar-static-hash url) => identity)
   (else
    (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? (system* "convert" "-resize" "32!x32!"
                                         tmp
                                         (string-append "png:" tmp)))
                         (pict-from-file tmp))))
          (delete-file tmp)
          (hash-set! avatar-static-hash url pict)
          pict))))))

(set-record-type-printer! <status>
  (lambda (status port)
    (cond
     ((status-reblog status) =>
      (lambda (reblog)
        (format port "#<~s ~s BT: ~s>"
                (avatar-static->pict (status-avatar-static status))
                (status-id status)
                reblog)))
     (else
      (format port
              "#<~s ~s ~a~@[ ~:@(~a~)~] ~a>"
              (avatar-static->pict (status-avatar-static status))
              (status-id status)
              (status-acct status)
              (if (string=? (status-visibility status) "public")
                  #f
                  (status-visibility status))
              (cond
               ((status-spoiler-text status) =>
                (lambda (spoiler-text)
                  (format #f "CW: ~s" spoiler-text)))
               ((status-media-attachments status) =>
                (lambda (media-attachments)
                  (format #f "MEDIA(~a) ~s"
                          (length media-attachments)
                          (status-content status))))
               (else
                (format #f "~s"
                        (status-content status)))))))))

(define* (id->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 "timeline: failed" res body))))

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

(define* (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 (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 (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 (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 (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* (request method path #:key json authorization?)
  (define-values (res body)
    (http-request (string-append "https://"
                                 (current-mastodon-host)
                                 path)
                  #:method method
                  #:headers `((content-type application/json)
                              ,@(if authorization?
                                    `((authorization
                                       ,(string->symbol
                                         (string-append
                                          "Bearer "
                                          (current-mastodon-access-token)))))
                                    '()))
                  #:decode-body? #t
                  #:body (if json
                             (scm->json-string json)
                             #f)))
  (if (= 200 (response-code res))
      (values res (json-string->scm (utf8->string body)))
      (values res body)))