Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Add: WIP support for URL previews #63

Draft
wants to merge 6 commits into
base: master
Choose a base branch
from
Draft

Add: WIP support for URL previews #63

Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
37fd15d
Add: WIP support for URL previews
rayes0 Apr 14, 2022
fabd473
Fix: First attempt at implementing by inserting after body
rayes0 Apr 15, 2022
0411b60
Fix: Solve infinite recursion error
rayes0 Apr 15, 2022
f5e77ae
Fix/Change: Small fixes in places and simplify implementation
rayes0 Apr 15, 2022
8545864
Fix/Change: Remove debug code, fix conventions, add line wrapping
rayes0 May 1, 2022
69a7de6
Fix/Change: Key on URL string rather than index
rayes0 May 13, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
197 changes: 168 additions & 29 deletions ement-room.el
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -189,6 +189,10 @@ this one automatically.")
'((t (:inverse-video t :extend t))))
"Messages that mention the local user.")

(defface ement-room-preview
'((t (:inherit ement-room-message-text :height 0.9)))
"Text of URL previews.")

;;;;; Options

(defcustom ement-room-ellipsis "⋮"
Expand All @@ -207,6 +211,23 @@ this one automatically.")
"Maximum height in pixels of room avatars shown in header lines."
:type 'integer)

(defcustom ement-room-url-previews nil
"Show URL previews."
:type 'boolean)

(defcustom ement-room-url-preview-prefix (concat " "
(let ((char (char-from-name "BOX DRAWINGS HEAVY VERTICAL")))
(if (char-displayable-p char)
(char-to-string char)
"|"))
" ")
"Prefix to insert before lines in URL previews."
:type 'string)

(defcustom ement-room-url-preview-width 250
"Max width to use for URL previews before truncating."
:type 'integer)

(defcustom ement-room-header-line-format
;; TODO: Show in new screenshots.
'(:eval (concat (if ement-room-avatars
Expand Down Expand Up @@ -2317,14 +2338,14 @@ the first and last nodes in the buffer, respectively."
(defun ement-room--insert-event (event)
"Insert EVENT into current buffer."
(cl-labels ((format-event
(event) (format "TS:%S (%s) Sender:%s Message:%S"
(/ (ement-event-origin-server-ts event) 1000)
(format-time-string "%Y-%m-%d %H:%M:%S"
(/ (ement-event-origin-server-ts event) 1000))
(ement-user-id (ement-event-sender event))
(when (alist-get 'body (ement-event-content event))
(substring-no-properties
(truncate-string-to-width (alist-get 'body (ement-event-content event)) 20))))))
(event) (format "TS:%S (%s) Sender:%s Message:%S"
(/ (ement-event-origin-server-ts event) 1000)
(format-time-string "%Y-%m-%d %H:%M:%S"
(/ (ement-event-origin-server-ts event) 1000))
(ement-user-id (ement-event-sender event))
(when (alist-get 'body (ement-event-content event))
(substring-no-properties
(truncate-string-to-width (alist-get 'body (ement-event-content event)) 20))))))
(ement-debug "INSERTING NEW EVENT: " (format-event event))
(let* ((ewoc ement-ewoc)
(event< (lambda (a b)
Expand Down Expand Up @@ -2552,25 +2573,25 @@ Formats according to `ement-room-message-format-spec', which see."
;; TODO: Like other events, pop to a buffer showing the raw reaction events when a key is pressed.
(if-let ((reactions (map-elt (ement-event-local event) 'reactions)))
(cl-labels ((format-reaction
(ks) (pcase-let* ((`(,key . ,senders) ks)
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Please remove any whitespace-only hunks from the patch.

(key (propertize key 'face 'ement-room-reactions-key))
(count (propertize (format " (%s)" (length senders))
'face 'ement-room-reactions))
(string
(propertize (concat key count)
'button '(t)
'category 'default-button
'action #'ement-room-reaction-button-action
'follow-link t
'help-echo (lambda (_window buffer _pos)
(senders-names senders (buffer-local-value 'ement-room buffer))))))
(ement--remove-face-property string 'button)
string))
(ks) (pcase-let* ((`(,key . ,senders) ks)
(key (propertize key 'face 'ement-room-reactions-key))
(count (propertize (format " (%s)" (length senders))
'face 'ement-room-reactions))
(string
(propertize (concat key count)
'button '(t)
'category 'default-button
'action #'ement-room-reaction-button-action
'follow-link t
'help-echo (lambda (_window buffer _pos)
(senders-names senders (buffer-local-value 'ement-room buffer))))))
(ement--remove-face-property string 'button)
string))
(senders-names
(senders room) (cl-loop for sender in senders
collect (ement-room--user-display-name sender room)
into names
finally return (string-join names ", "))))
(senders room) (cl-loop for sender in senders
collect (ement-room--user-display-name sender room)
into names
finally return (string-join names ", "))))
(cl-loop with keys-senders
for reaction in reactions
for key = (map-nested-elt (ement-event-content reaction) '(m.relates_to key))
Expand Down Expand Up @@ -2666,6 +2687,20 @@ Format defaults to `ement-room-message-format-spec', which see."
(insert-and-inherit
(propertize " "
'display `((margin right-margin) ,string))))))
(when-let* ((data (ement-event-local event))
(previews (map-elt data 'url-previews)))
(goto-char (point-max))
(dolist (preview previews)
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is looking better. Now it probably should go into its own function, similar to ement-room--format-m.image. And the code that calls it should probably go in ement-room--format-message-body, treating it as a kind of "appendix" to the message body.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I've currently left it how it is, mainly due to the fact that there is already a function named ement-room--format-url-preview. I think the most reasonable way to go about it is integrating the dolist into ement-room--format-url-preview and calling it from ement-room--format-message-body, but just wanted to confirm with you before I do it.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'll also probably implement the message parsing in this combined function to insert the previews in the correct order rather than just iterating using dolist.

(unless (looking-at-p "^\n")
;; First preview
(insert "\n"))
(when (save-excursion
(forward-line -1)
(equal (get-text-property (point) 'line-prefix)
ement-room-url-preview-prefix))
;; Not first preview
(insert "\n"))
(insert (ement-room--format-url-preview preview))))
(buffer-string))))

(cl-defun ement-room--format-message-body (event &key (formatted-p t))
Expand Down Expand Up @@ -2693,6 +2728,9 @@ If FORMATTED-P, return the formatted body content, when available."
(when body
;; HACK: Once I got an error when body was nil, so let's avoid that.
(setf body (ement-room--linkify-urls body)))
(when ement-room-url-previews
;; HACK: Pass rendered body with text properties to match urls against them.
(ement-room--preview-urls event body))
;; HACK: Ensure body isn't nil (e.g. redacted messages can have empty bodies).
(unless body
(setf body "[message has no body content]"))
Expand Down Expand Up @@ -2757,12 +2795,14 @@ ROOM defaults to the value of `ement-room'."
;; HACK: So we use the username slot, which was created just for this, for now.
(when body
(cl-macrolet ((matches-body-p
(form) `(when-let ((string ,form))
(string-match-p (regexp-quote string) body))))
(form) `(when-let ((string ,form))
(string-match-p (regexp-quote string) body))))
(or (matches-body-p (ement-user-username user))
(matches-body-p (ement-room--user-display-name user room))
(matches-body-p (ement-user-id user)))))))

;; ;; ;; URLs

(defun ement-room--linkify-urls (string)
"Return STRING with URLs in it made clickable."
;; Is there an existing Emacs function to do this? I couldn't find one.
Expand All @@ -2777,9 +2817,108 @@ ROOM defaults to the value of `ement-room'."
'face 'link
'help-echo (match-string 0)
'action #'browse-url-at-mouse
'follow-link t))
'follow-link t
'ement-url t))
(buffer-string)))

(defun ement-room--preview-urls (event rendered)
"Parse RENDERED body of EVENT for URLs and fetch previews for them."
(if (and (not (alist-get 'url-previews (ement-event-local event)))
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not sure what rendered is here.

rendered)
(let ((room-buffer (alist-get 'buffer (ement-room-local ement-room))))
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If you can, please use pcase-let to destructure when possible. I'm trying to use it consistently (although sometimes using alist-get is still necessary).

(with-temp-buffer
(insert rendered)
(goto-char (point-min))
(cl-loop with match = nil
while (setf match (or (text-property-search-forward 'ement-url)
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why not just do a regexp search for URLs on the message's plain-text body? It will probably be faster, because Emacs's regexp engine is very well optimized, and the code will be much simpler.

(text-property-search-forward 'shr-url)))
for url = (buffer-substring-no-properties (prop-match-beginning match)
(prop-match-end match))
do (with-current-buffer room-buffer
(ement-room--url-preview event url)))))))

(defun ement-room--url-preview (event link)
"Fetch and insert a preview of LINK from EVENT if it isn't already present.
It is expected to be called in the room buffer associated with EVENT."
(let* ((id (ement-event-id event))
(related-event (cl-loop with match = (make-ement-event :id id)
for e in (ement-room-timeline ement-room)
if (ement--events-equal-p match e)
return e))
(saved-buffer (current-buffer)))
(unless (map-elt (ement-event-local related-event)
'url-previews)
(ement-api ement-session "preview_url"
:endpoint-category "media" :params `((url ,link))
:then (lambda (data)
(when (buffer-live-p saved-buffer)
rayes0 marked this conversation as resolved.
Show resolved Hide resolved
(with-current-buffer saved-buffer
(ement-room--insert-preview event
related-event
link
(progn (unless (alist-get 'og:url data)
(push (cons 'og:url link) data))
(unless (alist-get 'og:title data)
(push (cons 'og:title "[untitled page]") data))
data)))))
:else (lambda (why) (ement-debug "Error in fetching preview: " why))))))

(defun ement-room--insert-preview (message related key data)
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Please write in terms of events rather than messages, because events are the logical unit we work in here.

"Insert link preview for HTTP response DATA into MESSAGE from node RELATED,
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Note that docstrings' first lines should be a single sentence. You can use M-x checkdoc to help with these guidelines.

if it isn't already present. KEY will be the key used for inserting."
Copy link
Owner

@alphapapa alphapapa May 13, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't understand what "KEY will be the key used for inserting" means.

As well, "related" could be more clearly written as "related-event" or "related-node", etc.

(cond ((alist-get 'errcode data) (ement-debug "Rate limit in url preview"))
(data (let ((related-node (ement-room--ewoc-node-before ement-ewoc
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Please avoid one-symbol-per-line formatting style. This function has (declare (indent defun)) specified to avoid this. :)

message
(lambda (a b)
(string= (ement-event-id a)
(ement-event-id b)))
:pred #'ement-event-p))
(event (ement-event-local related)))
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If you're binding the event's local alist slot, the binding should be named local, not event--event should be the event struct itself.

But since you need to push to that alist anyway, you probably shouldn't bind it. I may be mistaken, but I don't think setting the bound variable will also set the slot value; you need to set the place form's value (at least, that's been my experience).

(unless (alist-get 'url-previews event)
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Please be consistent: use either map-elt or alist-get. :) (If performance matters, using alist-get will be faster, because map-elt is generic. But see also map-nested-elt, which can make for clearer code than nested alist-gets, and it's fast enough--although I don't think setf works with it, yet.)

(cl-pushnew (cons 'url-previews nil) event))
(unless (alist-get key (map-elt event 'url-previews))
(cl-pushnew (cons key data) (map-elt event 'url-previews)))
(ewoc-invalidate ement-ewoc related-node)))))

(defun ement-room--format-url-preview (data)
"Return a pretty-printed preview for DATA, an alist of parsed JSON from the homeserver."
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Nitpick: To keep the first line of the docstring short, the second clause (which is just supporting information) can go in a second sentence on a second line. (Checkdoc will complain, otherwise (although getting rid of all Checkdoc warnings is sometimes impractical)).

;; Reference: https://ogp.me/
(with-temp-buffer
(when-let ((title (alist-get 'og:title data)))
(insert (propertize title
'mouse-face 'highlight
'face '(link (:inherit ement-room-preview))
'help-echo (alist-get 'og:url data)
'action #'browse-url
'follow-link t
'button '(t)
'button-data (alist-get 'og:url data)
'keymap button-map
'category 'default-button)
"\n"))
(let* ((type-p (alist-get 'og:type data))
(special-p (alist-get 'og:site_name data))
(type nil))
(if special-p
(setf type special-p)
(setf type (cond ((not type-p) nil)
((string-match-p "music.*" type-p) "Music")
((string-match-p "video.*" type-p) "Video")
((string-match-p "article.*" type-p) "Article")
((string-match-p "book.*" type-p) "Book")
((string-match-p "profile.*" type-p) "Profile"))))
(when type
(insert (propertize type 'face 'ement-room-preview) "\n")))
(when-let* ((desc (alist-get 'og:description data)))
(insert (propertize (truncate-string-to-width (replace-regexp-in-string "\n" " " desc)
ement-room-url-preview-width 0 nil t t)
'face 'ement-room-preview)))
(let ((prefix (propertize ement-room-url-preview-prefix
'face 'ement-room-preview)))
(propertize (buffer-string)
'line-prefix prefix
'wrap-prefix prefix))))

;; NOTE: This function is not useful when displaynames are shown in the margin, because
;; margins are not mouse-interactive in Emacs, therefore the help-echo function is called
;; with the string and the position in the string, which leaves the buffer position
Expand Down