pgg-parse.el

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