From 6067d464cc05386fc0e9985178df46761c66a7f3 Mon Sep 17 00:00:00 2001 From: Cytrogen Date: Wed, 11 Mar 2026 16:47:29 -0400 Subject: [PATCH] =?UTF-8?q?=E5=88=9D=E5=A7=8B=E5=8F=91=E5=B8=83=EF=BC=9Awe?= =?UTF-8?q?bmention.el=20v0.1.0?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 从 Emacs 发送 Webmention（W3C 推荐标准）。 包含发现、直接发送、历史记录和 staging buffer 功能。 --- README.org | 123 +++++ docs/README.org | 123 +++++ webmention.el | 1324 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1570 insertions(+) create mode 100644 README.org create mode 100644 docs/README.org create mode 100644 webmention.el diff --git a/README.org b/README.org new file mode 100644 index 0000000000000000000000000000000000000000..e8269989f4544a644cb4db96e405bf55c36d53fb --- /dev/null +++ b/README.org @@ -0,0 +1,123 @@ +#+title: webmention.el +#+author: Cytrogen +#+language: zh-CN + +从 Emacs 发送 [[https://www.w3.org/TR/webmention/][Webmention]]（W3C 推荐标准）。 + +Emacs 28.1+ | GPLv3 | v0.1.0 + +[[file:docs/README.org][English]] + +* 功能 + +- =webmention-discover= — 抓取文章页面，提取外链，发现 Webmention 端点，打开 staging buffer 供你选择发送 +- =webmention-send-url= — 直接发送单条 Webmention（指定 source 和 target） +- =webmention-show-history= — 查看历史发送记录 + +* 安装 + +** 手动安装 + +#+begin_src shell +git clone https://git.cytrogen.icu/~cytrogen/webmention.el ~/.emacs.d/webmention +#+end_src + +#+begin_src emacs-lisp +(add-to-list 'load-path "~/.emacs.d/webmention") +(require 'webmention) +#+end_src + +** use-package + +#+begin_src emacs-lisp +(use-package webmention + :load-path "~/.emacs.d/webmention" + :commands (webmention-discover webmention-send-url webmention-show-history) + :bind (("C-c w d" . webmention-discover) + ("C-c w s" . webmention-send-url) + ("C-c w h" . webmention-show-history))) +#+end_src + +快捷键仅作参考，请根据自己的配置调整。 + +* 使用 + +** 发现并发送（webmention-discover） + +这是最常用的入口。典型场景：你发布了一篇博客文章，文中引用了其他站点，想通知它们。 + +1. =M-x webmention-discover=（或你绑定的快捷键） +2. 输入你的文章 URL（如果光标下有 URL、Org 属性 =WEBMENTION_URL= 或剪贴板中有 URL，会自动作为默认值） +3. 程序抓取页面，提取所有外链，并发现哪些支持 Webmention +4. 弹出 staging buffer，按分类列出所有链接 + +*** Staging Buffer 操作 + +| 按键 | 操作 | +|-------+------------------| +| =m= | 标记当前目标 | +| =u= | 取消标记 | +| =M= | 全部标记 | +| =U= | 全部取消标记 | +| =s= / =RET= | 发送已标记的目标 | +| =g= | 刷新（重新发现） | +| =n= | 下一个目标 | +| =p= | 上一个目标 | +| =q= | 退出 | + +Staging buffer 会将链接分为以下几组： + +- *Targets with endpoints* — 支持 Webmention 的目标，可标记发送 +- *Sent* — 已成功发送 +- *Discovering* — 正在发现端点 +- *No endpoint* — 不支持 Webmention +- *Skipped (internal)* — 同域名链接，已自动跳过 +- *Errors* — 发现过程中出错 + +** 直接发送（webmention-send-url） + +如果你已经知道要通知哪个页面： + +1. =M-x webmention-send-url= +2. 输入 Source URL（你的文章）和 Target URL（对方页面） +3. 自动发现端点并发送 + +适合脚本化或只需通知单个目标的场景。 + +** 查看历史（webmention-show-history） + +=M-x webmention-show-history= 打开历史记录 buffer，按时间倒序显示所有发送过的 Webmention，包括状态码和时间戳。 + +历史记录保存在 =~/.emacs.d/webmention-history.eld=。 + +* 自定义 + +所有变量均可通过 =M-x customize-group RET webmention= 配置。 + +| 变量 | 默认值 | 说明 | +|---------------------------------------+--------------------------------+--------------------------------------------| +| =webmention-user-agent= | ="Emacs-Webmention/0.1"= | HTTP 请求的 User-Agent 字符串 | +| =webmention-timeout= | =30= | HTTP 请求超时（秒） | +| =webmention-max-concurrent-requests= | =4= | 端点发现的最大并发数 | +| =webmention-history-file= | =~/.emacs.d/webmention-history.eld= | 历史记录文件路径 | +| =webmention-skip-internal-links= | =t= | 是否跳过同域名链接 | +| =webmention-confirm-resend= | =t= | 重复发送时是否确认 | +| =webmention-max-response-size= | =1048576= (1 MB) | 最大响应体大小（字节），超出则截断 | +| =webmention-history-max-entries= | =500= | 历史记录最大条数，超出则清理最旧的 | +| =webmention-max-retries= | =2= | 瞬态错误（5xx、超时）的重试次数，0 禁用 | +| =webmention-debug= | =nil= | 启用后将日志写入 =*Webmention Log*= buffer | + +* 什么是 Webmention？ + +[[https://www.w3.org/TR/webmention/][Webmention]] 是 W3C 推荐的 Web 标准协议。当你的文章链接了另一个站点时，可以通过 Webmention 通知对方"我提到了你"。 + +它是 Pingback 的现代替代方案，广泛用于 [[https://indieweb.org/][IndieWeb]] 社区。支持 Webmention 的站点会在页面中声明一个端点（通过 HTTP Link header 或 HTML == 标签），接收方可以据此展示评论、点赞、转发等互动信息。 + +适用场景： +- 独立博客之间的互相通知 +- 跨站评论和互动 +- 去中心化的社交网络交互 + +* 许可证 + +GPLv3。详见 [[https://www.gnu.org/licenses/gpl-3.0.html][GNU General Public License v3.0]]。 diff --git a/docs/README.org b/docs/README.org new file mode 100644 index 0000000000000000000000000000000000000000..ac5fcc2f944de58ca876add80aeb2cb9c7ca1417 --- /dev/null +++ b/docs/README.org @@ -0,0 +1,123 @@ +#+title: webmention.el +#+author: Cytrogen +#+language: en + +Send [[https://www.w3.org/TR/webmention/][Webmentions]] (W3C Recommendation) from Emacs. + +Emacs 28.1+ | GPLv3 | v0.1.0 + +[[file:../README.org][中文]] + +* Features + +- =webmention-discover= — Fetch a page, extract outbound links, discover Webmention endpoints, and open a staging buffer for selective sending +- =webmention-send-url= — Send a single Webmention directly (given source and target URLs) +- =webmention-show-history= — View previously sent Webmentions + +* Installation + +** Manual + +#+begin_src shell +git clone https://git.cytrogen.icu/~cytrogen/webmention.el ~/.emacs.d/webmention +#+end_src + +#+begin_src emacs-lisp +(add-to-list 'load-path "~/.emacs.d/webmention") +(require 'webmention) +#+end_src + +** use-package + +#+begin_src emacs-lisp +(use-package webmention + :load-path "~/.emacs.d/webmention" + :commands (webmention-discover webmention-send-url webmention-show-history) + :bind (("C-c w d" . webmention-discover) + ("C-c w s" . webmention-send-url) + ("C-c w h" . webmention-show-history))) +#+end_src + +Keybindings are suggestions only — adjust to your preference. + +* Usage + +** Discover & Send (webmention-discover) + +The primary entry point. Typical scenario: you published a blog post that links to other sites and want to notify them. + +1. =M-x webmention-discover= (or your bound key) +2. Enter your article URL (defaults to URL at point, the Org =WEBMENTION_URL= property, or a URL in the kill ring) +3. The package fetches the page, extracts all outbound links, and discovers which support Webmention +4. A staging buffer opens with links grouped by category + +*** Staging Buffer Keys + +| Key | Action | +|-------+-----------------------| +| =m= | Mark target | +| =u= | Unmark target | +| =M= | Mark all | +| =U= | Unmark all | +| =s= / =RET= | Send marked targets | +| =g= | Refresh (re-discover) | +| =n= | Next target | +| =p= | Previous target | +| =q= | Quit | + +The staging buffer groups links into sections: + +- *Targets with endpoints* — Webmention-capable targets, ready to mark and send +- *Sent* — Successfully sent +- *Discovering* — Endpoint discovery in progress +- *No endpoint* — Target does not support Webmention +- *Skipped (internal)* — Same-domain links, automatically skipped +- *Errors* — Discovery failed + +** Direct Send (webmention-send-url) + +When you already know the exact target: + +1. =M-x webmention-send-url= +2. Enter the Source URL (your article) and Target URL (their page) +3. The endpoint is discovered and the Webmention is sent automatically + +Useful for scripting or notifying a single target. + +** View History (webmention-show-history) + +=M-x webmention-show-history= opens a buffer listing all previously sent Webmentions in reverse chronological order, including HTTP status codes and timestamps. + +History is stored in =~/.emacs.d/webmention-history.eld=. + +* Customization + +All variables can be configured via =M-x customize-group RET webmention=. + +| Variable | Default | Description | +|---------------------------------------+--------------------------------+------------------------------------------------| +| =webmention-user-agent= | ="Emacs-Webmention/0.1"= | User-Agent string for HTTP requests | +| =webmention-timeout= | =30= | HTTP request timeout in seconds | +| =webmention-max-concurrent-requests= | =4= | Max concurrent endpoint discovery requests | +| =webmention-history-file= | =~/.emacs.d/webmention-history.eld= | Path to the history file | +| =webmention-skip-internal-links= | =t= | Skip same-domain links during discovery | +| =webmention-confirm-resend= | =t= | Prompt before resending a previous Webmention | +| =webmention-max-response-size= | =1048576= (1 MB) | Max response body size in bytes (truncated) | +| =webmention-history-max-entries= | =500= | Max history entries; oldest pruned on save | +| =webmention-max-retries= | =2= | Retries for transient errors (5xx, timeout) | +| =webmention-debug= | =nil= | Log to =*Webmention Log*= buffer when non-nil | + +* What is Webmention? + +[[https://www.w3.org/TR/webmention/][Webmention]] is a W3C Recommendation for notifying a URL when you link to it. It is the modern replacement for Pingback, widely adopted in the [[https://indieweb.org/][IndieWeb]] community. + +Sites that support Webmention declare an endpoint via an HTTP =Link= header or an HTML == tag. Receivers can then display mentions as comments, likes, reposts, and other interactions. + +Use cases: +- Cross-site notifications between independent blogs +- Decentralized comments and interactions +- Federated social web interactions + +* License + +GPLv3. See [[https://www.gnu.org/licenses/gpl-3.0.html][GNU General Public License v3.0]]. diff --git a/webmention.el b/webmention.el new file mode 100644 index 0000000000000000000000000000000000000000..d7ff714408e2249685573f772720fafcd245c78c --- /dev/null +++ b/webmention.el @@ -0,0 +1,1324 @@ +;;; webmention.el --- Send Webmentions from Emacs -*- lexical-binding: t -*- + +;; Copyright (C) 2026 Cytrogen + +;; Author: Cytrogen +;; Version: 0.1.0 +;; Package-Requires: ((emacs "28.1")) +;; Keywords: comm, web, hypermedia +;; URL: https://git.cytrogen.icu/~cytrogen/webmention.el + +;; This file is NOT part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Send Webmentions (W3C recommendation) from Emacs. +;; +;; Webmention is a simple protocol for notifying a URL when you link to it. +;; This package provides: +;; +;; - `webmention-discover': Fetch a source URL, extract links, discover +;; webmention endpoints, and present a staging buffer for sending. +;; - `webmention-send-url': Programmatic interface to send a single +;; webmention given source and target URLs. +;; - `webmention-show-history': View previously sent webmentions. + +;;; Code: + +(require 'cl-lib) +(require 'seq) +(require 'url) +(require 'url-parse) +(require 'url-http) +(require 'dom) + +;;; Customization + +(defgroup webmention nil + "Send Webmentions from Emacs." + :group 'comm + :prefix "webmention-") + +(defcustom webmention-user-agent "Emacs-Webmention/0.1" + "User-Agent string for HTTP requests." + :type 'string + :group 'webmention) + +(defcustom webmention-timeout 30 + "HTTP request timeout in seconds." + :type 'integer + :group 'webmention) + +(defcustom webmention-max-concurrent-requests 4 + "Maximum number of concurrent endpoint discovery requests." + :type 'integer + :group 'webmention) + +(defcustom webmention-history-file + (locate-user-emacs-file "webmention-history.eld") + "File for storing webmention send history." + :type 'file + :group 'webmention) + +(defcustom webmention-skip-internal-links t + "When non-nil, skip endpoint discovery for same-domain links." + :type 'boolean + :group 'webmention) + +(defcustom webmention-confirm-resend t + "When non-nil, prompt before resending a previously sent webmention." + :type 'boolean + :group 'webmention) + +(defcustom webmention-max-response-size (* 1024 1024) + "Maximum response body size in bytes. Larger responses are truncated." + :type 'integer :group 'webmention) + +(defcustom webmention-history-max-entries 500 + "Maximum number of history entries. Oldest entries are pruned on save." + :type 'integer :group 'webmention) + +(defcustom webmention-max-retries 2 + "Number of retries for transient failures (5xx, timeout). 0 disables." + :type 'integer :group 'webmention) + +(defcustom webmention-debug nil + "When non-nil, log to *Webmention Log* buffer." + :type 'boolean :group 'webmention) + +;;; Faces + +(defface webmention-source-url + '((t :inherit font-lock-keyword-face :weight bold)) + "Face for the source URL header." + :group 'webmention) + +(defface webmention-marked + '((t :inherit success :weight bold)) + "Face for marked indicator." + :group 'webmention) + +(defface webmention-supported + '((t :inherit success)) + "Face for targets that support webmention." + :group 'webmention) + +(defface webmention-unsupported + '((t :inherit shadow)) + "Face for targets that do not support webmention." + :group 'webmention) + +(defface webmention-discovering + '((t :inherit font-lock-comment-face)) + "Face for targets with endpoint discovery in progress." + :group 'webmention) + +(defface webmention-sent + '((t :inherit font-lock-string-face)) + "Face for successfully sent webmentions." + :group 'webmention) + +(defface webmention-error + '((t :inherit error)) + "Face for targets with errors." + :group 'webmention) + +(defface webmention-internal + '((t :inherit shadow)) + "Face for internal (same-domain) links." + :group 'webmention) + +(defface webmention-section-header + '((t :inherit font-lock-type-face :weight bold)) + "Face for section headers in the staging buffer." + :group 'webmention) + +(defun webmention--log (format-string &rest args) + "Log to *Webmention Log* when `webmention-debug' is non-nil." + (when webmention-debug + (with-current-buffer (get-buffer-create "*Webmention Log*") + (goto-char (point-max)) + (insert (format "[%s] %s\n" + (format-time-string "%H:%M:%S") + (apply #'format format-string args)))))) + +;;; Data structures + +(cl-defstruct (webmention-target (:constructor webmention-target-create)) + "A potential webmention target." + url + text + internal-p + endpoint + status + error-message + marked-p + (retry-count 0)) + +;;; Internal variables + +(defvar-local webmention--source-url nil + "Source URL for the current staging buffer.") + +(defvar-local webmention--targets nil + "List of `webmention-target' structs for current buffer.") + +(defvar-local webmention--fetch-time nil + "Time when the source page was fetched.") + +(defvar webmention--request-queue nil + "Queue of pending endpoint discovery thunks.") + +(defvar webmention--active-requests 0 + "Number of currently active endpoint discovery requests.") + +(defvar webmention--history nil + "Cached history entries. Loaded lazily from `webmention-history-file'.") + +(defvar webmention--history-loaded-p nil + "Non-nil when history has been loaded from file.") + +(defvar-local webmention--request-completed nil + "Non-nil when the url-retrieve callback has finished processing.") + +;;; URL utilities and link extraction + +(defun webmention--url-domain (url) + "Extract the host (domain) from URL string." + (url-host (url-generic-parse-url url))) + +(defun webmention--internal-link-p (source-url target-url) + "Return non-nil if TARGET-URL is on the same domain as SOURCE-URL." + (string-equal (webmention--url-domain source-url) + (webmention--url-domain target-url))) + +(defun webmention--absolute-url (url base-url) + "Resolve URL against BASE-URL, returning an absolute URL. +If URL is already absolute (http or https), return it unchanged." + (if (string-match-p "\\`https?://" url) + url + (url-expand-file-name url base-url))) + +(defun webmention--extract-canonical (dom base-url) + "Extract canonical URL from DOM, resolving against BASE-URL. +Return the canonical URL string, or nil if not found." + (let ((canonical nil)) + (dolist (link (dom-by-tag dom 'link)) + (when (and (not canonical) + (let ((rel (dom-attr link 'rel))) + (and rel (string-match-p "\\bcanonical\\b" rel)))) + (let ((href (dom-attr link 'href))) + (when (and href (not (string-empty-p href))) + (setq canonical (webmention--absolute-url href base-url)))))) + canonical)) + +(defun webmention--valid-http-url-p (url) + "Return non-nil if URL is a valid http or https URL string." + (and (stringp url) + (string-match-p "\\`https?://" url))) + +(defun webmention--parse-html (html-string) + "Parse HTML-STRING into a DOM tree. +Return the DOM, or nil if libxml is not available." + (when (fboundp 'libxml-parse-html-region) + (with-temp-buffer + (insert html-string) + (libxml-parse-html-region (point-min) (point-max))))) + +(defun webmention--extract-links (html-string base-url) + "Extract links from HTML-STRING, resolving relative URLs against BASE-URL. +Return a deduplicated list of (URL . TEXT) cons cells. +Uses DOM parsing when available, falling back to regex extraction." + (let ((dom (webmention--parse-html html-string)) + (seen (make-hash-table :test #'equal)) + (result nil)) + (if dom + ;; Path A: DOM parsing + (dolist (a (dom-by-tag dom 'a)) + (let ((href (dom-attr a 'href)) + (text (string-trim (dom-texts a "")))) + (when (and href + (not (string-empty-p href)) + (not (string-prefix-p "#" href)) + (not (string-prefix-p "mailto:" href)) + (not (string-prefix-p "javascript:" href))) + (let ((abs-url (webmention--absolute-url href base-url))) + (when (and (webmention--valid-http-url-p abs-url) + (not (gethash abs-url seen))) + (puthash abs-url t seen) + (push (cons abs-url text) result)))))) + ;; Path B: Regex fallback + (with-temp-buffer + (insert html-string) + (goto-char (point-min)) + (while (re-search-forward + "]+href=[\"']\\([^\"']+\\)[\"'][^>]*>\\([^<]*\\)" + nil t) + (let* ((href (match-string 1)) + (text (string-trim (match-string 2))) + (abs-url (webmention--absolute-url href base-url))) + (when (and (webmention--valid-http-url-p abs-url) + (not (gethash abs-url seen))) + (puthash abs-url t seen) + (push (cons abs-url text) result)))))) + (nreverse result))) + +;;; Endpoint discovery and request queue + +(defun webmention--rel-webmention-p (rel-string) + "Return non-nil if REL-STRING contains \"webmention\" as a word." + (and (stringp rel-string) + (string-match-p "\\bwebmention\\b" rel-string))) + +(defun webmention--parse-link-header (header-value target-url) + "Parse RFC 8288 Link HEADER-VALUE, return webmention endpoint URL or nil. +Resolve relative URLs against TARGET-URL." + (when (stringp header-value) + (let ((entries (split-string header-value ">\\s-*," t)) + (endpoint nil)) + (while (and entries (not endpoint)) + (let ((entry (pop entries))) + (when (string-match "<\\([^>]+\\)>" entry) + (let ((url (match-string 1 entry))) + (when (string-match "rel=[\"']?\\([^\"';]+\\)" entry) + (let ((rel (match-string 1 entry))) + (when (webmention--rel-webmention-p rel) + (setq endpoint + (webmention--absolute-url url target-url))))))))) + endpoint))) + +(defun webmention--response-header-end () + "Return the position of the header/body boundary in current buffer. +Prefer `url-http-end-of-headers' when available, fall back to searching +for the blank line separator." + (or (and (boundp 'url-http-end-of-headers) + url-http-end-of-headers) + (save-excursion + (goto-char (point-min)) + (when (or (re-search-forward "\r\n\r\n" nil t) + (re-search-forward "\n\n" nil t)) + (point))))) + +(defun webmention--extract-body () + "Extract and return the HTTP response body from current buffer. +Truncate to `webmention-max-response-size' bytes." + (let ((header-end (webmention--response-header-end))) + (if (not header-end) + "" + (let ((body-size (- (point-max) header-end))) + (when (> body-size webmention-max-response-size) + (webmention--log "Response truncated: %d → %d bytes" + body-size webmention-max-response-size)) + (buffer-substring-no-properties + header-end + (min (point-max) (+ header-end webmention-max-response-size))))))) + +(defun webmention--discover-endpoint-from-headers (target-url) + "Discover webmention endpoint from HTTP Link headers in current buffer. +Return the endpoint URL string, or nil if not found. +TARGET-URL is used to resolve relative URLs." + (let ((header-end (webmention--response-header-end))) + (when header-end + (let ((case-fold-search t) + (link-values nil)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^Link:\\s-*\\(.*\\)$" header-end t) + (push (match-string 1) link-values))) + (when link-values + (webmention--parse-link-header + (mapconcat #'identity (nreverse link-values) ", ") + target-url)))))) + +(defun webmention--discover-endpoint-from-html (html-string target-url) + "Discover webmention endpoint from HTML-STRING. +Return the endpoint URL string, or nil if not found. +TARGET-URL is used to resolve relative URLs." + (let ((dom (webmention--parse-html html-string))) + (if dom + ;; DOM path: try tags, then tags + (let ((endpoint nil)) + (dolist (link (dom-by-tag dom 'link)) + (when (and (not endpoint) + (webmention--rel-webmention-p (dom-attr link 'rel))) + (let ((href (dom-attr link 'href))) + (when (and href (not (string-empty-p href))) + (setq endpoint (webmention--absolute-url href target-url)))))) + (unless endpoint + (dolist (a (dom-by-tag dom 'a)) + (when (and (not endpoint) + (webmention--rel-webmention-p (dom-attr a 'rel))) + (let ((href (dom-attr a 'href))) + (when (and href (not (string-empty-p href))) + (setq endpoint (webmention--absolute-url href target-url))))))) + endpoint) + ;; Regex fallback: try both attribute orders + (with-temp-buffer + (insert html-string) + (let ((case-fold-search t) + (endpoint nil)) + (goto-char (point-min)) + ;; Pattern 1: rel before href + (while (and (not endpoint) + (re-search-forward + "]+rel=[\"']\\([^\"']+\\)[\"'][^>]+href=[\"']\\([^\"']+\\)[\"']" + nil t)) + (when (webmention--rel-webmention-p (match-string 1)) + (setq endpoint (webmention--absolute-url (match-string 2) target-url)))) + ;; Pattern 2: href before rel + (unless endpoint + (goto-char (point-min)) + (while (and (not endpoint) + (re-search-forward + "]+href=[\"']\\([^\"']+\\)[\"'][^>]+rel=[\"']\\([^\"']+\\)[\"']" + nil t)) + (when (webmention--rel-webmention-p (match-string 2)) + (setq endpoint (webmention--absolute-url (match-string 1) target-url))))) + ;; Try tags with same two patterns + (unless endpoint + (goto-char (point-min)) + (while (and (not endpoint) + (re-search-forward + "]+rel=[\"']\\([^\"']+\\)[\"'][^>]+href=[\"']\\([^\"']+\\)[\"']" + nil t)) + (when (webmention--rel-webmention-p (match-string 1)) + (setq endpoint (webmention--absolute-url (match-string 2) target-url))))) + (unless endpoint + (goto-char (point-min)) + (while (and (not endpoint) + (re-search-forward + "]+href=[\"']\\([^\"']+\\)[\"'][^>]+rel=[\"']\\([^\"']+\\)[\"']" + nil t)) + (when (webmention--rel-webmention-p (match-string 2)) + (setq endpoint (webmention--absolute-url (match-string 1) target-url))))) + endpoint))))) + +(defun webmention--handle-timeout (response-buffer target staging-buffer) + "Handle timeout for endpoint discovery of TARGET. +Kill RESPONSE-BUFFER if still alive, mark TARGET as error, +and process the next item in the queue. +STAGING-BUFFER is passed through for rendering updates." + (when (and (buffer-live-p response-buffer) + (not (buffer-local-value 'webmention--request-completed + response-buffer))) + (kill-buffer response-buffer) + (setf (webmention-target-error-message target) "Request timed out") + (webmention--log "Timeout: %s" (webmention-target-url target)) + (message "Webmention: %s timed out after %ds" + (webmention-target-url target) webmention-timeout) + (if (and (> webmention-max-retries 0) + (< (webmention-target-retry-count target) webmention-max-retries) + (webmention--retriable-error-p target)) + (progn + (cl-incf (webmention-target-retry-count target)) + (webmention--log "Retry %s (%d/%d)" + (webmention-target-url target) + (webmention-target-retry-count target) + webmention-max-retries) + (run-at-time 1 nil #'webmention--enqueue-discovery + target staging-buffer)) + (setf (webmention-target-status target) 'error) + (when (buffer-live-p staging-buffer) + (with-current-buffer staging-buffer + (webmention--render-staging-buffer)))) + (webmention--process-queue))) + +(defun webmention--discover-endpoint (target staging-buffer) + "Asynchronously discover the webmention endpoint for TARGET. +Update TARGET struct with results and refresh STAGING-BUFFER." + (webmention--log "Discovering endpoint: %s" (webmention-target-url target)) + (let* ((target-url (webmention-target-url target)) + (url-request-extra-headers + `(("User-Agent" . ,webmention-user-agent))) + (response-buffer + (url-retrieve + target-url + (lambda (status) + (let ((resp-buf (current-buffer))) + (unwind-protect + (progn + (setq-local webmention--request-completed t) + ;; Cancel timeout timer + (when (and (boundp 'webmention--timeout-timer) + webmention--timeout-timer) + (cancel-timer webmention--timeout-timer)) + (cond + ;; Network/connection error + ((plist-get status :error) + (let ((err (plist-get status :error))) + (setf (webmention-target-error-message target) + (format "%S" err)) + (webmention--log "Discovery error: %s — %S" + target-url err) + (message "Webmention: error discovering %s: %S" + target-url err) + (if (and (> webmention-max-retries 0) + (< (webmention-target-retry-count target) + webmention-max-retries) + (webmention--retriable-error-p target)) + (progn + (cl-incf (webmention-target-retry-count target)) + (webmention--log "Retry %s (%d/%d)" + target-url + (webmention-target-retry-count target) + webmention-max-retries) + (run-at-time 1 nil #'webmention--enqueue-discovery + target staging-buffer)) + (setf (webmention-target-status target) 'error)))) + ;; HTTP error status + ((and (boundp 'url-http-response-status) + url-http-response-status + (>= url-http-response-status 400)) + (let ((msg (format "HTTP %d" url-http-response-status))) + (setf (webmention-target-error-message target) msg) + (webmention--log "Discovery error: %s — %s" + target-url msg) + (message "Webmention: error discovering %s: %s" + target-url msg) + (if (and (> webmention-max-retries 0) + (< (webmention-target-retry-count target) + webmention-max-retries) + (webmention--retriable-error-p target)) + (progn + (cl-incf (webmention-target-retry-count target)) + (webmention--log "Retry %s (%d/%d)" + target-url + (webmention-target-retry-count target) + webmention-max-retries) + (run-at-time 1 nil #'webmention--enqueue-discovery + target staging-buffer)) + (setf (webmention-target-status target) 'error)))) + ;; Success — try to find endpoint + (t + (let ((endpoint (webmention--discover-endpoint-from-headers + target-url))) + (unless endpoint + (let ((body (webmention--extract-body))) + (unless (string-empty-p body) + (setq endpoint + (webmention--discover-endpoint-from-html + body target-url))))) + (if endpoint + (progn + (setf (webmention-target-endpoint target) endpoint) + (setf (webmention-target-status target) 'discovered) + (webmention--log "Discovered: %s → %s" + target-url endpoint) + (message "Webmention: %s supports webmention at %s" + target-url endpoint)) + (setf (webmention-target-status target) 'no-endpoint) + (webmention--log "No endpoint: %s" target-url) + (message "Webmention: %s does not support webmention" + target-url))))) + ;; Refresh staging buffer + (when (buffer-live-p staging-buffer) + (with-current-buffer staging-buffer + (webmention--render-staging-buffer)))) + ;; Cleanup: kill response buffer & advance queue + (when (buffer-live-p resp-buf) + (kill-buffer resp-buf)) + (webmention--process-queue)))) + nil t))) + ;; Set up timeout timer on the response buffer + (when (buffer-live-p response-buffer) + (with-current-buffer response-buffer + (setq-local webmention--timeout-timer + (run-at-time webmention-timeout nil + #'webmention--handle-timeout + response-buffer target staging-buffer)))))) + +(defun webmention--process-queue () + "Process the next item in the request queue. +Decrement active request count and launch the next queued thunk +if under the concurrency limit." + (cl-decf webmention--active-requests) + (while (and webmention--request-queue + (< webmention--active-requests webmention-max-concurrent-requests)) + (let ((thunk (pop webmention--request-queue))) + (cl-incf webmention--active-requests) + (funcall thunk))) + (when (and (= webmention--active-requests 0) + (null webmention--request-queue)) + (webmention--report-discovery-summary))) + +(defun webmention--enqueue-discovery (target staging-buffer) + "Enqueue endpoint discovery for TARGET. +If under the concurrency limit, start immediately. +Otherwise add to the request queue. STAGING-BUFFER is the buffer +to refresh when results arrive." + (if (< webmention--active-requests webmention-max-concurrent-requests) + (progn + (cl-incf webmention--active-requests) + (setf (webmention-target-status target) 'discovering) + (message "Webmention: discovering endpoint for %s" + (webmention-target-url target)) + (webmention--discover-endpoint target staging-buffer)) + (setf (webmention-target-status target) 'queued) + (setq webmention--request-queue + (append webmention--request-queue + (list (lambda () + (setf (webmention-target-status target) 'discovering) + (message "Webmention: discovering endpoint for %s" + (webmention-target-url target)) + (webmention--discover-endpoint target staging-buffer))))))) + +(defun webmention--discovery-complete-p () + "Return non-nil if all targets have completed endpoint discovery." + (not (cl-some (lambda (target) + (memq (webmention-target-status target) + '(queued discovering))) + webmention--targets))) + +(defun webmention--report-discovery-summary () + "Report a summary of endpoint discovery results via `message'." + (let ((discovered 0) (no-endpoint 0) (skipped 0) (errors 0)) + (dolist (target webmention--targets) + (pcase (webmention-target-status target) + ('discovered (cl-incf discovered)) + ('no-endpoint (cl-incf no-endpoint)) + ('skipped (cl-incf skipped)) + ('error (cl-incf errors)))) + (message "Webmention: discovery complete — %d with endpoint, %d unsupported, %d skipped, %d errors" + discovered no-endpoint skipped errors))) + +(defun webmention--discover-all-endpoints (staging-buffer) + "Start endpoint discovery for all targets in STAGING-BUFFER. +Skip internal links when `webmention-skip-internal-links' is non-nil." + (setq webmention--active-requests 0) + (setq webmention--request-queue nil) + (with-current-buffer staging-buffer + (dolist (target webmention--targets) + (if (and webmention-skip-internal-links + (webmention-target-internal-p target)) + (progn + (setf (webmention-target-status target) 'skipped) + (message "Webmention: skipping internal link %s" + (webmention-target-url target))) + (webmention--enqueue-discovery target staging-buffer))))) + +;;; Staging buffer UI + +(declare-function text-property-search-forward "text-property-search" + (property &optional value predicate not-current)) +(declare-function text-property-search-backward "text-property-search" + (property &optional value predicate not-current)) + +(defun webmention--target-at-point () + "Return the `webmention-target' struct at point, or nil." + (get-text-property (line-beginning-position) 'webmention-target)) + +(defun webmention--next-target () + "Move point to the next target line." + (interactive) + (let ((match (save-excursion + (goto-char (line-end-position)) + (text-property-search-forward + 'webmention-target nil + (lambda (_val prop) prop))))) + (when match + (goto-char (prop-match-beginning match)) + (move-to-column 4)))) + +(defun webmention--prev-target () + "Move point to the previous target line." + (interactive) + (let ((match (save-excursion + (goto-char (line-beginning-position)) + (text-property-search-backward + 'webmention-target nil + (lambda (_val prop) prop))))) + (when match + (goto-char (prop-match-beginning match)) + (move-to-column 4)))) + +(defun webmention--format-target-line (target) + "Return a propertized string for TARGET (no trailing newline)." + (let* ((status (webmention-target-status target)) + (marked (webmention-target-marked-p target)) + (url (webmention-target-url target)) + (checkbox (pcase status + ('discovered (if marked "✓" " ")) + ((or 'discovering 'queued 'sending) "~") + ('sent "✓") + ((or 'skipped 'no-endpoint) "—") + ('error "!") + (_ " "))) + (face (pcase status + ('discovered 'webmention-supported) + ((or 'discovering 'queued 'sending) 'webmention-discovering) + ('sent 'webmention-sent) + ('no-endpoint 'webmention-unsupported) + ('skipped 'webmention-internal) + ('error 'webmention-error) + (_ 'default))) + (suffix (pcase status + ('discovered + (let ((ep (webmention-target-endpoint target))) + (if ep (format "→ %s" ep) ""))) + ('sending "sending...") + ('sent "sent") + ('error + (format "error: %s" + (or (webmention-target-error-message target) "unknown"))) + ((or 'discovering 'queued) "discovering...") + ('skipped "(internal)") + (_ ""))) + (checkbox-str (if marked + (propertize (format "[%s]" checkbox) + 'face 'webmention-marked) + (format "[%s]" checkbox))) + (line (format " %s %s %s" checkbox-str + (propertize url 'face face) + (propertize suffix 'face face)))) + (propertize line + 'webmention-target target + 'webmention-target-url url))) + +(defun webmention--render-staging-buffer () + "Render the staging buffer contents. +Preserves cursor position by matching target URL text properties." + (let* ((saved-url (get-text-property (line-beginning-position) + 'webmention-target-url)) + (saved-col (current-column)) + (win (get-buffer-window (current-buffer))) + (saved-window-start (when win (window-start win)))) + (let ((inhibit-read-only t)) + (erase-buffer) + ;; Header + (insert (propertize (format "Source: %s" (or webmention--source-url "")) + 'face 'webmention-source-url) + "\n") + (insert (format "Fetched: %s\n" + (if webmention--fetch-time + (format-time-string "%Y-%m-%d %H:%M:%S" + webmention--fetch-time) + "—"))) + (insert (make-string 40 ?─) "\n") + (if (null webmention--targets) + (insert "\nNo links found in source page.\n") + ;; Group targets by category + (let ((discovered nil) (in-progress nil) (sent-list nil) + (no-endpoint nil) (skipped nil) (errors nil)) + (dolist (target webmention--targets) + (pcase (webmention-target-status target) + ((or 'discovered 'marked) + (push target discovered)) + ((or 'discovering 'queued 'sending) + (push target in-progress)) + ('sent (push target sent-list)) + ('no-endpoint (push target no-endpoint)) + ('skipped (push target skipped)) + ('error (push target errors)))) + (setq discovered (nreverse discovered) + in-progress (nreverse in-progress) + sent-list (nreverse sent-list) + no-endpoint (nreverse no-endpoint) + skipped (nreverse skipped) + errors (nreverse errors)) + (cl-flet ((render-section (label section-sym targets) + (when targets + (insert "\n" + (propertize label + 'face 'webmention-section-header + 'webmention-section section-sym) + "\n") + (dolist (target targets) + (insert (webmention--format-target-line target) "\n"))))) + (render-section "Targets with endpoints:" 'discovered discovered) + (render-section "Sent:" 'sent sent-list) + (render-section "Discovering:" 'discovering in-progress) + (render-section "No endpoint:" 'no-endpoint no-endpoint) + (render-section "Skipped (internal):" 'skipped skipped) + (render-section "Errors:" 'error errors))))) + ;; Restore cursor position + (if saved-url + (let ((match (save-excursion + (goto-char (point-min)) + (text-property-search-forward + 'webmention-target-url saved-url #'equal)))) + (if match + (progn + (goto-char (prop-match-beginning match)) + (move-to-column saved-col)) + (goto-char (point-min)))) + (goto-char (point-min))) + (when (and win saved-window-start) + (set-window-start win (min saved-window-start (point-max)))))) + +(defun webmention-mark () + "Mark the target at point for sending." + (interactive) + (let ((target (webmention--target-at-point))) + (unless target + (user-error "No target at point")) + (unless (eq (webmention-target-status target) 'discovered) + (user-error "Can only mark targets with discovered endpoints")) + (setf (webmention-target-marked-p target) t) + (webmention--render-staging-buffer) + (webmention--next-target))) + +(defun webmention-unmark () + "Unmark the target at point." + (interactive) + (let ((target (webmention--target-at-point))) + (unless target + (user-error "No target at point")) + (setf (webmention-target-marked-p target) nil) + (webmention--render-staging-buffer) + (webmention--next-target))) + +(defun webmention-mark-all () + "Mark all targets with discovered endpoints." + (interactive) + (dolist (target webmention--targets) + (when (eq (webmention-target-status target) 'discovered) + (setf (webmention-target-marked-p target) t))) + (webmention--render-staging-buffer)) + +(defun webmention-unmark-all () + "Unmark all targets." + (interactive) + (dolist (target webmention--targets) + (setf (webmention-target-marked-p target) nil)) + (webmention--render-staging-buffer)) + +(defun webmention-refresh () + "Re-discover endpoints for all targets. +Does not re-fetch the source page." + (interactive) + (dolist (target webmention--targets) + (setf (webmention-target-status target) 'queued) + (setf (webmention-target-endpoint target) nil) + (setf (webmention-target-error-message target) nil) + (setf (webmention-target-marked-p target) nil)) + (webmention--render-staging-buffer) + (webmention--discover-all-endpoints (current-buffer))) + +(defun webmention-send-marked () + "Send webmentions for all marked targets." + (interactive) + (let ((marked (cl-remove-if-not #'webmention-target-marked-p + webmention--targets))) + (unless marked + (user-error "No marked targets")) + (webmention--send-targets marked (current-buffer)))) + +(defvar webmention-staging-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map special-mode-map) + (define-key map "m" #'webmention-mark) + (define-key map "u" #'webmention-unmark) + (define-key map "M" #'webmention-mark-all) + (define-key map "U" #'webmention-unmark-all) + (define-key map "s" #'webmention-send-marked) + (define-key map (kbd "RET") #'webmention-send-marked) + (define-key map "g" #'webmention-refresh) + (define-key map "n" #'webmention--next-target) + (define-key map "p" #'webmention--prev-target) + map) + "Keymap for `webmention-staging-mode'.") + +(define-derived-mode webmention-staging-mode special-mode "Webmention" + "Major mode for the webmention staging buffer. +\\{webmention-staging-mode-map}" + (setq buffer-read-only t) + (setq truncate-lines t) + (setq header-line-format + (substitute-command-keys + " \\\\[webmention-mark]:mark \\[webmention-unmark]:unmark \\[webmention-mark-all]:mark-all \\[webmention-unmark-all]:unmark-all \\[webmention-send-marked]:send \\[webmention-refresh]:refresh \\[quit-window]:quit"))) + +;;; History + +(defun webmention--ensure-history-loaded () + "Load history from `webmention-history-file' if not already loaded." + (unless webmention--history-loaded-p + (if (file-exists-p webmention-history-file) + (condition-case err + (with-temp-buffer + (insert-file-contents webmention-history-file) + (setq webmention--history (read (current-buffer)))) + (error + (warn "Webmention: failed to read history file: %S" err) + (setq webmention--history nil))) + (setq webmention--history nil)) + (setq webmention--history-loaded-p t) + (webmention--log "History loaded (%d entries)" (length webmention--history)))) + +(defun webmention--save-history () + "Write `webmention--history' to `webmention-history-file'." + (when (and (integerp webmention-history-max-entries) + (> (length webmention--history) webmention-history-max-entries)) + (webmention--log "History pruned: %d → %d entries" + (length webmention--history) + webmention-history-max-entries) + (setq webmention--history + (seq-take webmention--history webmention-history-max-entries))) + (condition-case err + (with-temp-file webmention-history-file + (let ((print-length nil) + (print-level nil)) + (prin1 webmention--history (current-buffer)))) + (error + (warn "Webmention: failed to save history: %S" err))) + (webmention--log "History saved (%d entries)" (length webmention--history))) + +(defun webmention--record-history (source target endpoint status + &optional http-status error-message) + "Record a webmention send attempt in history. +SOURCE, TARGET, and ENDPOINT are URL strings. +STATUS is a symbol (`sent' or `error'). +HTTP-STATUS is the numeric HTTP response code. +ERROR-MESSAGE is an optional error description string." + (webmention--ensure-history-loaded) + (push (list :source source :target target :endpoint endpoint + :status status :time (current-time) + :http-status http-status :error-message error-message) + webmention--history) + (webmention--save-history)) + +(defun webmention--history-sent-p (source target) + "Return non-nil if a `sent' record exists for SOURCE and TARGET." + (webmention--ensure-history-loaded) + (cl-some (lambda (entry) + (and (equal (plist-get entry :source) source) + (equal (plist-get entry :target) target) + (eq (plist-get entry :status) 'sent))) + webmention--history)) + +(defun webmention--format-history-entry (entry) + "Format a single history ENTRY as a one-line string." + (let ((time (plist-get entry :time)) + (status (plist-get entry :status)) + (source (plist-get entry :source)) + (target (plist-get entry :target)) + (http-status (plist-get entry :http-status)) + (err-msg (plist-get entry :error-message))) + (format "%s %-5s %s → %s%s" + (if time (format-time-string "%Y-%m-%d %H:%M:%S" time) "unknown") + (propertize (symbol-name status) + 'face (if (eq status 'sent) + 'webmention-sent + 'webmention-error)) + source target + (cond (err-msg (format " (%s)" err-msg)) + (http-status (format " (HTTP %s)" http-status)) + (t ""))))) + +;;; Sending + +(defun webmention--retriable-error-p (target) + "Return non-nil if TARGET's error is transient (5xx or timeout)." + (let ((msg (or (webmention-target-error-message target) ""))) + (or (string-match-p "timed out" msg) + (string-match-p "HTTP 5[0-9][0-9]" msg)))) + +(defun webmention--send-single (source-url target staging-buffer) + "Asynchronously send a webmention from SOURCE-URL for TARGET. +TARGET is a `webmention-target' struct. STAGING-BUFFER is refreshed +on completion (if still alive)." + (webmention--log "Sending: %s → %s via %s" + source-url (webmention-target-url target) + (webmention-target-endpoint target)) + (let* ((target-url (webmention-target-url target)) + (endpoint (webmention-target-endpoint target))) + (unless endpoint + (setf (webmention-target-status target) 'error) + (setf (webmention-target-error-message target) "No endpoint") + (when (buffer-live-p staging-buffer) + (with-current-buffer staging-buffer + (webmention--render-staging-buffer))) + (cl-return-from webmention--send-single)) + (setf (webmention-target-status target) 'sending) + (when (buffer-live-p staging-buffer) + (with-current-buffer staging-buffer + (webmention--render-staging-buffer))) + (let* ((url-request-method "POST") + (url-request-extra-headers + `(("Content-Type" . "application/x-www-form-urlencoded") + ("User-Agent" . ,webmention-user-agent))) + (url-request-data + (format "source=%s&target=%s" + (url-hexify-string source-url) + (url-hexify-string target-url))) + (response-buffer + (url-retrieve + endpoint + (lambda (status) + (let ((resp-buf (current-buffer))) + (unwind-protect + (progn + (setq-local webmention--request-completed t) + ;; Cancel timeout timer + (when (and (boundp 'webmention--timeout-timer) + webmention--timeout-timer) + (cancel-timer webmention--timeout-timer)) + (cond + ;; Network error + ((plist-get status :error) + (let ((err (plist-get status :error))) + (setf (webmention-target-error-message target) + (format "%S" err)) + (webmention--log "Send error: %s — %S" + target-url err) + (message "Webmention: error sending to %s: %S" + target-url err) + (if (and (> webmention-max-retries 0) + (< (webmention-target-retry-count target) + webmention-max-retries) + (webmention--retriable-error-p target)) + (progn + (cl-incf (webmention-target-retry-count target)) + (webmention--log "Retry send %s (%d/%d)" + target-url + (webmention-target-retry-count target) + webmention-max-retries) + (run-at-time 1 nil + #'webmention--send-single + source-url target staging-buffer)) + (setf (webmention-target-status target) 'error) + (webmention--record-history + source-url target-url endpoint 'error nil + (format "%S" err))))) + ;; Check HTTP status + (t + (let ((http-status + (and (boundp 'url-http-response-status) + url-http-response-status))) + (if (and http-status + (>= http-status 200) (< http-status 300)) + (progn + (setf (webmention-target-status target) 'sent) + (setf (webmention-target-marked-p target) nil) + (webmention--record-history + source-url target-url endpoint + 'sent http-status nil) + (webmention--log "Sent: %s → %s (HTTP %d)" + source-url target-url http-status) + (message "Webmention: sent to %s (HTTP %d)" + target-url http-status)) + (let ((msg (format "HTTP %s" + (or http-status "unknown")))) + (setf (webmention-target-error-message target) msg) + (webmention--log "Send failed: %s — %s" + target-url msg) + (message "Webmention: failed sending to %s: %s" + target-url msg) + (if (and (> webmention-max-retries 0) + (< (webmention-target-retry-count target) + webmention-max-retries) + (webmention--retriable-error-p target)) + (progn + (cl-incf (webmention-target-retry-count target)) + (webmention--log "Retry send %s (%d/%d)" + target-url + (webmention-target-retry-count target) + webmention-max-retries) + (run-at-time 1 nil + #'webmention--send-single + source-url target staging-buffer)) + (setf (webmention-target-status target) 'error) + (webmention--record-history + source-url target-url endpoint + 'error http-status msg))))))) + ;; Refresh staging buffer + (when (buffer-live-p staging-buffer) + (with-current-buffer staging-buffer + (webmention--render-staging-buffer)))) + ;; Cleanup + (when (buffer-live-p resp-buf) + (kill-buffer resp-buf))))) + nil t))) + ;; Set up timeout timer + (when (buffer-live-p response-buffer) + (with-current-buffer response-buffer + (setq-local webmention--timeout-timer + (run-at-time + webmention-timeout nil + (lambda () + (when (and (buffer-live-p response-buffer) + (not (buffer-local-value + 'webmention--request-completed + response-buffer))) + (kill-buffer response-buffer) + (setf (webmention-target-error-message target) + "Request timed out") + (webmention--log "Send timeout: %s" target-url) + (message "Webmention: sending to %s timed out after %ds" + target-url webmention-timeout) + (if (and (> webmention-max-retries 0) + (< (webmention-target-retry-count target) + webmention-max-retries) + (webmention--retriable-error-p target)) + (progn + (cl-incf (webmention-target-retry-count target)) + (webmention--log "Retry send %s (%d/%d)" + target-url + (webmention-target-retry-count target) + webmention-max-retries) + (run-at-time 1 nil + #'webmention--send-single + source-url target staging-buffer)) + (setf (webmention-target-status target) 'error) + (webmention--record-history + source-url target-url endpoint 'error nil + "Request timed out") + (when (buffer-live-p staging-buffer) + (with-current-buffer staging-buffer + (webmention--render-staging-buffer))))))))))))) + +(defun webmention--send-targets (targets staging-buffer) + "Send webmentions for TARGETS, checking resend confirmation. +STAGING-BUFFER is the current staging buffer." + (let ((source-url (buffer-local-value 'webmention--source-url staging-buffer))) + (dolist (target targets) + (let ((target-url (webmention-target-url target))) + (if (and webmention-confirm-resend + (webmention--history-sent-p source-url target-url) + (not (y-or-n-p + (format "Already sent webmention to %s. Resend? " + target-url)))) + ;; User declined resend — restore state + (progn + (setf (webmention-target-marked-p target) nil) + (when (buffer-live-p staging-buffer) + (with-current-buffer staging-buffer + (webmention--render-staging-buffer)))) + ;; Send it + (webmention--send-single source-url target staging-buffer)))))) + +;;; Entry point + +(defun webmention--fetch-source (source-url callback) + "Asynchronously fetch SOURCE-URL and call CALLBACK with (html-string final-url). +CALLBACK receives the HTML body as a string and the final URL after redirects." + (let ((url-request-extra-headers + `(("User-Agent" . ,webmention-user-agent)))) + (let ((response-buffer + (url-retrieve + source-url + (lambda (status) + (let ((resp-buf (current-buffer))) + (unwind-protect + (progn + (setq-local webmention--request-completed t) + (when (and (boundp 'webmention--timeout-timer) + webmention--timeout-timer) + (cancel-timer webmention--timeout-timer)) + (cond + ((plist-get status :error) + (webmention--log "Fetch source error: %s — %S" + source-url (plist-get status :error)) + (message "Webmention: error fetching source: %S" + (plist-get status :error))) + ((and (boundp 'url-http-response-status) + url-http-response-status + (>= url-http-response-status 200) + (< url-http-response-status 300)) + (let* ((body (webmention--extract-body)) + (final-url (if (and (boundp 'url-http-target-url) + url-http-target-url) + (url-recreate-url url-http-target-url) + source-url))) + (funcall callback body final-url))) + (t + (message "Webmention: source returned HTTP %s" + (or (and (boundp 'url-http-response-status) + url-http-response-status) + "unknown"))))) + (when (buffer-live-p resp-buf) + (kill-buffer resp-buf))))) + nil t))) + ;; Set up timeout + (when (buffer-live-p response-buffer) + (with-current-buffer response-buffer + (setq-local webmention--timeout-timer + (run-at-time + webmention-timeout nil + (lambda () + (when (and (buffer-live-p response-buffer) + (not (buffer-local-value + 'webmention--request-completed + response-buffer))) + (kill-buffer response-buffer) + (webmention--log "Fetch source timeout: %s" source-url) + (message "Webmention: timed out fetching source %s" + source-url)))))))))) + +;;;###autoload +(defun webmention-discover (source-url) + "Discover webmention targets for SOURCE-URL and open a staging buffer. +Interactively, the default URL is determined by (in priority order): +the URL at point, the Org WEBMENTION_URL property, the first URL +in the kill ring, or manual input." + (interactive + (let* ((default (or (thing-at-point 'url t) + (and (derived-mode-p 'org-mode) + (fboundp 'org-entry-get) + (org-entry-get nil "WEBMENTION_URL" t)) + (let ((top (ignore-errors (current-kill 0 t)))) + (when (and top (webmention--valid-http-url-p top)) + top)) + "")) + (url (read-string + (if (string-empty-p default) + "Source URL: " + (format "Source URL (default %s): " default)) + nil nil default))) + (list url))) + (unless (webmention--valid-http-url-p source-url) + (user-error "Invalid URL: %s" source-url)) + (message "Webmention: fetching %s..." source-url) + (webmention--fetch-source + source-url + (lambda (html-string final-url) + (let* ((dom (webmention--parse-html html-string)) + (effective-url (or (and dom + (webmention--extract-canonical dom final-url)) + final-url)) + (links (webmention--extract-links html-string effective-url)) + (buf-name (format "*Webmention: %s*" effective-url)) + (buf (get-buffer-create buf-name))) + (with-current-buffer buf + ;; Mode first (kills local variables), then set locals + (webmention-staging-mode) + (setq webmention--source-url effective-url) + (setq webmention--fetch-time (current-time)) + (setq webmention--targets + (mapcar (lambda (link) + (webmention-target-create + :url (car link) + :text (cdr link) + :status 'queued + :internal-p (webmention--internal-link-p + effective-url (car link)))) + links)) + (webmention--render-staging-buffer) + (webmention--discover-all-endpoints buf)) + (pop-to-buffer buf + '((display-buffer-reuse-window + display-buffer-same-window))))))) + +;;;###autoload +(defun webmention-show-history () + "Display the webmention send history buffer." + (interactive) + (webmention--ensure-history-loaded) + (let ((buf (get-buffer-create "*Webmention History*"))) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (propertize "Webmention Send History" + 'face 'webmention-section-header) + "\n" + (make-string 40 ?─) "\n\n") + (if (null webmention--history) + (insert "No webmentions sent yet.\n") + (let ((sorted (sort (copy-sequence webmention--history) + (lambda (a b) + (time-less-p (plist-get b :time) + (plist-get a :time)))))) + (dolist (entry sorted) + (insert (webmention--format-history-entry entry) "\n"))))) + (special-mode) + (goto-char (point-min))) + (pop-to-buffer buf + '((display-buffer-reuse-window + display-buffer-same-window))))) + +;;;###autoload +(defun webmention-send-url (source-url target-url) + "Send a webmention from SOURCE-URL to TARGET-URL. +Discover the endpoint for TARGET-URL, then send the webmention. +Results are reported via `message' and recorded in history." + (interactive + (list (read-string "Source URL: ") + (read-string "Target URL: "))) + (unless (webmention--valid-http-url-p source-url) + (user-error "Invalid source URL: %s" source-url)) + (unless (webmention--valid-http-url-p target-url) + (user-error "Invalid target URL: %s" target-url)) + (message "Webmention: discovering endpoint for %s..." target-url) + (let ((target (webmention-target-create + :url target-url + :text "" + :status 'discovering))) + ;; Discover endpoint, then send in callback + (let* ((url-request-extra-headers + `(("User-Agent" . ,webmention-user-agent))) + (response-buffer + (url-retrieve + target-url + (lambda (status) + (let ((resp-buf (current-buffer))) + (unwind-protect + (progn + (setq-local webmention--request-completed t) + (when (and (boundp 'webmention--timeout-timer) + webmention--timeout-timer) + (cancel-timer webmention--timeout-timer)) + (cond + ((plist-get status :error) + (webmention--log "send-url discovery error: %s — %S" + target-url (plist-get status :error)) + (message "Webmention: error discovering %s: %S" + target-url (plist-get status :error))) + ((and (boundp 'url-http-response-status) + url-http-response-status + (>= url-http-response-status 400)) + (message "Webmention: target returned HTTP %d" + url-http-response-status)) + (t + (let ((endpoint (webmention--discover-endpoint-from-headers + target-url))) + (unless endpoint + (let ((body (webmention--extract-body))) + (unless (string-empty-p body) + (setq endpoint + (webmention--discover-endpoint-from-html + body target-url))))) + (if endpoint + (progn + (setf (webmention-target-endpoint target) endpoint) + (setf (webmention-target-status target) 'discovered) + (webmention--log "send-url: %s → %s via %s" + source-url target-url endpoint) + (message "Webmention: sending %s → %s via %s" + source-url target-url endpoint) + ;; Now send — no staging buffer needed + (webmention--send-single source-url target nil)) + (message "Webmention: %s does not support webmention" + target-url)))))) + (when (buffer-live-p resp-buf) + (kill-buffer resp-buf))))) + nil t))) + (when (buffer-live-p response-buffer) + (with-current-buffer response-buffer + (setq-local webmention--timeout-timer + (run-at-time + webmention-timeout nil + (lambda () + (when (and (buffer-live-p response-buffer) + (not (buffer-local-value + 'webmention--request-completed + response-buffer))) + (kill-buffer response-buffer) + (webmention--log "send-url discovery timeout: %s" + target-url) + (message "Webmention: timed out discovering %s" + target-url)))))))))) + +(provide 'webmention) +;;; webmention.el ends here