From b167fc6a8a97eef6555160be1584a55f7031382c Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Mon, 20 Jan 2025 09:50:11 +1100 Subject: [emacs] Rename mastorg to fediorg Now that the package handles fedi posts in general, it no longer makes sense to use mastodon-specific naming. Also updated ytdl infobox formatting chapters and removal of extra queries in urls --- emacs/.emacs.d/init/ycp-web.el | 6 +- emacs/.emacs.d/lisp/my/fediorg.el | 367 ++++++++++++++++++++++++++++++++++++++ emacs/.emacs.d/lisp/my/mastorg.el | 356 ------------------------------------ emacs/.emacs.d/lisp/my/my-web.el | 8 - emacs/.emacs.d/lisp/my/my-ytdl.el | 27 ++- 5 files changed, 395 insertions(+), 369 deletions(-) create mode 100644 emacs/.emacs.d/lisp/my/fediorg.el delete mode 100644 emacs/.emacs.d/lisp/my/mastorg.el (limited to 'emacs/.emacs.d') diff --git a/emacs/.emacs.d/init/ycp-web.el b/emacs/.emacs.d/init/ycp-web.el index 6083b35..3c033ad 100644 --- a/emacs/.emacs.d/init/ycp-web.el +++ b/emacs/.emacs.d/init/ycp-web.el @@ -335,12 +335,12 @@ (add-hook 'mastodon-toot-mode-hook (lambda () (turn-off-auto-fill))) (mastodon)) -(my-package mastorg +(my-package fediorg (:delay 60) (require 'my-web) (add-to-list 'browse-url-handlers - `(my-mastodon-url-p - . ,(lambda (url &rest _) (mastorg-open url)))) + `(fediorg-post-url-p + . ,(lambda (url &rest _) (fediorg-open url)))) ) (add-to-list 'load-path (locate-user-emacs-file "lisp/servall/lisp")) diff --git a/emacs/.emacs.d/lisp/my/fediorg.el b/emacs/.emacs.d/lisp/my/fediorg.el new file mode 100644 index 0000000..123545b --- /dev/null +++ b/emacs/.emacs.d/lisp/my/fediorg.el @@ -0,0 +1,367 @@ +;;; fediorg.el -- Read and archive fedi post context in org mode -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Yuchen Pei +;; Package-Requires: ((emacs "28.2")) + +;; This file is part of dotted. + +;; dotted is free software: you can redistribute it and/or modify it under +;; the terms of the GNU Affero General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; dotted is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General +;; Public License for more details. + +;; You should have received a copy of the GNU Affero General Public +;; License along with dotted. If not, see . + +;;; Commentary: + +;; Read or archive a fedi thread context in org mode. This is a +;; standalone library, and can be used without any other files in this +;; project. + +;; Usage: +;; M-x fediorg-open https://pleroma.instance/notice/... +;; M-x fediorg-open https://mastodon.instance/@user/... +;; +;; The post, together with its ancestors and descendants, subject to +;; the API depth limit, are displayed in an org buffer. + +;; TODO: +;; +;; To be able to refresh the org buffer at an org entry, which would +;; re-fetch the context of the corresponding post and upsert them in +;; the buffer. +;;; Code: + + +(require 'hierarchy) +(require 'json) +(require 'url-parse) + +(defvar fediorg-buffer "*fediorg*" "Buffer name for fediorg buffers.") + +;;; Fetching utilities +(defvar fediorg-client-buffer-name "*fediorg-api*" + "Buffer name for logging API requests.") + +(defun fediorg-url-fetch-json (url &optional decompression with-header) + "Fetch and parse json from URL. + +With nonnil DECOMPRESSION, gunzip the response first. +With nonnil WITH-HEADER, include the response headers in the return value." + (fediorg-url-fetch-internal + url + (lambda () + (json-read-from-string (decode-coding-string (buffer-string) 'utf-8))) + decompression + with-header)) + +(defun fediorg-url-fetch-internal (url buffer-processor decompression with-header) + "Fetch from URL and process the response with BUFFER-PROCESSOR. + +With nonnil DECOMPRESSION, gunzip the response first. +With nonnil WITH-HEADER, include the response headers in the return value." + (with-current-buffer (get-buffer-create fediorg-client-buffer-name) + (goto-char (point-max)) + (insert "[" (current-time-string) "] Request: " url "\n")) + (with-current-buffer (url-retrieve-synchronously url t) + (let ((header (fediorg-kill-http-header)) (status) (fields)) + (goto-char (point-min)) + (setq header (fediorg-parse-http-header header) + status (alist-get 'status header) + fields (alist-get 'fields header)) + (with-current-buffer fediorg-client-buffer-name + (insert "[" (current-time-string) "] Response: " status "\n")) + (when decompression + (call-process-region (point) (point-max) "gunzip" t t t) + (goto-char (point-min))) + (call-interactively 'delete-trailing-whitespace) + (if (string= status "200") + (unless (= (point) (point-max)) + (if with-header + (list + (cons 'header fields) + (cons 'json (funcall buffer-processor))) + (funcall buffer-processor))) + (error "HTTP error: %s" (buffer-substring (point) (point-max))))))) + +(defun fediorg-kill-http-header () + "Kill http headers in the current buffer." + (fediorg-skip-http-header) + (let ((killed (buffer-substring-no-properties (point-min) (point)))) + (delete-region (point-min) (point)) + killed)) + +(defun fediorg-skip-http-header () + "Skip http headers in the current buffer." + (goto-char (point-min)) + (re-search-forward "\r?\n\r?\n")) + +(defun fediorg-parse-http-header (text) + "Parse http headers from TEXT in the current buffer." + (let ((status) (fields)) + (with-temp-buffer + (insert text) + (goto-char (point-min)) + (re-search-forward "^HTTP.*\\([0-9]\\{3\\}\\).*$") + (setq status (match-string 1)) + (while (re-search-forward "^\\(.*?\\): \\(.*\\)$" nil t) + (push (cons (intern (match-string 1)) (match-string 2)) fields))) + (list (cons 'status status) (cons 'fields fields)))) + +;;; utilities +(defun fediorg-api-search (host url) + (fediorg-url-fetch-json + (format "https://%s/api/v2/search/?q=%s&resolve=true" host url))) + +(defun fediorg-canonical-post-url-by-search (host url) + (let-alist (fediorg-api-search host url) + (if (seq-empty-p .statuses) + (error "No statuses associated with URL %s" url) + (fediorg-canonical-post-url (alist-get 'url (elt .statuses 0)) t)))) + +(defun fediorg-post-url-p (url &optional no-fetch) + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj)) + (host (url-host urlobj))) + (or (string-match-p "^/objects/[-a-f0-9]+$" path) + (string-match-p + "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" path) + (string-match-p "^/@[^/]+/\\([0-9]+\\)$" path) + (string-match-p "^/notice/\\([[:alnum:]]+\\)$" path)))) + +(defun fediorg-canonical-post-url (url &optional no-fetch) + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj)) + (host (url-host urlobj))) + (cond ((or (string-match-p "^/objects/[-a-f0-9]+$" path) + (string-match-p + "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" path)) + (unless no-fetch (fediorg-canonical-post-url-by-search host url))) + ((or (string-match-p "^/@[^/]+/\\([0-9]+\\)$" path) + (string-match-p "^/notice/\\([[:alnum:]]+\\)$" path)) + url) + (t (error "Unrecognisable URL: %s" url))))) + +(defun fediorg-parse-url (url) + "Parse fedi post URL." + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj)) + (host (url-host urlobj))) + (cons host (caddr (split-string path "/"))))) + +(defun fediorg-api-status (url) + "Get the status given URL." + (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url))) + (fediorg-url-fetch-json + (format "https://%s/api/v1/statuses/%s" host post-id)))) + +(defun fediorg-api-status-context (url) + "Get the status context given URL." + (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url))) + (fediorg-url-fetch-json + (format "https://%s/api/v1/statuses/%s/context" host post-id)))) + +(defun fediorg-get-first-ancestor (url) + "Given a fedi post URL, return the url of its first ancestor." + (let ((ancestors + (alist-get 'ancestors (fediorg-api-status-context url)))) + (if (length> ancestors 0) + (alist-get 'url (elt ancestors 0)) + url))) + +(defun fediorg-post-make-parent-fn (posts) + "Given a collection of POSTS, return a function that find the parent post." + (lambda (post) + (let ((id (alist-get 'in_reply_to_id post))) + (seq-find + (lambda (candidate) + (equal (alist-get 'id candidate) id)) + posts)))) + +;;; Formatting functions +(defun fediorg-format-post-tree (url) + "Format a post tree of post located at URL. + +Including ancestors and descendants, if any." + (let* ((posts-hier (hierarchy-new)) + (context-posts (fediorg-api-status-context url)) + (posts (vconcat + (alist-get 'ancestors context-posts) + (vector (fediorg-api-status url)) + (alist-get 'descendants context-posts)))) + (hierarchy-add-trees + posts-hier + posts + (fediorg-post-make-parent-fn posts)) + (string-join + (hierarchy-map 'fediorg-format-post posts-hier 1) + "\n"))) + +(defun fediorg-make-org-link (link desc) + (format "[[%s][%s]]" link desc)) + +(defun fediorg-format-attached (attachments host) + (mapconcat + (lambda (attachment) + (let-alist attachment + (with-temp-buffer + (insert + (fediorg-make-org-link .url .type)) + (if .description + (insert ": " .description)) + (when .preview_url + (let ((thumb-file-name + (file-name-concat + fediorg-dir + (format "%s.%s.%s" host .id + (file-name-extension .preview_url))))) + (ignore-error 'file-already-exists + (url-copy-file .preview_url thumb-file-name)) + (insert "\n") + (insert-image (create-image thumb-file-name)) + )) + (buffer-string)))) + attachments + "\n")) + +(defun fediorg-format-post (post level) + "Format a POST with indent LEVEL." + (let-alist post + (let ((host (car (fediorg-parse-url .url)))) + (format "%s %s (@%s@%s) %s\n\n%s%s\n\n⤷%d ⇆%d ★%d\n" + (make-string level ?*) + (if (string-empty-p .account.display_name) + .account.username .account.display_name) + .account.username + host + (fediorg-make-org-link + .url + (fediorg--relative-time-description .created_at)) + (with-temp-buffer + (insert .content) + (shr-render-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) (point-max))) + (fediorg-format-attached .media_attachments host) + .replies_count + .reblogs_count + .favourites_count)))) + +(defun fediorg-save-text-and-switch-to-buffer (text file-name) + "Save TEXT to FILE-NAME and switch to buffer." + (let ((buffer (find-file-noselect file-name)) + (coding-system-for-write 'utf-8)) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert text)) + (goto-char (point-min)) + (save-buffer) + (revert-buffer t t)) + (switch-to-buffer buffer))) + +(defvar fediorg-dir (locate-user-emacs-file "fediorg") + "Path to local directory of saved threads.") + +(defun fediorg-make-post-file-name (url) + (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url))) + (format "%s.%s.org" host post-id))) + +;;;###autoload +(defun fediorg-open (url) + "Given a fedi post URL, open an org buffer rendering the post. + +Including the context, i.e. ancestors and descendant posts." + (interactive "sPost URL: ") + (setq url (fediorg-canonical-post-url url)) + (fediorg-save-text-and-switch-to-buffer + (fediorg-format-post-tree url) + (file-name-concat fediorg-dir (fediorg-make-post-file-name url)))) + +;;; code adapted from mastodon.el +(defun fediorg--human-duration (seconds &optional resolution) + "Return a string describing SECONDS in a more human-friendly way. +The return format is (STRING . RES) where RES is the resolution of +this string, in seconds. +RESOLUTION is the finest resolution, in seconds, to use for the +second part of the output (defaults to 60, so that seconds are only +displayed when the duration is smaller than a minute)." + (cl-assert (>= seconds 0)) + (unless resolution (setq resolution 60)) + (let* ((units fediorg--time-units) + (n1 seconds) (unit1 (pop units)) (res1 1) + n2 unit2 res2 + next) + (while (and units (> (truncate (setq next (/ n1 (car units)))) 0)) + (setq unit2 unit1) + (setq res2 res1) + (setq n2 (- n1 (* (car units) (truncate n1 (car units))))) + (setq n1 next) + (setq res1 (truncate (* res1 (car units)))) + (pop units) + (setq unit1 (pop units))) + (setq n1 (truncate n1)) + (if n2 (setq n2 (truncate n2))) + (cond + ((null n2) + ;; revert to old just now style for < 1 min: + (cons "just now" 60)) + ;; (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) + ;; (max resolution res1))) + ((< (* res2 n2) resolution) + (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) + (max resolution res2))) + ((< res2 resolution) + (let ((n2 (/ (* resolution (/ (* n2 res2) resolution)) res2))) + (cons (format "%d %s%s, %d %s%s" + n1 unit1 (if (> n1 1) "s" "") + n2 unit2 (if (> n2 1) "s" "")) + resolution))) + (t + (cons (format "%d %s%s, %d %s%s" + n1 unit1 (if (> n1 1) "s" "") + n2 unit2 (if (> n2 1) "s" "")) + (max res2 resolution)))))) + +(defconst fediorg--time-units + '("sec" 60.0 ;; Use a float to convert `n' to float. + "min" 60 + "hour" 24 + "day" 7 + "week" 4.345 + "month" 12 + "year")) + +(defun fediorg--relative-time-details (timestamp &optional current-time) + "Return cons of (DESCRIPTIVE STRING . NEXT-CHANGE) for the TIMESTAMP. +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). +The descriptive string is a human readable version relative to +the current time while the next change timestamp give the first +time that this description will change in the future. +TIMESTAMP is assumed to be in the past." + (let* ((time-difference (time-subtract current-time timestamp)) + (seconds-difference (float-time time-difference)) + (tmp (fediorg--human-duration (max 0 seconds-difference)))) + ;; revert to old just now style for < 1 min + (cons (concat (car tmp) (if (string= "just now" (car tmp)) "" " ago")) + (time-add current-time (cdr tmp))))) + +(defun fediorg--relative-time-description (time-string &optional current-time) + "Return a string with a human readable TIME-STRING relative to the current time. +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). +E.g. this could return something like \"1 min ago\", \"yesterday\", etc. +TIME-STAMP is assumed to be in the past." + (car (fediorg--relative-time-details + (encode-time (parse-time-string time-string)) current-time))) + +(provide 'fediorg) +;;; fediorg.el ends here diff --git a/emacs/.emacs.d/lisp/my/mastorg.el b/emacs/.emacs.d/lisp/my/mastorg.el deleted file mode 100644 index d0db3a0..0000000 --- a/emacs/.emacs.d/lisp/my/mastorg.el +++ /dev/null @@ -1,356 +0,0 @@ -;;; mastorg.el -- Read or archive mastodon toot context in org mode -*- lexical-binding: t -*- - -;; Copyright (C) 2023 Free Software Foundation, Inc. - -;; Author: Yuchen Pei -;; Package-Requires: ((emacs "28.2")) - -;; This file is part of dotted. - -;; dotted is free software: you can redistribute it and/or modify it under -;; the terms of the GNU Affero General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; dotted is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General -;; Public License for more details. - -;; You should have received a copy of the GNU Affero General Public -;; License along with dotted. If not, see . - -;;; Commentary: - -;; Read or archive mastodon toot context in org mode. This is a -;; standalone library, and can be used without any other files in this -;; project. - -;; Usage: -;; M-x mastorg-open https://mastodon.instance/@user/12345678901234 -;; -;; The toot, together with its ancestors and descendants, subject to -;; mastodon API depth limit, are displayed in an org buffer. - -;; TODO: -;; -;; To be able to refresh the org buffer at an org entry, which would -;; re-fetch the context of the corresponding toot and upsert them in -;; the buffer. -;;; Code: - - -(require 'hierarchy) -(require 'json) -(require 'url-parse) - -(defvar mastorg-buffer "*mastorg*" "Buffer name for mastorg buffers.") - -;;; Fetching utilities -(defvar mastorg-client-buffer-name "*mastorg-api*" - "Buffer name for logging API requests.") - -(defun mastorg-url-fetch-json (url &optional decompression with-header) - "Fetch and parse json from URL. - -With nonnil DECOMPRESSION, gunzip the response first. -With nonnil WITH-HEADER, include the response headers in the return value." - (mastorg-url-fetch-internal - url - (lambda () - (json-read-from-string (decode-coding-string (buffer-string) 'utf-8))) - decompression - with-header)) - -(defun mastorg-url-fetch-internal (url buffer-processor decompression with-header) - "Fetch from URL and process the response with BUFFER-PROCESSOR. - -With nonnil DECOMPRESSION, gunzip the response first. -With nonnil WITH-HEADER, include the response headers in the return value." - (with-current-buffer (get-buffer-create mastorg-client-buffer-name) - (goto-char (point-max)) - (insert "[" (current-time-string) "] Request: " url "\n")) - (with-current-buffer (url-retrieve-synchronously url t) - (let ((header (mastorg-kill-http-header)) (status) (fields)) - (goto-char (point-min)) - (setq header (mastorg-parse-http-header header) - status (alist-get 'status header) - fields (alist-get 'fields header)) - (with-current-buffer mastorg-client-buffer-name - (insert "[" (current-time-string) "] Response: " status "\n")) - (when decompression - (call-process-region (point) (point-max) "gunzip" t t t) - (goto-char (point-min))) - (call-interactively 'delete-trailing-whitespace) - (if (string= status "200") - (unless (= (point) (point-max)) - (if with-header - (list - (cons 'header fields) - (cons 'json (funcall buffer-processor))) - (funcall buffer-processor))) - (error "HTTP error: %s" (buffer-substring (point) (point-max))))))) - -(defun mastorg-kill-http-header () - "Kill http headers in the current buffer." - (mastorg-skip-http-header) - (let ((killed (buffer-substring-no-properties (point-min) (point)))) - (delete-region (point-min) (point)) - killed)) - -(defun mastorg-skip-http-header () - "Skip http headers in the current buffer." - (goto-char (point-min)) - (re-search-forward "\r?\n\r?\n")) - -(defun mastorg-parse-http-header (text) - "Parse http headers from TEXT in the current buffer." - (let ((status) (fields)) - (with-temp-buffer - (insert text) - (goto-char (point-min)) - (re-search-forward "^HTTP.*\\([0-9]\\{3\\}\\).*$") - (setq status (match-string 1)) - (while (re-search-forward "^\\(.*?\\): \\(.*\\)$" nil t) - (push (cons (intern (match-string 1)) (match-string 2)) fields))) - (list (cons 'status status) (cons 'fields fields)))) - -;;; mastodon utilities -(defun mastorg-api-search (host url) - (mastorg-url-fetch-json - (format "https://%s/api/v2/search/?q=%s&resolve=true" host url))) - -(defun mastorg-canonical-post-url-by-search (host url) - (let-alist (mastorg-api-search host url) - (if (seq-empty-p .statuses) - (error "No statuses associated with URL %s" url) - (mastorg-canonical-post-url (alist-get 'url (elt .statuses 0)) t)))) - -(defun mastorg-canonical-post-url (url &optional no-fetch) - (pcase-let* ((urlobj (url-generic-parse-url url)) - (`(,path . _) (url-path-and-query urlobj)) - (host (url-host urlobj))) - (cond ((or (string-match-p "^/objects/[-a-f0-9]+$" path) - (string-match-p - "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" path)) - (unless no-fetch (mastorg-canonical-post-url-by-search host url))) - ((or (string-match-p "^/@[^/]+/\\([0-9]+\\)$" path) - (string-match-p "^/notice/\\([[:alnum:]]+\\)$" path)) - url) - (t (error "Unrecognisable URL: %s" url))))) - -(defun mastorg-parse-url (url) - "Parse mastodon post URL." - (pcase-let* ((urlobj (url-generic-parse-url url)) - (`(,path . _) (url-path-and-query urlobj)) - (host (url-host urlobj))) - (cons host (caddr (split-string path "/"))))) - -(defun mastorg-api-status (url) - "Get the status given URL." - (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url))) - (mastorg-url-fetch-json - (format "https://%s/api/v1/statuses/%s" host post-id)))) - -(defun mastorg-api-status-context (url) - "Get the status context given URL." - (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url))) - (mastorg-url-fetch-json - (format "https://%s/api/v1/statuses/%s/context" host post-id)))) - -(defun mastorg-get-first-ancestor (url) - "Given a mastodon URL, return the url of its first ancestor." - (let ((ancestors - (alist-get 'ancestors (mastorg-api-status-context url)))) - (if (length> ancestors 0) - (alist-get 'url (elt ancestors 0)) - url))) - -(defun mastorg-toot-make-parent-fn (toots) - "Given a collection of TOOTS, return a function that find the parent toot." - (lambda (toot) - (let ((id (alist-get 'in_reply_to_id toot))) - (seq-find - (lambda (candidate) - (equal (alist-get 'id candidate) id)) - toots)))) - -;;; Formatting functions -(defun mastorg-format-toot-tree (url) - "Format a toot tree of toot located at URL. - -Including ancestors and descendants, if any." - (let* ((toots-hier (hierarchy-new)) - (context-toots (mastorg-api-status-context url)) - (toots (vconcat - (alist-get 'ancestors context-toots) - (vector (mastorg-api-status url)) - (alist-get 'descendants context-toots)))) - (hierarchy-add-trees - toots-hier - toots - (mastorg-toot-make-parent-fn toots)) - (string-join - (hierarchy-map 'mastorg-format-toot toots-hier 1) - "\n"))) - -(defun mastorg-make-org-link (link desc) - (format "[[%s][%s]]" link desc)) - -(defun mastorg-format-attached (attachments host) - (mapconcat - (lambda (attachment) - (let-alist attachment - (with-temp-buffer - (insert - (mastorg-make-org-link .url .type)) - (if .description - (insert ": " .description)) - (when .preview_url - (let ((thumb-file-name - (file-name-concat - mastorg-dir - (format "%s.%s.%s" host .id - (file-name-extension .preview_url))))) - (ignore-error 'file-already-exists - (url-copy-file .preview_url thumb-file-name)) - (insert "\n") - (insert-image (create-image thumb-file-name)) - )) - (buffer-string)))) - attachments - "\n")) - -(defun mastorg-format-toot (toot level) - "Format a TOOT with indent LEVEL." - (let-alist toot - (let ((host (car (mastorg-parse-url .url)))) - (format "%s %s (@%s@%s) %s\n\n%s%s\n\n⤷%d ⇆%d ★%d\n" - (make-string level ?*) - (if (string-empty-p .account.display_name) - .account.username .account.display_name) - .account.username - host - (mastorg-make-org-link - .url - (mastorg--relative-time-description .created_at)) - (with-temp-buffer - (insert .content) - (shr-render-region (point-min) (point-max)) - (buffer-substring-no-properties (point-min) (point-max))) - (mastorg-format-attached .media_attachments host) - .replies_count - .reblogs_count - .favourites_count)))) - -(defun mastorg-save-text-and-switch-to-buffer (text file-name) - "Save TEXT to FILE-NAME and switch to buffer." - (let ((buffer (find-file-noselect file-name)) - (coding-system-for-write 'utf-8)) - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (erase-buffer) - (insert text)) - (goto-char (point-min)) - (save-buffer) - (revert-buffer t t)) - (switch-to-buffer buffer))) - -(defvar mastorg-dir (locate-user-emacs-file "mastorg") - "Path to local directory of saved threads.") - -(defun mastorg-make-filename (url) - (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url))) - (format "%s.%s.org" host post-id))) - -;;;###autoload -(defun mastorg-open (url) - "Given a mastodon toot URL, open an org buffer rendering the toot. - -Including the context, i.e. ancestors and descendant toots." - (interactive "sToot URL: ") - (setq url (mastorg-canonical-post-url url)) - (mastorg-save-text-and-switch-to-buffer - (mastorg-format-toot-tree url) - (file-name-concat mastorg-dir (mastorg-make-filename url)))) - -;;; code adapted from mastodon.el -(defun mastorg--human-duration (seconds &optional resolution) - "Return a string describing SECONDS in a more human-friendly way. -The return format is (STRING . RES) where RES is the resolution of -this string, in seconds. -RESOLUTION is the finest resolution, in seconds, to use for the -second part of the output (defaults to 60, so that seconds are only -displayed when the duration is smaller than a minute)." - (cl-assert (>= seconds 0)) - (unless resolution (setq resolution 60)) - (let* ((units mastorg--time-units) - (n1 seconds) (unit1 (pop units)) (res1 1) - n2 unit2 res2 - next) - (while (and units (> (truncate (setq next (/ n1 (car units)))) 0)) - (setq unit2 unit1) - (setq res2 res1) - (setq n2 (- n1 (* (car units) (truncate n1 (car units))))) - (setq n1 next) - (setq res1 (truncate (* res1 (car units)))) - (pop units) - (setq unit1 (pop units))) - (setq n1 (truncate n1)) - (if n2 (setq n2 (truncate n2))) - (cond - ((null n2) - ;; revert to old just now style for < 1 min: - (cons "just now" 60)) - ;; (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) - ;; (max resolution res1))) - ((< (* res2 n2) resolution) - (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) - (max resolution res2))) - ((< res2 resolution) - (let ((n2 (/ (* resolution (/ (* n2 res2) resolution)) res2))) - (cons (format "%d %s%s, %d %s%s" - n1 unit1 (if (> n1 1) "s" "") - n2 unit2 (if (> n2 1) "s" "")) - resolution))) - (t - (cons (format "%d %s%s, %d %s%s" - n1 unit1 (if (> n1 1) "s" "") - n2 unit2 (if (> n2 1) "s" "")) - (max res2 resolution)))))) - -(defconst mastorg--time-units - '("sec" 60.0 ;; Use a float to convert `n' to float. - "min" 60 - "hour" 24 - "day" 7 - "week" 4.345 - "month" 12 - "year")) - -(defun mastorg--relative-time-details (timestamp &optional current-time) - "Return cons of (DESCRIPTIVE STRING . NEXT-CHANGE) for the TIMESTAMP. -Use the optional CURRENT-TIME as the current time (only used for -reliable testing). -The descriptive string is a human readable version relative to -the current time while the next change timestamp give the first -time that this description will change in the future. -TIMESTAMP is assumed to be in the past." - (let* ((time-difference (time-subtract current-time timestamp)) - (seconds-difference (float-time time-difference)) - (tmp (mastorg--human-duration (max 0 seconds-difference)))) - ;; revert to old just now style for < 1 min - (cons (concat (car tmp) (if (string= "just now" (car tmp)) "" " ago")) - (time-add current-time (cdr tmp))))) - -(defun mastorg--relative-time-description (time-string &optional current-time) - "Return a string with a human readable TIME-STRING relative to the current time. -Use the optional CURRENT-TIME as the current time (only used for -reliable testing). -E.g. this could return something like \"1 min ago\", \"yesterday\", etc. -TIME-STAMP is assumed to be in the past." - (car (mastorg--relative-time-details - (encode-time (parse-time-string time-string)) current-time))) - -(provide 'mastorg) -;;; mastorg.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-web.el b/emacs/.emacs.d/lisp/my/my-web.el index 6c3cd92..aeb5a6d 100644 --- a/emacs/.emacs.d/lisp/my/my-web.el +++ b/emacs/.emacs.d/lisp/my/my-web.el @@ -164,14 +164,6 @@ Useful for bypassing some paywalls." (require 'hmm) (defvar my-url-context-function 'hmm-url "Context function for urls.") -(defun my-mastodon-url-p (url) - "Guess if a url is a mastodon post. -e.g. https://hostux.social/@fsf/113709722998924141 -" - (pcase-let* ((urlobj (url-generic-parse-url url)) - (`(,path . _) (url-path-and-query urlobj))) - (string-match-p "^/@[^/]+/[0-9]\\{18\\}$" path))) - (defun my-hacker-news-url-p (url) "Check if a url is a hacker news post. e.g. https://news.ycombinator.com/item?id=42505454" diff --git a/emacs/.emacs.d/lisp/my/my-ytdl.el b/emacs/.emacs.d/lisp/my/my-ytdl.el index bf917ce..b3b1cf7 100644 --- a/emacs/.emacs.d/lisp/my/my-ytdl.el +++ b/emacs/.emacs.d/lisp/my/my-ytdl.el @@ -90,13 +90,32 @@ (defun my-ytdl-video-url-p (url) (let ((urlobj (url-generic-parse-url url))) - (or (and (string-match-p "^\\(www\\.\\)?youtube.com" (url-host urlobj)) + (or (and (string-match-p + "^\\(www\\.\\)?\\(youtube\\.com\\|yewtu\\.be\\)" + (url-host urlobj)) (string-match-p "^/watch\\?v=.*" (url-filename urlobj))) (equal "youtu.be" (url-host urlobj))))) (require 'hmm) (defvar my-ytdl-player 'hmm-external-mpv "Function to play ytdl urls.") +(defun my-ytdl-video-format-seconds (secs) + (setq secs (floor secs)) + (if (>= secs 3600) + (format "%d:%02d:%02d" + (/ secs 3600) (/ (% secs 3600) 60) (% secs 60)) + (format "%d:%02d" + (/ secs 60) (% secs 60)))) + +(defun my-ytdl-video-format-chapters (chapters) + (mapconcat + (lambda (chapter) + (let-alist chapter + (format "%s: %s-%s" .title (my-ytdl-video-format-seconds .start_time) + (my-ytdl-video-format-seconds .end_time)))) + chapters + "; ")) + (defun my-ytdl-video-render-info (info url) (setf (alist-get 'webpage_url info) (concat (alist-get 'webpage_url info) @@ -104,7 +123,9 @@ (funcall my-ytdl-player url))) " " (buttonize "context" (lambda (_) - (funcall my-url-context-function url))))) + (funcall my-url-context-function url)))) + (alist-get 'chapters info) + (my-ytdl-video-format-chapters (alist-get 'chapters info))) (infobox-render (infobox-translate info (infobox-default-specs info)) `(my-ytdl-video-infobox ,url) @@ -112,6 +133,8 @@ (defun my-ytdl-video-infobox (url) (interactive "sytdl video url: ") + ;; Remove any extra queries from the URL + (setq url (replace-regexp-in-string "&.*" "" url)) (my-ytdl-video-render-info (my-ytdl-video-info url) url)) ;;; fixme: autoload -- cgit v1.2.3