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 'poem)
  43 (require 'pccl)
  44 (require 'pcustom)
  45 (require 'mel)
  46
  47 (defgroup pgg-parse ()
  48   "OpenPGP packet parsing"
  49   :group 'pgg)
  50
  51 (defcustom pgg-parse-public-key-algorithm-alist
  52   '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
  53   "Alist of the assigned number to the public key algorithm."
  54   :group 'pgg-parse
  55   :type 'alist)
  56
  57 (defcustom pgg-parse-symmetric-key-algorithm-alist
  58   '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
  59   "Alist of the assigned number to the simmetric key algorithm."
  60   :group 'pgg-parse
  61   :type 'alist)
  62
  63 (defcustom pgg-parse-hash-algorithm-alist
  64   '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2))
  65   "Alist of the assigned number to the cryptographic hash algorithm."
  66   :group 'pgg-parse
  67   :type 'alist)
  68
  69 (defcustom pgg-parse-compression-algorithm-alist
  70   '((0 . nil); Uncompressed
  71     (1 . ZIP)
  72     (2 . ZLIB))
  73   "Alist of the assigned number to the compression algorithm."
  74   :group 'pgg-parse
  75   :type 'alist)
  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 'alist)
  94
  95 (defcustom pgg-ignore-packet-checksum (featurep 'xemacs); XXX
  96   "If non-nil checksum of each ascii armored packet will be ignored."
  97   :group 'pgg-parse
  98   :type 'boolean)
  99
 100 (defmacro pgg-format-key-identifier (string)
 101   `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
 102                   (string-to-int-list ,string))))
 103
 104 (defmacro pgg-parse-time-field (bytes)
 105   `(list (logior (lsh (car ,bytes) 8)
 106                  (nth 1 ,bytes))
 107          (logior (lsh (nth 2 ,bytes) 8)
 108                  (nth 3 ,bytes))
 109          0))
 110
 111 (defmacro pgg-byte-after (&optional pos)
 112   `(char-int (char-after ,pos)))
 113
 114 (defmacro pgg-read-byte ()
 115   `(char-int (char-after (prog1 (point) (forward-char)))))
 116
 117 (defmacro pgg-read-bytes-string (nbytes)
 118   `(buffer-substring
 119     (point) (prog1 (+ ,nbytes (point))
 120               (forward-char ,nbytes))))
 121
 122 (defmacro pgg-read-bytes (nbytes)
 123   `(string-to-int-list (pgg-read-bytes-string ,nbytes)))
 124
 125 (defmacro pgg-read-body-string (ptag)
 126   `(if (nth 1 ,ptag)
 127        (pgg-read-bytes-string (nth 1 ,ptag))
 128      (pgg-read-bytes-string (- (point-max) (point)))))
 129
 130 (defmacro pgg-read-body (ptag)
 131   `(string-to-int-list (pgg-read-body-string ,ptag)))
 132
 133 (defalias 'pgg-skip-bytes 'forward-char)
 134
 135 (defmacro pgg-skip-header (ptag)
 136   `(pgg-skip-bytes (nth 2 ,ptag)))
 137
 138 (defmacro pgg-skip-body (ptag)
 139   `(pgg-skip-bytes (nth 1 ,ptag)))
 140
 141 (defmacro pgg-set-alist (alist key value)
 142   `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
 143
 144 (unless-broken ccl-usable
 145   (check-broken-facility ccl-cascading-read)
 146
 147   (define-ccl-program pgg-parse-crc24
 148     '(1
 149       ((r1 = 183) (r2 = 1230)
 150        (loop
 151         (read r0) (r1 ^= r0) (r2 ^= 0)
 152         (r5 = 0)
 153         (loop
 154          (r1 <<= 1)
 155          (r1 += ((r2 >> 15) & 1))
 156          (r2 <<= 1)
 157          (if (r1 & 256)
 158              ((r1 ^= 390) (r2 ^= 19707)))
 159          (if (r5 < 7)
 160              ((r5 += 1)
 161               (repeat))))
 162         (repeat)))
 163       ((r1 &= 255)
 164        (r3 = (r2 & 255))
 165        (r2 = ((r2 >> 8) & 255))
 166        (write r1 r2 r3))))
 167
 168   (make-ccl-coding-system
 169    'pgg-parse-crc24 ?C "CRC24 checker"
 170    'pgg-parse-crc24 'pgg-parse-crc24)
 171
 172   (defun pgg-parse-crc24-string (string)
 173     (encode-coding-string string 'pgg-parse-crc24))
 174   )
 175
 176 (defmacro pgg-parse-length-type (c)
 177   `(cond
 178     ((< ,c 192) (cons ,c 1))
 179     ((< ,c 224)
 180      (cons (+ (lsh (- ,c 192) 8)
 181               (pgg-byte-after (+ 2 (point)))
 182               192)
 183            2))
 184     ((= ,c 255)
 185      (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
 186                          (pgg-byte-after (+ 3 (point))))
 187                  (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
 188                          (pgg-byte-after (+ 5 (point)))))
 189            5))
 190     (t;partial body length
 191      '(0 . 0))))
 192
 193 (defun pgg-parse-packet-header ()
 194   (let ((ptag (pgg-byte-after))
 195         length-type content-tag packet-bytes header-bytes)
 196     (if (zerop (logand 64 ptag));Old format
 197         (progn
 198           (setq length-type (logand ptag 3)
 199                 length-type (if (= 3 length-type) 0 (lsh 1 length-type))
 200                 content-tag (logand 15 (lsh ptag -2))
 201                 packet-bytes 0
 202                 header-bytes (1+ length-type))
 203           (dotimes (i length-type)
 204             (setq packet-bytes
 205                   (logior (lsh packet-bytes 8)
 206                           (pgg-byte-after (+ 1 i (point))))))
 207           )
 208       (setq content-tag (logand 63 ptag)
 209             length-type (pgg-parse-length-type
 210                          (pgg-byte-after (1+ (point))))
 211             packet-bytes (car length-type)
 212             header-bytes (1+ (cdr length-type))))
 213     (list content-tag packet-bytes header-bytes)))
 214
 215 (defun pgg-parse-packet (ptag)
 216   (case (car ptag)
 217     (1 ;Public-Key Encrypted Session Key Packet
 218      (pgg-parse-public-key-encrypted-session-key-packet ptag))
 219     (2 ;Signature Packet
 220      (pgg-parse-signature-packet ptag))
 221     (3 ;Symmetric-Key Encrypted Session Key Packet
 222      (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
 223     ;; 4        -- One-Pass Signature Packet
 224     ;; 5        -- Secret Key Packet
 225     (6 ;Public Key Packet
 226      (pgg-parse-public-key-packet ptag))
 227     ;; 7        -- Secret Subkey Packet
 228     ;; 8        -- Compressed Data Packet
 229     (9 ;Symmetrically Encrypted Data Packet
 230      (pgg-read-body ptag))
 231     (10 ;Marker Packet
 232      (pgg-read-body ptag))
 233     (11 ;Literal Data Packet
 234      (pgg-read-body ptag))
 235     ;; 12       -- Trust Packet
 236     (13 ;User ID Packet
 237      (pgg-read-body ptag))
 238     ;; 14       -- Public Subkey Packet
 239     ;; 60 .. 63 -- Private or Experimental Values
 240     ))
 241
 242 (defun pgg-parse-packets (&optional header-parser body-parser)
 243   (let ((header-parser
 244          (or header-parser
 245              (function pgg-parse-packet-header)))
 246         (body-parser
 247          (or body-parser
 248              (function pgg-parse-packet)))
 249         result ptag)
 250     (while (> (point-max) (1+ (point)))
 251       (setq ptag (funcall header-parser))
 252       (pgg-skip-header ptag)
 253       (push (cons (car ptag)
 254                   (save-excursion
 255                     (funcall body-parser ptag)))
 256             result)
 257       (if (zerop (nth 1 ptag))
 258           (goto-char (point-max))
 259         (forward-char (nth 1 ptag))))
 260     result))
 261
 262 (defun pgg-parse-signature-subpacket-header ()
 263   (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
 264     (list (pgg-byte-after (+ (cdr length-type) (point)))
 265           (1- (car length-type))
 266           (1+ (cdr length-type)))))
 267
 268 (defun pgg-parse-signature-subpacket (ptag)
 269   (case (car ptag)
 270     (2 ;signature creation time
 271      (cons 'creation-time
 272            (let ((bytes (pgg-read-bytes 4)))
 273              (pgg-parse-time-field bytes))))
 274     (3 ;signature expiration time
 275      (cons 'signature-expiry
 276            (let ((bytes (pgg-read-bytes 4)))
 277              (pgg-parse-time-field bytes))))
 278     (4 ;exportable certification
 279      (cons 'exportability (pgg-read-byte)))
 280     (5 ;trust signature
 281      (cons 'trust-level (pgg-read-byte)))
 282     (6 ;regular expression
 283      (cons 'regular-expression
 284            (pgg-read-body ptag)))
 285     (7 ;revocable
 286      (cons 'revocability (pgg-read-byte)))
 287     (9 ;key expiration time
 288      (cons 'key-expiry
 289            (let ((bytes (pgg-read-bytes 4)))
 290              (pgg-parse-time-field bytes))))
 291     ;; 10 = placeholder for backward compatibility
 292     (11 ;preferred symmetric algorithms
 293      (cons 'preferred-symmetric-key-algorithm
 294            (cdr (assq (pgg-read-byte)
 295                       pgg-parse-symmetric-key-algorithm-alist))))
 296     (12 ;revocation key
 297      )
 298     (16 ;issuer key ID
 299      (cons 'key-identifier
 300            (pgg-format-key-identifier (pgg-read-body-string ptag))))
 301     (20 ;notation data
 302      (pgg-skip-bytes 4)
 303      (cons 'notation
 304            (let ((name-bytes (pgg-read-bytes 2))
 305                  (value-bytes (pgg-read-bytes 2)))
 306              (cons (pgg-read-bytes-string
 307                     (logior (lsh (car name-bytes) 8)
 308                             (nth 1 name-bytes)))
 309                    (pgg-read-bytes-string
 310                     (logior (lsh (car value-bytes) 8)
 311                             (nth 1 value-bytes))))))
 312      )
 313     (21 ;preferred hash algorithms
 314      (cons 'preferred-hash-algorithm
 315            (cdr (assq (pgg-read-byte)
 316                       pgg-parse-hash-algorithm-alist))))
 317     (22 ;preferred compression algorithms
 318      (cons 'preferred-compression-algorithm
 319            (cdr (assq (pgg-read-byte)
 320                       pgg-parse-compression-algorithm-alist))))
 321     (23 ;key server preferences
 322      )
 323     ;; 24 = preferred key server
 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       )
 357      ((= signature-version 4)
 358       (pgg-skip-bytes 1)
 359       (pgg-set-alist result
 360                      'signature-type
 361                      (cdr (assq (pgg-read-byte)
 362                                 pgg-parse-signature-type-alist)))
 363       (pgg-set-alist result
 364                      'public-key-algorithm
 365                      (pgg-read-byte))
 366       (pgg-set-alist result
 367                      'hash-algorithm (pgg-read-byte))
 368       (when (>= 10000 (setq n (pgg-read-bytes 2)
 369                             n (logior (lsh (car n) 8)
 370                                       (nth 1 n))))
 371         (save-restriction
 372           (narrow-to-region (point)(+ n (point)))
 373           (nconc result
 374                  (mapcar (function cdr) ;remove packet types
 375                          (pgg-parse-packets
 376                           #'pgg-parse-signature-subpacket-header
 377                           #'pgg-parse-signature-subpacket)))
 378           (goto-char (point-max)))
 379         )
 380       (when (>= 10000 (setq n (pgg-read-bytes 2)
 381                             n (logior (lsh (car n) 8)
 382                                       (nth 1 n))))
 383         (save-restriction
 384           (narrow-to-region (point)(+ n (point)))
 385           (nconc result
 386                  (mapcar (function cdr) ;remove packet types
 387                          (pgg-parse-packets
 388                           #'pgg-parse-signature-subpacket-header
 389                           #'pgg-parse-signature-subpacket)))
 390           ))
 391       ))
 392
 393     (setcdr (setq field (assq 'public-key-algorithm
 394                               result))
 395             (cdr (assq (cdr field)
 396                        pgg-parse-public-key-algorithm-alist)))
 397     (setcdr (setq field (assq 'hash-algorithm
 398                               result))
 399             (cdr (assq (cdr field)
 400                        pgg-parse-hash-algorithm-alist)))
 401     result))
 402
 403 (defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
 404   (let (result)
 405     (pgg-set-alist result
 406                    'version (pgg-read-byte))
 407     (pgg-set-alist result
 408                    'key-identifier
 409                    (pgg-format-key-identifier
 410                     (pgg-read-bytes-string 8)))
 411     (pgg-set-alist result
 412                    'public-key-algorithm
 413                    (cdr (assq (pgg-read-byte)
 414                               pgg-parse-public-key-algorithm-alist)))
 415     result))
 416
 417 (defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
 418   (let (result)
 419     (pgg-set-alist result
 420                    'version
 421                    (pgg-read-byte))
 422     (pgg-set-alist result
 423                    'symmetric-key-algorithm
 424                    (cdr (assq (pgg-read-byte)
 425                               pgg-parse-symmetric-key-algorithm-alist)))
 426     result))
 427
 428 (defun pgg-parse-public-key-packet (ptag)
 429   (let* ((key-version (pgg-read-byte))
 430          (result (list (cons 'version key-version)))
 431          field)
 432     (cond
 433      ((= 3 key-version)
 434       (pgg-set-alist result
 435                      'creation-time
 436                      (let ((bytes (pgg-read-bytes 4)))
 437                        (pgg-parse-time-field bytes)))
 438       (pgg-set-alist result
 439                      'key-expiry (pgg-read-bytes 2))
 440       (pgg-set-alist result
 441                      'public-key-algorithm (pgg-read-byte))
 442       )
 443      ((= 4 key-version)
 444       (pgg-set-alist result
 445                      'creation-time
 446                      (let ((bytes (pgg-read-bytes 4)))
 447                        (pgg-parse-time-field bytes)))
 448       (pgg-set-alist result
 449                      'public-key-algorithm (pgg-read-byte))
 450       ))
 451
 452     (setcdr (setq field (assq 'public-key-algorithm
 453                               result))
 454             (cdr (assq (cdr field)
 455                        pgg-parse-public-key-algorithm-alist)))
 456     result))
 457
 458 (defun pgg-decode-packets ()
 459   (let* ((marker
 460           (set-marker (make-marker)
 461                       (and (re-search-forward "^=")
 462                            (match-beginning 0))))
 463          (checksum (buffer-substring (point) (+ 4 (point)))))
 464     (delete-region marker (point-max))
 465     (mime-decode-region (point-min) marker "base64")
 466     (static-when (fboundp 'pgg-parse-crc24-string )
 467       (or pgg-ignore-packet-checksum
 468           (string-equal (mime-encode-string
 469                          (pgg-parse-crc24-string
 470                           (buffer-substring (point-min)(point-max)))
 471                          "base64")
 472                         checksum)
 473           (error "PGP packet checksum does not match.")))))
 474
 475 ;;;###autoload
 476 (defun pgg-decode-armor-region (start end)
 477   (save-restriction
 478     (narrow-to-region start end)
 479     (goto-char (point-min))
 480     (re-search-forward "^-+BEGIN PGP" nil t)
 481     (delete-region (point-min)
 482                    (and (search-forward "\n\n")
 483                         (match-end 0)))
 484     (pgg-decode-packets)
 485     (goto-char (point-min))
 486     (pgg-parse-packets)))
 487
 488 (defun pgg-parse-armor (string)
 489   (with-temp-buffer
 490     (buffer-disable-undo)
 491     (set-buffer-multibyte nil)
 492     (insert string)
 493     (pgg-decode-armor-region (point-min)(point))))
 494
 495 (defun pgg-parse-armor-region (start end)
 496   (pgg-parse-armor (string-as-unibyte (buffer-substring start end))))
 497
 498 (provide 'pgg-parse)
 499
 500 ;;; pgg-parse.el ends here