summaryrefslogtreecommitdiff
path: root/qkbox
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2020-07-10 10:18:51 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2020-07-10 10:18:51 +0900
commitc50929cc93774a2d1a7c7e567cbb47cb586881bc (patch)
tree97529fe67bfd0c01b7fcea86497f01479f08b99e /qkbox
parentb05e744f75dd44eb17de27168ad41c3496593432 (diff)
qkbox: toot: Update.
Diffstat (limited to 'qkbox')
-rw-r--r--qkbox/toot.scm250
1 files changed, 175 insertions, 75 deletions
diff --git a/qkbox/toot.scm b/qkbox/toot.scm
index 3a8c784..6d83e92 100644
--- a/qkbox/toot.scm
+++ b/qkbox/toot.scm
@@ -25,9 +25,17 @@
#: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))
#:export (post
timeline
favourite
@@ -100,16 +108,55 @@
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 (status-public? status)
+ (eq? 'public (status-visibility status)))
+
+(define* (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 (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-account status)
+ (make-account (assoc-ref (status-json status) "account")))
(define (status-reblog status)
(let ((reblog/json (assoc-ref (status-json status) "reblog")))
@@ -120,6 +167,35 @@
(define (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* (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 (status-visibility status)
(string->symbol (assoc-ref (status-json status) "visibility")))
@@ -135,65 +211,55 @@
#f
(vector->list v))))
+(define (account-id account)
+ (assoc-ref (account-json account) "id"))
+
+(define (account-avatar-static account)
+ (assoc-ref (account-json account) "avatar_static"))
+
+(define (account-acct account)
+ (assoc-ref (account-json account) "acct"))
+
+(define (account-display-name account)
+ (assoc-ref (account-json account) "display_name"))
+
(define avatar-static-hash (make-hash-table))
-(define* (avatar-static->pict url)
+(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
- (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))))))
+ (let ((pict (fetch-pict url #:resize '(32 32))))
+ (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)
- (case (status-visibility status)
- ((public) #f)
- (else
- (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* (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))))
+ (error "status: failed" res body))))
(define* (/api/v1/statuses/:id id #:key (authorization? #t))
(request
@@ -284,24 +350,58 @@
(format #f "/api/v1/statuses/~a/unreblog" id)
#:authorization? #t))
-(define* (request method path #:key json authorization?)
+(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* (account id)
(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)))
+ (/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)))