cgit.sxemacs.org Git - gnus/blob - lisp/pgg-parse.el

   1 ;;; pgg-parse.el --- OpenPGP packet parsing
   2
   3 ;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
   4 ;;   2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   5
   6 ;; Author: Daiki Ueno <ueno@unixuser.org>
   7 ;; Created: 1999/10/28
   8 ;; Keywords: PGP, OpenPGP, GnuPG
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;;    This module is based on
  28
  29 ;;      [OpenPGP] RFC 2440: "OpenPGP Message Format"
  30 ;;          by John W. Noerenberg, II <jwn2@qualcomm.com>,
  31 ;;          Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>,
  32 ;;          Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com>
  33 ;;          (1998/11)
  34
  35 ;;; Code:
  36
  37 (eval-when-compile
  38   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
  39   (require 'cl))
  40
  41 (defgroup pgg-parse ()
  42   "OpenPGP packet parsing."
  43   :group 'pgg)
  44
  45 (defcustom pgg-parse-public-key-algorithm-alist
  46   '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
  47   "Alist of the assigned number to the public key algorithm."
  48   :group 'pgg-parse
  49   :type '(repeat
  50           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  51
  52 (defcustom pgg-parse-symmetric-key-algorithm-alist
  53   '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
  54   "Alist of the assigned number to the simmetric key algorithm."
  55   :group 'pgg-parse
  56   :type '(repeat
  57           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  58
  59 (defcustom pgg-parse-hash-algorithm-alist
  60   '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384)
  61     (10 . SHA512))
  62   "Alist of the assigned number to the cryptographic hash algorithm."
  63   :group 'pgg-parse
  64   :type '(repeat
  65           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  66
  67 (defcustom pgg-parse-compression-algorithm-alist
  68   '((0 . nil); Uncompressed
  69     (1 . ZIP)
  70     (2 . ZLIB))
  71   "Alist of the assigned number to the compression algorithm."
  72   :group 'pgg-parse
  73   :type '(repeat
  74           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  75
  76 (defcustom pgg-parse-signature-type-alist
  77   '((0 . "Signature of a binary document")
  78     (1 . "Signature of a canonical text document")
  79     (2 . "Standalone signature")
  80     (16 . "Generic certification of a User ID and Public Key packet")
  81     (17 . "Persona certification of a User ID and Public Key packet")
  82     (18 . "Casual certification of a User ID and Public Key packet")
  83     (19 . "Positive certification of a User ID and Public Key packet")
  84     (24 . "Subkey Binding Signature")
  85     (31 . "Signature directly on a key")
  86     (32 . "Key revocation signature")
  87     (40 . "Subkey revocation signature")
  88     (48 . "Certification revocation signature")
  89     (64 . "Timestamp signature."))
  90   "Alist of the assigned number to the signature type."
  91   :group 'pgg-parse
  92   :type '(repeat
  93           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  94
  95 (defcustom pgg-ignore-packet-checksum t; XXX
  96   "If non-nil checksum of each ascii armored packet will be ignored."
  97   :group 'pgg-parse
  98   :type 'boolean)
  99
 100 (defvar pgg-armor-header-lines
 101   '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$"
 102     "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
 103     "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$"
 104     "^-----BEGIN PGP SIGNATURE-----\r?$")
 105   "Armor headers.")
 106
 107 (eval-and-compile
 108   (defalias 'pgg-char-int (if (fboundp 'char-int)
 109                               'char-int
 110                             'identity)))
 111
 112 (defmacro pgg-format-key-identifier (string)
 113   `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c)))
 114               ,string "")
 115   ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
 116   ;;                 (string-to-number-list ,string)))
 117   )
 118
 119 (defmacro pgg-parse-time-field (bytes)
 120   `(list (logior (lsh (car ,bytes) 8)
 121                  (nth 1 ,bytes))
 122          (logior (lsh (nth 2 ,bytes) 8)
 123                  (nth 3 ,bytes))
 124          0))
 125
 126 (defmacro pgg-byte-after (&optional pos)
 127   `(pgg-char-int (char-after ,(or pos `(point)))))
 128
 129 (defmacro pgg-read-byte ()
 130   `(pgg-char-int (char-after (prog1 (point) (forward-char)))))
 131
 132 (defmacro pgg-read-bytes-string (nbytes)
 133   `(buffer-substring
 134     (point) (prog1 (+ ,nbytes (point))
 135               (forward-char ,nbytes))))
 136
 137 (defmacro pgg-read-bytes (nbytes)
 138   `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes))
 139   ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes))
 140   )
 141
 142 (defmacro pgg-read-body-string (ptag)
 143   `(if (nth 1 ,ptag)
 144        (pgg-read-bytes-string (nth 1 ,ptag))
 145      (pgg-read-bytes-string (- (point-max) (point)))))
 146
 147 (defmacro pgg-read-body (ptag)
 148   `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag))
 149   ;; `(string-to-number-list (pgg-read-body-string ,ptag))
 150   )
 151
 152 (defalias 'pgg-skip-bytes 'forward-char)
 153
 154 (defmacro pgg-skip-header (ptag)
 155   `(pgg-skip-bytes (nth 2 ,ptag)))
 156
 157 (defmacro pgg-skip-body (ptag)
 158   `(pgg-skip-bytes (nth 1 ,ptag)))
 159
 160 (defmacro pgg-set-alist (alist key value)
 161   `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
 162
 163 (when (fboundp 'define-ccl-program)
 164
 165   (define-ccl-program pgg-parse-crc24
 166     '(1
 167       ((loop
 168         (read r0) (r1 ^= r0) (r2 ^= 0)
 169         (r5 = 0)
 170         (loop
 171          (r1 <<= 1)
 172          (r1 += ((r2 >> 15) & 1))
 173          (r2 <<= 1)
 174          (if (r1 & 256)
 175              ((r1 ^= 390) (r2 ^= 19707)))
 176          (if (r5 < 7)
 177              ((r5 += 1)
 178               (repeat))))
 179         (repeat)))))
 180
 181   (defvar pgg-parse-crc24)
 182
 183   (defun pgg-parse-crc24-string (string)
 184     (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
 185       (ccl-execute-on-string pgg-parse-crc24 h string)
 186       (format "%c%c%c"
 187               (logand (aref h 1) 255)
 188               (logand (lsh (aref h 2) -8) 255)
 189               (logand (aref h 2) 255)))))
 190
 191 (defmacro pgg-parse-length-type (c)
 192   `(cond
 193     ((< ,c 192) (cons ,c 1))
 194     ((< ,c 224)
 195      (cons (+ (lsh (- ,c 192) 8)
 196               (pgg-byte-after (+ 2 (point)))
 197               192)
 198            2))
 199     ((= ,c 255)
 200      (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
 201                          (pgg-byte-after (+ 3 (point))))
 202                  (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
 203                          (pgg-byte-after (+ 5 (point)))))
 204            5))
 205     (t;partial body length
 206      '(0 . 0))))
 207
 208 (defun pgg-parse-packet-header ()
 209   (let ((ptag (pgg-byte-after))
 210         length-type content-tag packet-bytes header-bytes)
 211     (if (zerop (logand 64 ptag));Old format
 212         (progn
 213           (setq length-type (logand ptag 3)
 214                 length-type (if (= 3 length-type) 0 (lsh 1 length-type))
 215                 content-tag (logand 15 (lsh ptag -2))
 216                 packet-bytes 0
 217                 header-bytes (1+ length-type))
 218           (dotimes (i length-type)
 219             (setq packet-bytes
 220                   (logior (lsh packet-bytes 8)
 221                           (pgg-byte-after (+ 1 i (point)))))))
 222       (setq content-tag (logand 63 ptag)
 223             length-type (pgg-parse-length-type
 224                          (pgg-byte-after (1+ (point))))
 225             packet-bytes (car length-type)
 226             header-bytes (1+ (cdr length-type))))
 227     (list content-tag packet-bytes header-bytes)))
 228
 229 (defun pgg-parse-packet (ptag)
 230   (case (car ptag)
 231     (1 ;Public-Key Encrypted Session Key Packet
 232      (pgg-parse-public-key-encrypted-session-key-packet ptag))
 233     (2 ;Signature Packet
 234      (pgg-parse-signature-packet ptag))
 235     (3 ;Symmetric-Key Encrypted Session Key Packet
 236      (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
 237     ;; 4        -- One-Pass Signature Packet
 238     ;; 5        -- Secret Key Packet
 239     (6 ;Public Key Packet
 240      (pgg-parse-public-key-packet ptag))
 241     ;; 7        -- Secret Subkey Packet
 242     ;; 8        -- Compressed Data Packet
 243     (9 ;Symmetrically Encrypted Data Packet
 244      (pgg-read-body-string ptag))
 245     (10 ;Marker Packet
 246      (pgg-read-body-string ptag))
 247     (11 ;Literal Data Packet
 248      (pgg-read-body-string ptag))
 249     ;; 12       -- Trust Packet
 250     (13 ;User ID Packet
 251      (pgg-read-body-string ptag))
 252     ;; 14       -- Public Subkey Packet
 253     ;; 60 .. 63 -- Private or Experimental Values
 254     ))
 255
 256 (defun pgg-parse-packets (&optional header-parser body-parser)
 257   (let ((header-parser
 258          (or header-parser
 259              (function pgg-parse-packet-header)))
 260         (body-parser
 261          (or body-parser
 262              (function pgg-parse-packet)))
 263         result ptag)
 264     (while (> (point-max) (1+ (point)))
 265       (setq ptag (funcall header-parser))
 266       (pgg-skip-header ptag)
 267       (push (cons (car ptag)
 268                   (save-excursion
 269                     (funcall body-parser ptag)))
 270             result)
 271       (if (zerop (nth 1 ptag))
 272           (goto-char (point-max))
 273         (forward-char (nth 1 ptag))))
 274     result))
 275
 276 (defun pgg-parse-signature-subpacket-header ()
 277   (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
 278     (list (pgg-byte-after (+ (cdr length-type) (point)))
 279           (1- (car length-type))
 280           (1+ (cdr length-type)))))
 281
 282 (defun pgg-parse-signature-subpacket (ptag)
 283   (case (car ptag)
 284     (2 ;signature creation time
 285      (cons 'creation-time
 286            (let ((bytes (pgg-read-bytes 4)))
 287              (pgg-parse-time-field bytes))))
 288     (3 ;signature expiration time
 289      (cons 'signature-expiry
 290            (let ((bytes (pgg-read-bytes 4)))
 291              (pgg-parse-time-field bytes))))
 292     (4 ;exportable certification
 293      (cons 'exportability (pgg-read-byte)))
 294     (5 ;trust signature
 295      (cons 'trust-level (pgg-read-byte)))
 296     (6 ;regular expression
 297      (cons 'regular-expression
 298            (pgg-read-body-string ptag)))
 299     (7 ;revocable
 300      (cons 'revocability (pgg-read-byte)))
 301     (9 ;key expiration time
 302      (cons 'key-expiry
 303            (let ((bytes (pgg-read-bytes 4)))
 304              (pgg-parse-time-field bytes))))
 305     ;; 10 = placeholder for backward compatibility
 306     (11 ;preferred symmetric algorithms
 307      (cons 'preferred-symmetric-key-algorithm
 308            (cdr (assq (pgg-read-byte)
 309                       pgg-parse-symmetric-key-algorithm-alist))))
 310     (12 ;revocation key
 311      )
 312     (16 ;issuer key ID
 313      (cons 'key-identifier
 314            (pgg-format-key-identifier (pgg-read-body-string ptag))))
 315     (20 ;notation data
 316      (pgg-skip-bytes 4)
 317      (cons 'notation
 318            (let ((name-bytes (pgg-read-bytes 2))
 319                  (value-bytes (pgg-read-bytes 2)))
 320              (cons (pgg-read-bytes-string
 321                     (logior (lsh (car name-bytes) 8)
 322                             (nth 1 name-bytes)))
 323                    (pgg-read-bytes-string
 324                     (logior (lsh (car value-bytes) 8)
 325                             (nth 1 value-bytes)))))))
 326     (21 ;preferred hash algorithms
 327      (cons 'preferred-hash-algorithm
 328            (cdr (assq (pgg-read-byte)
 329                       pgg-parse-hash-algorithm-alist))))
 330     (22 ;preferred compression algorithms
 331      (cons 'preferred-compression-algorithm
 332            (cdr (assq (pgg-read-byte)
 333                       pgg-parse-compression-algorithm-alist))))
 334     (23 ;key server preferences
 335      (cons 'key-server-preferences
 336            (pgg-read-body ptag)))
 337     (24 ;preferred key server
 338      (cons 'preferred-key-server
 339            (pgg-read-body-string ptag)))
 340     ;; 25 = primary user id
 341     (26 ;policy URL
 342      (cons 'policy-url (pgg-read-body-string ptag)))
 343     ;; 27 = key flags
 344     ;; 28 = signer's user id
 345     ;; 29 = reason for revocation
 346     ;; 100 to 110 = internal or user-defined
 347     ))
 348
 349 (defun pgg-parse-signature-packet (ptag)
 350   (let* ((signature-version (pgg-byte-after))
 351          (result (list (cons 'version signature-version)))
 352          hashed-material field n)
 353     (cond
 354      ((= signature-version 3)
 355       (pgg-skip-bytes 2)
 356       (setq hashed-material (pgg-read-bytes 5))
 357       (pgg-set-alist result
 358                      'signature-type
 359                      (cdr (assq (pop hashed-material)
 360                                 pgg-parse-signature-type-alist)))
 361       (pgg-set-alist result
 362                      'creation-time
 363                      (pgg-parse-time-field hashed-material))
 364       (pgg-set-alist result
 365                      'key-identifier
 366                      (pgg-format-key-identifier
 367                       (pgg-read-bytes-string 8)))
 368       (pgg-set-alist result
 369                      'public-key-algorithm (pgg-read-byte))
 370       (pgg-set-alist result
 371                      'hash-algorithm (pgg-read-byte)))
 372      ((= signature-version 4)
 373       (pgg-skip-bytes 1)
 374       (pgg-set-alist result
 375                      'signature-type
 376                      (cdr (assq (pgg-read-byte)
 377                                 pgg-parse-signature-type-alist)))
 378       (pgg-set-alist result
 379                      'public-key-algorithm
 380                      (pgg-read-byte))
 381       (pgg-set-alist result
 382                      'hash-algorithm (pgg-read-byte))
 383       (when (>= 10000 (setq n (pgg-read-bytes 2)
 384                             n (logior (lsh (car n) 8)
 385                                       (nth 1 n))))
 386         (save-restriction
 387           (narrow-to-region (point)(+ n (point)))
 388           (nconc result
 389                  (mapcar (function cdr) ;remove packet types
 390                          (pgg-parse-packets
 391                           #'pgg-parse-signature-subpacket-header
 392                           #'pgg-parse-signature-subpacket)))
 393           (goto-char (point-max))))
 394       (when (>= 10000 (setq n (pgg-read-bytes 2)
 395                             n (logior (lsh (car n) 8)
 396                                       (nth 1 n))))
 397         (save-restriction
 398           (narrow-to-region (point)(+ n (point)))
 399           (nconc result
 400                  (mapcar (function cdr) ;remove packet types
 401                          (pgg-parse-packets
 402                           #'pgg-parse-signature-subpacket-header
 403                           #'pgg-parse-signature-subpacket)))))))
 404
 405     (setcdr (setq field (assq 'public-key-algorithm
 406                               result))
 407             (cdr (assq (cdr field)
 408                        pgg-parse-public-key-algorithm-alist)))
 409     (setcdr (setq field (assq 'hash-algorithm
 410                               result))
 411             (cdr (assq (cdr field)
 412                        pgg-parse-hash-algorithm-alist)))
 413     result))
 414
 415 (defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
 416   (let (result)
 417     (pgg-set-alist result
 418                    'version (pgg-read-byte))
 419     (pgg-set-alist result
 420                    'key-identifier
 421                    (pgg-format-key-identifier
 422                     (pgg-read-bytes-string 8)))
 423     (pgg-set-alist result
 424                    'public-key-algorithm
 425                    (cdr (assq (pgg-read-byte)
 426                               pgg-parse-public-key-algorithm-alist)))
 427     result))
 428
 429 (defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
 430   (let (result)
 431     (pgg-set-alist result
 432                    'version
 433                    (pgg-read-byte))
 434     (pgg-set-alist result
 435                    'symmetric-key-algorithm
 436                    (cdr (assq (pgg-read-byte)
 437                               pgg-parse-symmetric-key-algorithm-alist)))
 438     result))
 439
 440 (defun pgg-parse-public-key-packet (ptag)
 441   (let* ((key-version (pgg-read-byte))
 442          (result (list (cons 'version key-version)))
 443          field)
 444     (cond
 445      ((= 3 key-version)
 446       (pgg-set-alist result
 447                      'creation-time
 448                      (let ((bytes (pgg-read-bytes 4)))
 449                        (pgg-parse-time-field bytes)))
 450       (pgg-set-alist result
 451                      'key-expiry (pgg-read-bytes 2))
 452       (pgg-set-alist result
 453                      'public-key-algorithm (pgg-read-byte)))
 454      ((= 4 key-version)
 455       (pgg-set-alist result
 456                      'creation-time
 457                      (let ((bytes (pgg-read-bytes 4)))
 458                        (pgg-parse-time-field bytes)))
 459       (pgg-set-alist result
 460                      'public-key-algorithm (pgg-read-byte))))
 461
 462     (setcdr (setq field (assq 'public-key-algorithm
 463                               result))
 464             (cdr (assq (cdr field)
 465                        pgg-parse-public-key-algorithm-alist)))
 466     result))
 467
 468 ;; p-d-p only calls this if it is defined, but the compiler does not
 469 ;; recognize that.
 470 (declare-function pgg-parse-crc24-string "pgg-parse" (string))
 471
 472 (defun pgg-decode-packets ()
 473   (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t)
 474       (let ((p (match-beginning 0))
 475             (checksum (match-string 1)))
 476         (delete-region p (point-max))
 477         (if (ignore-errors (base64-decode-region (point-min) p))
 478             (or (not (fboundp 'pgg-parse-crc24-string))
 479                 pgg-ignore-packet-checksum
 480                 (string-equal (base64-encode-string (pgg-parse-crc24-string
 481                                                      (buffer-string)))
 482                               checksum)
 483                 (progn
 484                   (message "PGP packet checksum does not match")
 485                   nil))
 486           (message "PGP packet contain invalid base64")
 487           nil))
 488     (message "PGP packet checksum not found")
 489     nil))
 490
 491 (defun pgg-decode-armor-region (start end)
 492   (save-restriction
 493     (narrow-to-region start end)
 494     (goto-char (point-min))
 495     (re-search-forward "^-+BEGIN PGP" nil t)
 496     (delete-region (point-min)
 497                    (and (search-forward "\n\n")
 498                         (match-end 0)))
 499     (when (pgg-decode-packets)
 500       (goto-char (point-min))
 501       (pgg-parse-packets))))
 502
 503 (defun pgg-parse-armor (string)
 504   (with-temp-buffer
 505     (buffer-disable-undo)
 506     (if (fboundp 'set-buffer-multibyte)
 507         (set-buffer-multibyte nil))
 508     (insert string)
 509     (pgg-decode-armor-region (point-min)(point))))
 510
 511 (eval-and-compile
 512   (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte)
 513                                        'string-as-unibyte
 514                                      'identity)))
 515
 516 (defun pgg-parse-armor-region (start end)
 517   (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end))))
 518
 519 (provide 'pgg-parse)
 520
 521 ;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e
 522 ;;; pgg-parse.el ends here