;;; epa-ks.el --- the EasyPG Assistant -*- lexical-binding: t -*-

;; Copyright (C) 2020 Free Software Foundation, Inc.

;; Author: Philip K. <philip@warpmail.net>
;; 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 <https://www.gnu.org/licenses/>.

;;; 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