summaryrefslogtreecommitdiff
path: root/qkbox/toot.scm
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2020-07-12 06:35:51 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2020-07-12 06:35:51 +0900
commitd8f4c0acbf1eafaa4367f771c2f7d308eff916d4 (patch)
tree13fdd38d171e8cb1f9395ecc9c6f207fedd3afe0 /qkbox/toot.scm
parent98a528fc22adfbead514365a201cc1b33f90a34e (diff)
qkbox: toot: Update.
Diffstat (limited to 'qkbox/toot.scm')
-rw-r--r--qkbox/toot.scm284
1 files changed, 223 insertions, 61 deletions
diff --git a/qkbox/toot.scm b/qkbox/toot.scm
index bb44a72..025c7a7 100644
--- a/qkbox/toot.scm
+++ b/qkbox/toot.scm
@@ -31,8 +31,8 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (pict)
- #:use-module ((sxml simple)
- #:select (xml->sxml))
+ #:use-module ((htmlprag)
+ #:select (html->sxml))
#:use-module ((sxml fold)
#:select (foldt))
#:use-module ((sxml xpath)
@@ -123,29 +123,60 @@
(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)
+ (content-filter (account-display-name account)))
+ (account-acct account)
+ (account-id account)))
+
(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)))
+ display-cw?
+ (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?)
+ (content-filter
+ (status-to-content-string status)))))))))
+
+(define (status-avatar-pict status)
+ (let ((status-pict (or (fetch-avatar-static
+ (account-avatar-static
+ (status-account status)))
+ no-image)))
(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)))))
+ ((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"))
@@ -162,28 +193,36 @@
(define-public (status-content status)
(assoc-ref (status-json status) "content"))
+(define (content-filter x)
+ (string-delete (char-set #\x202d #\x202e) x))
+
(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))
+ (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
@@ -200,12 +239,85 @@
#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-public (status-media-attachments status)
(let ((v (assoc-ref (status-json status) "media_attachments")))
(if (zero? (vector-length v))
#f
(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"))
@@ -218,7 +330,10 @@
(define-public (account-display-name account)
(assoc-ref (account-json account) "display_name"))
-(define avatar-static-hash (make-hash-table))
+(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)
(receive (res body)
@@ -227,25 +342,43 @@
(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 "~d!x~d!"
- (car resize)
- (cadr resize))))
- ,(string-append tmp "[0]")
- ,(string-append "png:" tmp))))
- (pict-from-file tmp))))
- (delete-file tmp)
- pict))))
+ (case (response-code res)
+ ((200)
+ (let ((pict (and (zero? (apply system* "convert"
+ `(,@(and/nil 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))
+ (else
+ (display (response-code res))
+ (newline)
+ #f)))))
(define* (fetch-avatar-static url)
(cond
- ((hash-ref avatar-static-hash url) => identity)
+ ((hash-ref avatar-static-cache url) => identity)
(else
- (let ((pict (fetch-pict url #:resize '(32 32))))
- (hash-set! avatar-static-hash url pict)
- pict))))
+ (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)
@@ -261,7 +394,7 @@
(format #f "/api/v1/statuses/~a" id)
#:authorization? authorization?))
-(define*-public (fetch-timeline #:key max-id since-id min-id limit local?)
+(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
@@ -272,9 +405,24 @@
((200)
(map make-status (vector->list body)))
((206)
- (error "fetch-timeline: Home feed is regenerating"))
+ (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-timeline: failed" res body)))))
+ (error "fetch-public-timeline: failed" res body)))))
(define* (/api/v1/timelines/home #:key max-id since-id min-id limit local?)
(request
@@ -288,6 +436,20 @@
,@(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))