@@ 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 =<link>= 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]].
@@ 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 <https://www.gnu.org/licenses/>.
+
+;;; 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
+ "<a[^>]+href=[\"']\\([^\"']+\\)[\"'][^>]*>\\([^<]*\\)</a>"
+ 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 <link> tags, then <a> 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
+ "<link[^>]+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
+ "<link[^>]+href=[\"']\\([^\"']+\\)[\"'][^>]+rel=[\"']\\([^\"']+\\)[\"']"
+ nil t))
+ (when (webmention--rel-webmention-p (match-string 2))
+ (setq endpoint (webmention--absolute-url (match-string 1) target-url)))))
+ ;; Try <a> tags with same two patterns
+ (unless endpoint
+ (goto-char (point-min))
+ (while (and (not endpoint)
+ (re-search-forward
+ "<a[^>]+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
+ "<a[^>]+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-staging-mode-map>\\[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