epg.el

   1 (defgroup epg ()
   2   "EasyPG, yet another GnuPG interface.")
   3
   4 (defcustom epg-gpg-program "gpg"
   5   "The `gpg' executable."
   6   :group 'epg
   7   :type 'string)
   8
   9 (defvar epg-user-id nil
  10   "GnuPG ID of your default identity.")
  11
  12 (defvar epg-user-id-alist nil
  13   "An alist mapping from key ID to user ID.")
  14
  15 (defvar epg-read-point nil)
  16 (defvar epg-pending-status-list nil)
  17 (defvar epg-key-id nil)
  18 (defvar epg-context nil)
  19 (defvar epg-debug nil)
  20
  21 (defvar epg-colons-pub-spec
  22   '((trust "[^:]")
  23     (length "[0-9]+" 0 string-to-number)
  24     (algorithm "[0-9]+" 0 string-to-number)
  25     (key-id "[^:]+")
  26     (creation-date "[0-9]+")
  27     (expiration-date "[0-9]+")
  28     nil
  29     (ownertrust "[^:]")
  30     nil
  31     nil
  32     (capability "[escaESCA]*"))
  33   "The schema of keylisting output whose type is \"pub\".
  34 This is used by `epg-list-keys'.")
  35
  36 (defvar epg-colons-sec-spec
  37   '((trust "[^:]")
  38     (length "[0-9]+" 0 string-to-number)
  39     (algorithm "[0-9]+" 0 string-to-number)
  40     (key-id "[^:]+")
  41     (creation-date "[0-9]+")
  42     (expiration-date "[0-9]+")
  43     nil
  44     (ownertrust "[^:]"))
  45 "The schema of keylisting output whose type is \"sec\".
  46 This is used by `epg-list-keys'.")
  47
  48 (defvar epg-colons-uid-spec
  49   '((trust "[^:]")
  50     nil
  51     nil
  52     nil
  53     (creation-date "[0-9]+")
  54     (expiration-date "[0-9]+")
  55     (hash "[^:]+")
  56     nil
  57     (user-id "[^:]+"))
  58   "The schema of keylisting output whose type is \"uid\".
  59 This is used by `epg-list-keys'.")
  60
  61 (defun epg-make-context (&optional protocol armor textmode include-certs
  62                                    process output-file result)
  63   "Return a context object."
  64   (vector protocol armor textmode include-certs
  65           (list #'epg-passphrase-callback)
  66           (list #'epg-progress-callback)
  67           nil process output-file result))
  68
  69 (defun epg-context-protocol (context)
  70   "Return the protocol used within the context."
  71   (aref context 0))
  72
  73 (defun epg-context-armor (context)
  74   "Return t if the output shouled be ASCII armored in the CONTEXT context."
  75   (aref context 1))
  76
  77 (defun epg-context-textmode (context)
  78   "Return t if canonical text mode should be used in the CONTEXT context."
  79   (aref context 2))
  80
  81 (defun epg-context-include-certs (context)
  82   "Return how many certificates should be included in an S/MIME signed
  83 message."
  84   (aref context 3))
  85
  86 (defun epg-context-passphrase-callback (context)
  87   "Return the function used to query passphrase."
  88   (aref context 4))
  89
  90 (defun epg-context-progress-callback (context)
  91   "Return the function which handles progress update."
  92   (aref context 5))
  93
  94 (defun epg-context-signers (context)
  95   "Return the list of key-id for singning."
  96   (aref context 6))
  97
  98 (defun epg-context-process (context)
  99   "Return the process object of `epg-gpg-program'.
 100 This function is for internal use only."
 101   (aref context 7))
 102
 103 (defun epg-context-output-file (context)
 104   "Return the output file of `epg-gpg-program'.
 105 This function is for internal use only."
 106   (aref context 8))
 107
 108 (defun epg-context-result (context name)
 109   "Return the result of the previous cryptographic operation."
 110   (cdr (assq name (aref context 9))))
 111
 112 (defun epg-context-set-protocol (context protocol)
 113   "Set the protocol used within the context."
 114   (aset context 0 protocol))
 115
 116 (defun epg-context-set-armor (context armor)
 117   "Specify if the output shouled be ASCII armored in the CONTEXT context."
 118   (aset context 1 armor))
 119
 120 (defun epg-context-set-textmode (context textmode)
 121   "Specify if canonical text mode should be used in the CONTEXT context."
 122   (aset context 2 textmode))
 123
 124 (defun epg-context-set-include-certs (context include-certs)
 125  "Set how many certificates should be included in an S/MIME signed message."
 126   (aset context 3 include-certs))
 127
 128 (defun epg-context-set-passphrase-callback (context passphrase-callback
 129                                                     &optional handback)
 130   "Set the function used to query passphrase."
 131   (aset context 4 (cons passphrase-callback handback)))
 132
 133 (defun epg-context-set-progress-callback (context progress-callback
 134                                                   &optional handback)
 135   "Set the function which handles progress update."
 136   (aset context 5 (cons progress-callback handback)))
 137
 138 (defun epg-context-set-signers (context signers)
 139  "Set the list of key-id for singning."
 140   (aset context 6 signers))
 141
 142 (defun epg-context-set-process (context process)
 143   "Set the process object of `epg-gpg-program'.
 144 This function is for internal use only."
 145   (aset context 7 process))
 146
 147 (defun epg-context-set-output-file (context output-file)
 148   "Set the output file of `epg-gpg-program'.
 149 This function is for internal use only."
 150   (aset context 8 output-file))
 151
 152 (defun epg-context-set-result (context name result)
 153   "Set the result of the previous cryptographic operation."
 154   (let ((entry (assq name (aref context 9))))
 155     (if entry
 156         (setcdr entry result)
 157       (aset context 9 (cons (cons name result) (aref context 9))))))
 158
 159 (defun epg-make-signature (status key-id user-id)
 160   "Return a signature object."
 161   (vector status key-id user-id nil))
 162
 163 (defun epg-signature-status (signature)
 164   "Return the status code of SIGNATURE."
 165   (aref signature 0))
 166
 167 (defun epg-signature-key-id (signature)
 168   "Return the key-id of SIGNATURE."
 169   (aref signature 1))
 170
 171 (defun epg-signature-user-id (signature)
 172   "Return the user-id of SIGNATURE."
 173   (aref signature 2))
 174
 175 (defun epg-signature-validity (signature)
 176   "Return the validity of SIGNATURE."
 177   (aref signature 3))
 178
 179 (defun epg-signature-set-status (signature status)
 180  "Set the status code of SIGNATURE."
 181   (aset signature 0 status))
 182
 183 (defun epg-signature-set-key-id (signature key-id)
 184  "Set the key-id of SIGNATURE."
 185   (aset signature 1 key-id))
 186
 187 (defun epg-signature-set-user-id (signature user-id)
 188  "Set the user-id of SIGNATURE."
 189   (aset signature 2 user-id))
 190
 191 (defun epg-signature-set-validity (signature validity)
 192  "Set the validity of SIGNATURE."
 193   (aset signature 3 validity))
 194
 195 (defun epg-start (context args)
 196   "Start `epg-gpg-program' in a subprocess with given ARGS."
 197   (let* ((args (append (list "--no-tty"
 198                              "--status-fd" "1"
 199                              "--command-fd" "0"
 200                              "--yes") ; overwrite
 201                        (if (epg-context-armor context) '("--armor"))
 202                        (if (epg-context-textmode context) '("--textmode"))
 203                        (if (epg-context-output-file context)
 204                            (list "--output" (epg-context-output-file context)))
 205                        args))
 206          (coding-system-for-write 'binary)
 207          process-connection-type
 208          (orig-mode (default-file-modes))
 209          (buffer (generate-new-buffer " *epg*"))
 210          process)
 211     (with-current-buffer buffer
 212       (make-local-variable 'epg-read-point)
 213       (setq epg-read-point (point-min))
 214       (make-local-variable 'epg-pending-status-list)
 215       (setq epg-pending-status-list nil)
 216       (make-local-variable 'epg-key-id)
 217       (setq epg-key-id nil)
 218       (make-local-variable 'epg-context)
 219       (setq epg-context context))
 220     (unwind-protect
 221         (progn
 222           (set-default-file-modes 448)
 223           (setq process
 224                 (apply #'start-process "epg" buffer epg-gpg-program args)))
 225       (set-default-file-modes orig-mode))
 226     (set-process-filter process #'epg-process-filter)
 227     (epg-context-set-process context process)))
 228
 229 (defun epg-process-filter (process input)
 230   (if epg-debug
 231       (save-excursion
 232         (set-buffer (get-buffer-create  " *epg-debug*"))
 233         (goto-char (point-max))
 234         (insert input)))
 235   (if (buffer-live-p (process-buffer process))
 236       (save-excursion
 237         (set-buffer (process-buffer process))
 238         (goto-char (point-max))
 239         (insert input)
 240         (goto-char epg-read-point)
 241         (beginning-of-line)
 242         (while (looking-at ".*\n")      ;the input line is finished
 243           (save-excursion
 244             (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\) ?\\(.*\\)")
 245                 (let* ((status (match-string 1))
 246                        (string (match-string 2))
 247                        (symbol (intern-soft (concat "epg-status-" status))))
 248                   (if (member status epg-pending-status-list)
 249                       (setq epg-pending-status-list nil))
 250                   (if (and symbol
 251                            (fboundp symbol))
 252                       (funcall symbol process string)))))
 253           (forward-line))
 254         (setq epg-read-point (point)))))
 255
 256 (defun epg-read-output (context)
 257   (with-temp-buffer
 258     (set-buffer-multibyte nil)
 259     (if (file-exists-p (epg-context-output-file context))
 260         (let ((coding-system-for-read (if (epg-context-output-file context)
 261                                           'raw-text
 262                                       'binary)))
 263           (insert-file-contents (epg-context-output-file context))
 264           (buffer-string)))))
 265
 266 (defun epg-wait-for-status (context status-list)
 267   (with-current-buffer (process-buffer (epg-context-process context))
 268     (setq epg-pending-status-list status-list)
 269     (while (and (eq (process-status (epg-context-process context)) 'run)
 270                 epg-pending-status-list)
 271       (accept-process-output (epg-context-process context) 1))))
 272
 273 (defun epg-wait-for-completion (context)
 274   (process-send-eof (epg-context-process context))
 275   (while (eq (process-status (epg-context-process context)) 'run)
 276     ;; We can't use accept-process-output instead of sit-for here
 277     ;; because it may cause an interrupt during the sentinel execution.
 278     (sit-for 0.1)))
 279
 280 (defun epg-reset (context)
 281   (if (and (epg-context-process context)
 282            (buffer-live-p (process-buffer (epg-context-process context))))
 283       (kill-buffer (process-buffer (epg-context-process context))))
 284   (epg-context-set-process context nil)
 285   (if (file-exists-p (epg-context-output-file context))
 286       (delete-file (epg-context-output-file context)))
 287   (aset context 9 nil))
 288
 289 (defun epg-status-USERID_HINT (process string)
 290   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 291       (let* ((key-id (match-string 1 string))
 292              (user-id (match-string 2 string))
 293              (entry (assoc key-id epg-user-id-alist)))
 294         (if entry
 295             (setcdr entry user-id)
 296           (setq epg-user-id-alist (cons (cons key-id user-id)
 297                                         epg-user-id-alist))))))
 298
 299 (defun epg-status-NEED_PASSPHRASE (process string)
 300   (if (string-match "\\`\\([^ ]+\\)" string)
 301       (setq epg-key-id (match-string 1 string))))
 302
 303 (defun epg-status-NEED_PASSPHRASE_SYM (process string)
 304   (setq epg-key-id 'SYM))
 305
 306 (defun epg-status-NEED_PASSPHRASE_PIN (process string)
 307   (setq epg-key-id 'PIN))
 308
 309 (defun epg-status-GET_HIDDEN (process string)
 310   (let ((passphrase (funcall
 311                      (car (epg-context-passphrase-callback epg-context))
 312                      epg-key-id
 313                      (cdr (epg-context-passphrase-callback epg-context)))))
 314     (unwind-protect
 315         (if passphrase
 316             (process-send-string process (concat passphrase "\n")))
 317       (fillarray passphrase 0))))
 318
 319 (defun epg-status-GOODSIG (process string)
 320   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 321       (epg-context-set-result
 322        epg-context
 323        'verify
 324        (cons (epg-make-signature 'good
 325                                  (match-string 1 string)
 326                                  (match-string 2 string))
 327              (epg-context-result epg-context 'verify)))))
 328
 329 (defun epg-status-EXPSIG (process string)
 330   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 331       (epg-context-set-result
 332        epg-context
 333        'verify
 334        (cons (epg-make-signature 'expired
 335                                  (match-string 1 string)
 336                                  (match-string 2 string))
 337              (epg-context-result epg-context 'verify)))))
 338
 339 (defun epg-status-EXPKEYSIG (process string)
 340   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 341       (epg-context-set-result
 342        epg-context
 343        'verify
 344        (cons (epg-make-signature 'expired-key
 345                                  (match-string 1 string)
 346                                  (match-string 2 string))
 347              (epg-context-result epg-context 'verify)))))
 348
 349 (defun epg-status-REVKEYSIG (process string)
 350   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 351       (epg-context-set-result
 352        epg-context
 353        'verify
 354        (cons (epg-make-signature 'revoked-key
 355                                  (match-string 1 string)
 356                                  (match-string 2 string))
 357              (epg-context-result epg-context 'verify)))))
 358
 359 (defun epg-status-BADSIG (process string)
 360   (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
 361       (epg-context-set-result
 362        epg-context
 363        'verify
 364        (cons (epg-make-signature 'bad
 365                                  (match-string 1 string)
 366                                  (match-string 2 string))
 367              (epg-context-result epg-context 'verify)))))
 368
 369 (defun epg-status-TRUST_UNDEFINED (process string)
 370   (let ((signature (car (epg-context-result epg-context 'verify))))
 371     (if (and signature
 372              (eq (epg-signature-status signature) 'good))
 373         (epg-signature-set-validity signature 'unknown))))
 374
 375 (defun epg-status-TRUST_NEVER (process string)
 376   (let ((signature (car (epg-context-result epg-context 'verify))))
 377     (if (and signature
 378              (eq (epg-signature-status signature) 'good))
 379         (epg-signature-set-validity signature 'never))))
 380
 381 (defun epg-status-TRUST_MARGINAL (process string)
 382   (let ((signature (car (epg-context-result epg-context 'verify))))
 383     (if (and signature
 384              (eq (epg-signature-status signature) 'marginal))
 385         (epg-signature-set-validity signature 'marginal))))
 386
 387 (defun epg-status-TRUST_FULLY (process string)
 388   (let ((signature (car (epg-context-result epg-context 'verify))))
 389     (if (and signature
 390              (eq (epg-signature-status signature) 'good))
 391         (epg-signature-set-validity signature 'full))))
 392
 393 (defun epg-status-TRUST_ULTIMATE (process string)
 394   (let ((signature (car (epg-context-result epg-context 'verify))))
 395     (if (and signature
 396              (eq (epg-signature-status signature) 'good))
 397         (epg-signature-set-validity signature 'full))))
 398
 399 (defun epg-status-DECRYPTION_FAILED (process string)
 400   (epg-context-set-result epg-context 'decrypt 'failed))
 401
 402 (defun epg-status-PROGRESS (process string)
 403   (if (string-match "\\`\\([^ ]+\\) \\([^ ]\\) \\([0-9]+\\) \\([0-9]+\\)"
 404                     string)
 405       (funcall (car (epg-context-progress-callback epg-context))
 406                (match-string 1 string)
 407                (match-string 2 string)
 408                (string-to-number (match-string 3 string))
 409                (string-to-number (match-string 4 string)))))
 410
 411 (defun epg-passphrase-callback (key-id handback)
 412   (read-passwd
 413    (if (eq key-id 'SYM)
 414        "GnuPG passphrase for symmetric encryption: "
 415      (if (eq key-id 'PIN)
 416          "GnuPG passphrase for PIN: "
 417        (format "GnuPG passphrase for %s: "
 418                (let ((entry (assoc key-id epg-user-id-alist)))
 419                  (if entry
 420                      (cdr entry)
 421                    key-id)))))))
 422
 423 (defun epg-progress-callback (what char current total handback)
 424   (message "%s: %d%%/%d%%" what current total))
 425
 426 (defun epg-list-keys (name &optional secret)
 427   "List keys associated with STRING."
 428   (let ((args (list "--with-colons" "--no-greeting" "--batch"
 429                     "--fixed-list-mode"
 430                     (if secret "--list-secret-keys" "--list-keys")
 431                     name))
 432         keys type symbol pointer)
 433     (with-temp-buffer
 434       (apply #'call-process epg-gpg-program nil (list t nil) nil args)
 435       (goto-char (point-min))
 436       (while (looking-at "\\([a-z][a-z][a-z]\\):\\(.*\\)")
 437         (setq type (match-string 1)
 438               symbol (intern-soft (format "epg-colons-%s-spec" type)))
 439         (if (member type '("pub" "sec"))
 440             (setq keys (cons nil keys)))
 441         (if (and symbol
 442                  (boundp symbol))
 443             (setcar keys (cons (cons (intern type)
 444                                      (epg-parse-colons
 445                                       (symbol-value symbol)
 446                                       (match-string 2)))
 447                                (car keys))))
 448         (forward-line)))
 449     (setq pointer keys)
 450     (while pointer
 451       (setcar pointer (nreverse (car pointer)))
 452       (setq pointer (cdr pointer)))
 453     (nreverse keys)))
 454
 455 (defun epg-parse-colons (alist string)
 456   (let ((index 0)
 457         result)
 458     (while (and alist
 459                 (or (null (car alist))
 460                     (eq index
 461                         (string-match
 462                          (concat "\\(" (nth 1 (car alist)) "\\)?:")
 463                          string index))))
 464       (if (car alist)
 465           (progn
 466             (setq index (match-end 0))
 467             (if (match-beginning 1)
 468                 (setq result
 469                       (cons (cons (car (car alist))
 470                                   (funcall (or (nth 3 (car alist)) #'identity)
 471                                            (match-string
 472                                             (1+ (or (nth 2 (car alist)) 0))
 473                                             string)))
 474                             result))))
 475         (setq index (1+ index)))
 476       (setq alist (cdr alist)))
 477     (nreverse result)))
 478
 479 ;;;###autoload
 480 (defun epg-decrypt-start (context input-file)
 481   "Initiate a decrypt operation."
 482   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
 483   (epg-start context
 484              (list "--decrypt" input-file))
 485   (epg-wait-for-status context '("BEGIN_DECRYPTION")))
 486
 487 ;;;###autoload
 488 (defun epg-decrypt-string (context string)
 489   "Decrypt STRING."
 490   (let ((input-file (epg-make-temp-file "epg-input"))
 491         (coding-system-for-write 'binary))
 492     (unwind-protect
 493         (progn
 494           (write-region string nil input-file)
 495           (epg-decrypt-start context input-file)
 496           (epg-wait-for-completion context)
 497           (unless (epg-context-result context 'decrypt)
 498             (epg-read-output context)))
 499       (epg-reset context)
 500       (if (file-exists-p input-file)
 501           (delete-file input-file)))))
 502
 503 ;;;###autoload
 504 (defun epg-verify-start (context signature &optional string)
 505   "Initiate a verify operation."
 506   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
 507   (if string
 508       ;; Detached signature.
 509       (progn
 510         (epg-start context
 511                    (append (list "--verify")
 512                            (list signature "-")))
 513         (if (eq (process-status (epg-context-process context)) 'run)
 514             (process-send-string (epg-context-process context) string)))
 515     ;; Normal (or cleartext) signature.
 516     (epg-start context
 517                (list "--verify"))
 518     (if (eq (process-status (epg-context-process context)) 'run)
 519         (process-send-string (epg-context-process context) signature))))
 520
 521 ;;;###autoload
 522 (defun epg-verify-string (context signature &optional string)
 523   "Verify SIGNATURE."
 524   (let ((input-file (epg-make-temp-file "epg-input"))
 525         (coding-system-for-write 'binary))
 526     (unwind-protect
 527         (progn
 528           (if string
 529               (write-region signature nil input-file))
 530           (epg-verify-start context input-file string)
 531           (epg-wait-for-completion context)
 532           (epg-context-result context 'verify))
 533       (epg-reset context)
 534       (if (file-exists-p input-file)
 535           (delete-file input-file)))))
 536
 537 ;;;###autoload
 538 (defun epg-sign-start (context string &optional mode)
 539   "Initiate a sign operation."
 540   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
 541   (epg-start context
 542              (append (list (if (null mode)
 543                                "--sign"
 544                              (if (or (eq mode t) (eq mode 'detached))
 545                                  "--detach-sign"
 546                                "--clearsign")))
 547                      (apply #'nconc
 548                             (mapcar (lambda (signer)
 549                                       (list "-u" signer))
 550                                     (epg-context-signers context)))))
 551   (epg-wait-for-status context '("BEGIN_SIGNING"))
 552   (if (eq (process-status (epg-context-process context)) 'run)
 553       (process-send-string (epg-context-process context) string)))
 554
 555 ;;;###autoload
 556 (defun epg-sign-string (context string &optional mode)
 557   "Sign STRING."
 558   (unwind-protect
 559       (progn
 560         (epg-sign-start context string mode)
 561         (epg-wait-for-completion context)
 562         (epg-read-output context))
 563     (epg-reset context)))
 564
 565 ;;;###autoload
 566 (defun epg-encrypt-start (context string recipients
 567                                   &optional always-trust sign)
 568   "Initiate a encrypt operation."
 569   (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
 570   (epg-start context
 571              (append (if always-trust '("--always-trust"))
 572                      (if recipients '("--encrypt") '("--symmetric"))
 573                      (if sign
 574                          (cons "--sign"
 575                                (apply #'nconc
 576                                       (mapcar (lambda (signer)
 577                                                 (list "-u" signer))
 578                                               (epg-context-signers context)))))
 579                      (apply #'nconc
 580                             (mapcar (lambda (recipient)
 581                                       (list "-r" recipient))
 582                                     recipients))))
 583   (if sign
 584       (epg-wait-for-status context '("BEGIN_SIGNING")))
 585   (if (eq (process-status (epg-context-process context)) 'run)
 586       (process-send-string (epg-context-process context) string)))
 587
 588 ;;;###autoload
 589 (defun epg-encrypt-string (context string recipients
 590                                    &optional always-trust sign)
 591   "Encrypt STRING."
 592   (unwind-protect
 593       (progn
 594         (epg-encrypt-start context string recipients always-trust sign)
 595         (epg-wait-for-completion context)
 596         (epg-read-output context))
 597     (epg-reset context)))
 598
 599 (provide 'epg)
 600
 601 ;;; epg.el ends here