code.delx.au - gnu-emacs/blob - lisp/gnus/pgg-parse.el

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