From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.ciao.gmane.io!not-for-mail From: Philip K Newsgroups: gmane.emacs.bugs Subject: bug#39886: [PATCH] Add EPA keyserver client Date: Tue, 3 Mar 2020 17:23:59 +0100 Message-ID: <20200303162359.30215-1-philip@warpmail.net> Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="ciao.gmane.io:159.69.161.202"; logging-data="109469"; mail-complaints-to="usenet@ciao.gmane.io" To: 39886@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Tue Mar 03 17:25:14 2020 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1j9AM6-000SL4-6g for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 03 Mar 2020 17:25:14 +0100 Original-Received: from localhost ([::1]:49730 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1j9AM5-0006l6-23 for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 03 Mar 2020 11:25:13 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:55087) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1j9ALw-0006ku-Ca for bug-gnu-emacs@gnu.org; Tue, 03 Mar 2020 11:25:06 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1j9ALu-0006h6-Dh for bug-gnu-emacs@gnu.org; Tue, 03 Mar 2020 11:25:04 -0500 Original-Received: from debbugs.gnu.org ([209.51.188.43]:33920) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1j9ALu-0006h1-AL for bug-gnu-emacs@gnu.org; Tue, 03 Mar 2020 11:25:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1j9ALu-0000t1-5X for bug-gnu-emacs@gnu.org; Tue, 03 Mar 2020 11:25:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Philip K Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Tue, 03 Mar 2020 16:25:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 39886 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-gnu-emacs@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.15832526643355 (code B ref -1); Tue, 03 Mar 2020 16:25:01 +0000 Original-Received: (at submit) by debbugs.gnu.org; 3 Mar 2020 16:24:24 +0000 Original-Received: from localhost ([127.0.0.1]:39893 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j9ALB-0000rw-9H for submit@debbugs.gnu.org; Tue, 03 Mar 2020 11:24:24 -0500 Original-Received: from lists.gnu.org ([209.51.188.17]:57941) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1j9AL6-0000rl-9e for submit@debbugs.gnu.org; Tue, 03 Mar 2020 11:24:16 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:54880) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1j9AL3-0006XR-Gf for bug-gnu-emacs@gnu.org; Tue, 03 Mar 2020 11:24:11 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1j9AL0-0005sT-EC for bug-gnu-emacs@gnu.org; Tue, 03 Mar 2020 11:24:09 -0500 Original-Received: from out5-smtp.messagingengine.com ([66.111.4.29]:50565) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1j9AL0-0005q4-2x for bug-gnu-emacs@gnu.org; Tue, 03 Mar 2020 11:24:06 -0500 Original-Received: from compute2.internal (compute2.nyi.internal [10.202.2.42]) by mailout.nyi.internal (Postfix) with ESMTP id B67D822178 for ; Tue, 3 Mar 2020 11:24:03 -0500 (EST) Original-Received: from mailfrontend2 ([10.202.2.163]) by compute2.internal (MEProxy); Tue, 03 Mar 2020 11:24:03 -0500 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=warpmail.net; h= from:to:subject:date:message-id:mime-version :content-transfer-encoding; s=fm2; bh=Sibvf5YxmFiKgiVY7D9/S3Xo6r XetD04VLOk3TlV4HU=; b=JqByGmtgV6T4rCd8c4Jo+S7SIcU2ez2uAPStWubT9+ QlJw5Iyni69THEMvUnV8rdiQONvB0V+Q6+BqDtBt+nQgbf5S/3wlPrHtVlsR/M3E zrsp9wnnUNZmKOvHPSLaM0VYzm7oOSERi/zH0i737ALnqnrPvm+1AzlHGhKiaZMo WJo0lloS7+uQGjwhpq+nWhJ93ZPD6r30mOBlnCG/00ezg1PtzHEPPHmETd9zKfes zl3OAFM8UP61DccGYUc4gq8dWH2xjei8pNuGmgCa4VajZ3Ije28udU+AR+I2QM5u 2gHQHS7lfDmlP74JYGMdJ2rwa0+kicTbups/T3Mue6JA== DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d= messagingengine.com; h=content-transfer-encoding:date:from :message-id:mime-version:subject:to:x-me-proxy:x-me-proxy :x-me-sender:x-me-sender:x-sasl-enc; s=fm2; bh=Sibvf5YxmFiKgiVY7 D9/S3Xo6rXetD04VLOk3TlV4HU=; b=v3GASjlvETfS9qxnMq5TEVSvlGwZ4cWcw SXdIXYu2pBENPwI4LepVinKf1yzPxCLdnRC8ZjgNw18XXvo6/tjYo0hXExQlX2+m VUi1z30LGWYoO0VIj1VkPWBMsLXZNjG9jGu7uEnVu0F9p4+cGHlveFVeij8JD9VD myyLDtNtOkJum6eOpPhUvDDTYYw6W6C+fEyZYG6DHIef/dxzUGzEJIZlMk1czrT7 Bo1M+X+K++fKikUS1WXUu2bQGdXMsOYtia8Zh5EE4tpH+KBpXA29nEQSvgM52PV0 gB/1b7xUj9lXgKRYvoni1TYlM+7hqtkbHtfmm5RnIkd6ryD4xnsqw== X-ME-Sender: X-ME-Proxy-Cause: gggruggvucftvghtrhhoucdtuddrgedugedruddtiedgleduucetufdoteggodetrfdotf fvucfrrhhofhhilhgvmecuhfgrshhtofgrihhlpdfqfgfvpdfurfetoffkrfgpnffqhgen uceurghilhhouhhtmecufedttdenucenucfjughrpefhvffufffkofgggfestdekredtre dttdenucfhrhhomheprfhhihhlihhpucfmuceophhhihhlihhpseifrghrphhmrghilhdr nhgvtheqnecuffhomhgrihhnpehivghtfhdrohhrghdpghhnuhdrohhrghdpghhnuhhpgh drnhgvthdpuggvsghirghnrdhorhhgpdhusghunhhtuhdrtghomhdpshhkshdqkhgvhihs vghrvhgvrhhsrdhnvghtpdhmrgihfhhirhhsthdrohhrghenucfkphepjeelrddvudelrd duleefrddukeenucevlhhushhtvghrufhiiigvpedtnecurfgrrhgrmhepmhgrihhlfhhr ohhmpehphhhilhhiphesfigrrhhpmhgrihhlrdhnvght X-ME-Proxy: Original-Received: from localhost (p4fdbc112.dip0.t-ipconnect.de [79.219.193.18]) by mail.messagingengine.com (Postfix) with ESMTPA id CB6ED30612AF for ; Tue, 3 Mar 2020 11:24:02 -0500 (EST) X-Mailer: git-send-email 2.20.1 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:176800 Archived-At: This is a pure-elisp implementation of a keyserver client, as specified by https://tools.ietf.org/html/draft-shaw-openpgp-hkp-00. The current feature-set includes: - searching for keys (inexact search by default) - generate a interactive list of keys using tabulated-list-mode - import selected keys using epa The keyserver to use is set by epa-keyserver, and the customize interface already contains a few sensible defaults to choose from. --- lisp/epa-ks.el | 325 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 325 insertions(+) create mode 100644 lisp/epa-ks.el diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el new file mode 100644 index 0000000000..a798eec72f --- /dev/null +++ b/lisp/epa-ks.el @@ -0,0 +1,325 @@ +;;; epa-ks.el --- the EasyPG Assistant -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Philip K. +;; Keywords: PGP, GnuPG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; Keyserver client in Emacs. + +;;; Code: + +(require 'cl-lib) +(require 'epa) +(require 'subr-x) +(require 'tabulated-list) +(require 'url) +(require 'url-http) + +(defgroup epa-ks nil + "The EasyPG Assistant Keyserver client." + :version "27.1" + :group 'epa) + +(defcustom epa-keyserver "keys.gnupg.net" + "Domain of keyserver. + +This is used by `epa-ks-lookup-key', for looking up public keys." + :type '(choice :tag "Keyserver" + (const random) + (const "keyring.debian.org") + (const "keys.gnupg.net") + (const "keyserver.ubuntu.com") + (const "pgp.mit.edu") + (const "pool.sks-keyservers.net") + (const "zimmermann.mayfirst.org") + (string :tag "Custom keyserver"))) + +(cl-defstruct epa-ks-key + "Structure to hold key data." + id algo len created expires names flags) + +(cl-defstruct epa-ks-name + "Structure to hold user associated with keys data." + uid created expires flags) + +(defvar epa-ks-last-query nil + "List of arguments to pass to `epa-ks-search-keys', when + reverting a buffer to restart search.") + +(defvar epa-ks-search-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map (kbd "f") #'epa-ks--mark-key-to-fetch) + (define-key map (kbd "i") #'epa-ks--inspect-key-to-fetch) + (define-key map (kbd "u") #'epa-ks--unmark-key-to-fetch) + (define-key map (kbd "x") #'epa-ks-do-key-to-fetch) + map)) + +(define-derived-mode epa-ks-search-mode tabulated-list-mode "Keyserver" + "Major mode for listing public key search results." + (buffer-disable-undo) + (setq tabulated-list-format [("ID" 8 t) + ("Algo." 5 nil) + ("Created" 10 t) + ("Expires" 10 t) + ("User" 0 t)] + tabulated-list-sort-key '("User" . nil) + tabulated-list-padding 2) + (add-hook 'tabulated-list-revert-hook + #'epa-ks--restart-search + nil t) + (tabulated-list-init-header)) + +(defun epa-ks--inspect-key-to-fetch () + "Display full ID of key under point in the minibuffer." + (interactive) + (message "Full ID: %s" (epa-ks-key-id (car (tabulated-list-get-id))))) + +(defun epa-ks--unmark-key-to-fetch () + "Remove fetch mark for key under point. + +If a region is active, unmark all keys in active region." + (interactive) + (epa-ks--mark-key-to-fetch "")) + +(defun epa-ks--mark-key-to-fetch (tag) + "Add fetch-mark to key under point. + +If a region is active, mark all keys in active region. + +When all keys have been selected, use \\[epa-ks-do-key-to-fetch] to +actually import the keys. + +When called interactively, `epa-ks--mark-key-to-fetch' will always +add a \"F\" tag. Non-interactivly the tag must be specified by +setting the TAG parameter." + (interactive (list "F")) + (if (region-active-p) + (save-mark-and-excursion + (save-restriction + (narrow-to-region (region-beginning) (1- (region-end))) + (goto-char (point-min)) + (while (not (eobp)) + (tabulated-list-put-tag tag t)))) + (tabulated-list-put-tag tag t))) + +(defun epa-ks-do-key-to-fetch () + "Fetch all marked keys from keyserver and import them. + +Keys are marked using `epa-ks--mark-key-to-fetch'." + (interactive) + (save-excursion + (let (keys) + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at-p (rx bol "F")) + (push (epa-ks-key-id (car (tabulated-list-get-id))) + keys)) + (forward-line)) + (when (yes-or-no-p (format "Proceed fetching all %d key(s)? " + (length keys)))) + (dolist (id keys) + (epa-ks--fetch-key id)))) + (tabulated-list-clear-all-tags)) + +(defun epa-ks--fetch-key (id) + "Send request to import key with id ID." + (url-retrieve + (format "https://%s/pks/lookup?%s" + epa-keyserver + (url-build-query-string + `(("search" ,(concat "0x" (url-hexify-string id))) + ("options" "mr") + ("op" "get")))) + (lambda (status) + (when (plist-get status :error) + (error "Request failed: %s" + (caddr (assq (caddr (plist-get status :error)) + url-http-codes)))) + (forward-paragraph) + (save-excursion + (goto-char (point-max)) + (while (memq (char-before) '(? ? ?\n)) + (forward-char -1)) + (delete-region (point) (point-max))) + (let ((epa-popup-info-window nil)) + (epa-import-armor-in-region (point) (point-max))) + (kill-buffer)))) + +(defun epa-ks--display-keys (buf keys) + "Prepare KEYS for `tabulated-list-mode', for buffer BUF. + +KEYS is a list of `epa-ks-key' structures, as parsed by +`epa-ks-parse-result'." + (when (buffer-live-p buf) + (let (entries) + (dolist (key keys) + (dolist (name (epa-ks-key-names key)) + (push (list (cons key name) + (vector + (substring (epa-ks-key-id key) -8) + (cdr (epa-ks-key-algo key)) + (if (epa-ks-key-created key) + (format-time-string "%F" (epa-ks-key-created key)) + "N/A") + (if (epa-ks-key-expires key) + (let* ((date (epa-ks-key-expires key)) + (str (format-time-string "%F" date))) + (when (< 0 (time-to-seconds (time-since date))) + (setq str (propertize str 'face 'font-lock-warning-face))) + str) + (propertize "N/A" 'face 'shadow)) + (decode-coding-string + (epa-ks-name-uid name) + (select-safe-coding-system (epa-ks-name-uid name) nil 'utf-8)))) + entries))) + (with-current-buffer buf + (setq tabulated-list-entries entries) + (tabulated-list-print t t)) + (message "Press `f' to mark a key, `x' to fetch all marked keys.")))) + +(defun epa-ks--restart-search () + (when epa-ks-last-query + (apply #'epa-ks-search-keys epa-ks-last-query))) + +;;;###autoload +(defun epa-ks-search-keys (query exact) + "Ask a keyserver for all keys matching QUERY. + +The keyserver to be used is specified by `epa-keyserver'. + +If EXACT is non-nil require exact matches. Interactively, this +can be provoked using a prefix argument. + +Note that the request may fail, is the query is not specific +enough, since keyservers have strict timeout settings." + (interactive (list (read-string "Search for: ") + current-prefix-arg)) + (when (string-empty-p query) + (user-error "No query")) + (let ((buf (get-buffer-create "*Key search*"))) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (erase-buffer)) + (epa-ks-search-mode)) + (url-retrieve + (format "https://%s/pks/lookup?%s" + epa-keyserver + (url-build-query-string + (append `(("search" ,query) + ("options" "mr") + ("op" "index")) + (and exact '(("exact" "on")))))) + (lambda (status) + (when (plist-get status :error) + (when buf + (kill-buffer buf)) + (error "Request failed: %s" + (caddr (assq (caddr (plist-get status :error)) + url-http-codes)))) + (forward-paragraph) + (forward-line) + (save-match-data + ;; parse machine readable response according to + ;; https://tools.ietf.org/html/draft-shaw-openpgp-hkp-00#section-5.2 + (when (looking-at (rx bol "info:" (group (+ digit)) + ":" (* digit) eol)) + (unless (string= (match-string 1) "1") + (error "Unsupported keyserver version"))) + (let (key keys) + (forward-line) + (while (not (or (looking-at-p (rx ? eol)) + (eobp))) + (cond ((looking-at (rx bol "pub:" (group (+ alnum)) + ":" (group (* digit)) + ":" (group (* digit)) + ":" (group (* digit)) + ":" (group (* digit)) + ":" (group (* (any ?r ?d ?e))) + eol)) + (setq key + (make-epa-ks-key + :id (match-string 1) + :algo + (and (match-string 2) + (not (string-empty-p (match-string 2))) + (assoc (string-to-number (match-string 2)) + epg-pubkey-algorithm-alist)) + :len + (and (match-string 3) + (not (string-empty-p (match-string 3))) + (string-to-number (match-string 3))) + :created + (and (match-string 4) + (not (string-empty-p (match-string 4))) + (seconds-to-time + (string-to-number (match-string 4)))) + :expires + (and (match-string 5) + (not (string-empty-p (match-string 5))) + (seconds-to-time + (string-to-number (match-string 5)))) + :flags + (mapcar (lambda (flag) + (cdr (assq flag '((?r revoked) + (?d disabled) + (?e expired))))) + (match-string 6)))) + (push key keys)) + ((looking-at (rx bol "uid:" (group (+ (not ":"))) + ":" (group (* digit)) + ":" (group (* digit)) + ":" (group (* (any ?r ?d ?e))) + eol)) + (push (make-epa-ks-name + :uid (url-unhex-string (match-string 1) t) + :created + (and (match-string 2) + (not (string-empty-p (match-string 2))) + (decode-time (seconds-to-time + (string-to-number (match-string 2))))) + :expires + (and (match-string 3) + (not (string-empty-p (match-string 3))) + (decode-time (seconds-to-time + (string-to-number (match-string 3))))) + :flags + (mapcar (lambda (flag) + (cdr (assq flag '((?r revoked) + (?d disabled) + (?e expired))))) + (match-string 4))) + (epa-ks-key-names key))) + ((looking-at-p (rx bol "uat:")) + ;; user attribute fields are ignored + nil) + (t (error "Invalid server response"))) + (forward-line)) + (if buf (epa-ks--display-keys buf keys) keys) + (kill-buffer))))) + (pop-to-buffer buf) + (setq epa-ks-last-query (list query exact))) + (message "Searching keys...")) + +;;;###autoload +(defalias 'epa-search-keys 'epa-ks-search-keys) + +;;; epa-ks.el ends here -- 2.20.1