qkbox: toot: Update.

1 files changed, 222 insertions, 60 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>")))
+  (html->sxml content))
 
-(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 (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))