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   `(mapconcat (lambda (c) (format "%02X" (char-int c)))
 108               ,string "")
 109   ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
 110   ;;                 (string-to-int-list ,string)))
 111   )
 112
 113 (defmacro pgg-parse-time-field (bytes)
 114   `(list (logior (lsh (car ,bytes) 8)
 115                  (nth 1 ,bytes))
 116          (logior (lsh (nth 2 ,bytes) 8)
 117                  (nth 3 ,bytes))
 118          0))
 119
 120 (defmacro pgg-byte-after (&optional pos)
 121   `(char-int (char-after ,(or pos `(point)))))
 122
 123 (defmacro pgg-read-byte ()
 124   `(char-int (char-after (prog1 (point) (forward-char)))))
 125
 126 (defmacro pgg-read-bytes-string (nbytes)
 127   `(buffer-substring
 128     (point) (prog1 (+ ,nbytes (point))
 129               (forward-char ,nbytes))))
 130
 131 (defmacro pgg-read-bytes (nbytes)
 132   `(mapcar #'char-int (pgg-read-bytes-string ,nbytes))
 133   ;; `(string-to-int-list (pgg-read-bytes-string ,nbytes))
 134   )
 135
 136 (defmacro pgg-read-body-string (ptag)
 137   `(if (nth 1 ,ptag)
 138        (pgg-read-bytes-string (nth 1 ,ptag))
 139      (pgg-read-bytes-string (- (point-max) (point)))))
 140
 141 (defmacro pgg-read-body (ptag)
 142   `(mapcar #'char-int (pgg-read-body-string ,ptag))
 143   ;; `(string-to-int-list (pgg-read-body-string ,ptag))
 144   )
 145
 146 (defalias 'pgg-skip-bytes 'forward-char)
 147
 148 (defmacro pgg-skip-header (ptag)
 149   `(pgg-skip-bytes (nth 2 ,ptag)))
 150
 151 (defmacro pgg-skip-body (ptag)
 152   `(pgg-skip-bytes (nth 1 ,ptag)))
 153
 154 (defmacro pgg-set-alist (alist key value)
 155   `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
 156
 157 (unless-broken ccl-usable
 158   (define-ccl-program pgg-parse-crc24
 159     '(1
 160       ((loop
 161         (read r0) (r1 ^= r0) (r2 ^= 0)
 162         (r5 = 0)
 163         (loop
 164          (r1 <<= 1)
 165          (r1 += ((r2 >> 15) & 1))
 166          (r2 <<= 1)
 167          (if (r1 & 256)
 168              ((r1 ^= 390) (r2 ^= 19707)))
 169          (if (r5 < 7)
 170              ((r5 += 1)
 171               (repeat))))
 172         (repeat)))))
 173
 174   (defun pgg-parse-crc24-string (string)
 175     (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
 176       (ccl-execute-on-string pgg-parse-crc24 h string)
 177       (format "%c%c%c"
 178               (logand (aref h 1) 255)
 179               (logand (lsh (aref h 2) -8) 255)
 180               (logand (aref h 2) 255)))))
 181
 182 (defmacro pgg-parse-length-type (c)
 183   `(cond
 184     ((< ,c 192) (cons ,c 1))
 185     ((< ,c 224)
 186      (cons (+ (lsh (- ,c 192) 8)
 187               (pgg-byte-after (+ 2 (point)))
 188               192)
 189            2))
 190     ((= ,c 255)
 191      (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
 192                          (pgg-byte-after (+ 3 (point))))
 193                  (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
 194                          (pgg-byte-after (+ 5 (point)))))
 195            5))
 196     (t;partial body length
 197      '(0 . 0))))
 198
 199 (defun pgg-parse-packet-header ()
 200   (let ((ptag (pgg-byte-after))
 201         length-type content-tag packet-bytes header-bytes)
 202     (if (zerop (logand 64 ptag));Old format
 203         (progn
 204           (setq length-type (logand ptag 3)
 205                 length-type (if (= 3 length-type) 0 (lsh 1 length-type))
 206                 content-tag (logand 15 (lsh ptag -2))
 207                 packet-bytes 0
 208                 header-bytes (1+ length-type))
 209           (dotimes (i length-type)
 210             (setq packet-bytes
 211                   (logior (lsh packet-bytes 8)
 212                           (pgg-byte-after (+ 1 i (point)))))))
 213       (setq content-tag (logand 63 ptag)
 214             length-type (pgg-parse-length-type
 215                          (pgg-byte-after (1+ (point))))
 216             packet-bytes (car length-type)
 217             header-bytes (1+ (cdr length-type))))
 218     (list content-tag packet-bytes header-bytes)))
 219
 220 (defun pgg-parse-packet (ptag)
 221   (case (car ptag)
 222     (1 ;Public-Key Encrypted Session Key Packet
 223      (pgg-parse-public-key-encrypted-session-key-packet ptag))
 224     (2 ;Signature Packet
 225      (pgg-parse-signature-packet ptag))
 226     (3 ;Symmetric-Key Encrypted Session Key Packet
 227      (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
 228     ;; 4        -- One-Pass Signature Packet
 229     ;; 5        -- Secret Key Packet
 230     (6 ;Public Key Packet
 231      (pgg-parse-public-key-packet ptag))
 232     ;; 7        -- Secret Subkey Packet
 233     ;; 8        -- Compressed Data Packet
 234     (9 ;Symmetrically Encrypted Data Packet
 235      (pgg-read-body-string ptag))
 236     (10 ;Marker Packet
 237      (pgg-read-body-string ptag))
 238     (11 ;Literal Data Packet
 239      (pgg-read-body-string ptag))
 240     ;; 12       -- Trust Packet
 241     (13 ;User ID Packet
 242      (pgg-read-body-string ptag))
 243     ;; 14       -- Public Subkey Packet
 244     ;; 60 .. 63 -- Private or Experimental Values
 245     ))
 246
 247 (defun pgg-parse-packets (&optional header-parser body-parser)
 248   (let ((header-parser
 249          (or header-parser
 250              (function pgg-parse-packet-header)))
 251         (body-parser
 252          (or body-parser
 253              (function pgg-parse-packet)))
 254         result ptag)
 255     (while (> (point-max) (1+ (point)))
 256       (setq ptag (funcall header-parser))
 257       (pgg-skip-header ptag)
 258       (push (cons (car ptag)
 259                   (save-excursion
 260                     (funcall body-parser ptag)))
 261             result)
 262       (if (zerop (nth 1 ptag))
 263           (goto-char (point-max))
 264         (forward-char (nth 1 ptag))))
 265     result))
 266
 267 (defun pgg-parse-signature-subpacket-header ()
 268   (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
 269     (list (pgg-byte-after (+ (cdr length-type) (point)))
 270           (1- (car length-type))
 271           (1+ (cdr length-type)))))
 272
 273 (defun pgg-parse-signature-subpacket (ptag)
 274   (case (car ptag)
 275     (2 ;signature creation time
 276      (cons 'creation-time
 277            (let ((bytes (pgg-read-bytes 4)))
 278              (pgg-parse-time-field bytes))))
 279     (3 ;signature expiration time
 280      (cons 'signature-expiry
 281            (let ((bytes (pgg-read-bytes 4)))
 282              (pgg-parse-time-field bytes))))
 283     (4 ;exportable certification
 284      (cons 'exportability (pgg-read-byte)))
 285     (5 ;trust signature
 286      (cons 'trust-level (pgg-read-byte)))
 287     (6 ;regular expression
 288      (cons 'regular-expression
 289            (pgg-read-body-string ptag)))
 290     (7 ;revocable
 291      (cons 'revocability (pgg-read-byte)))
 292     (9 ;key expiration time
 293      (cons 'key-expiry
 294            (let ((bytes (pgg-read-bytes 4)))
 295              (pgg-parse-time-field bytes))))
 296     ;; 10 = placeholder for backward compatibility
 297     (11 ;preferred symmetric algorithms
 298      (cons 'preferred-symmetric-key-algorithm
 299            (cdr (assq (pgg-read-byte)
 300                       pgg-parse-symmetric-key-algorithm-alist))))
 301     (12 ;revocation key
 302      )
 303     (16 ;issuer key ID
 304      (cons 'key-identifier
 305            (pgg-format-key-identifier (pgg-read-body-string ptag))))
 306     (20 ;notation data
 307      (pgg-skip-bytes 4)
 308      (cons 'notation
 309            (let ((name-bytes (pgg-read-bytes 2))
 310                  (value-bytes (pgg-read-bytes 2)))
 311              (cons (pgg-read-bytes-string
 312                     (logior (lsh (car name-bytes) 8)
 313                             (nth 1 name-bytes)))
 314                    (pgg-read-bytes-string
 315                     (logior (lsh (car value-bytes) 8)
 316                             (nth 1 value-bytes)))))))
 317     (21 ;preferred hash algorithms
 318      (cons 'preferred-hash-algorithm
 319            (cdr (assq (pgg-read-byte)
 320                       pgg-parse-hash-algorithm-alist))))
 321     (22 ;preferred compression algorithms
 322      (cons 'preferred-compression-algorithm
 323            (cdr (assq (pgg-read-byte)
 324                       pgg-parse-compression-algorithm-alist))))
 325     (23 ;key server preferences
 326      (cons 'key-server-preferences
 327            (pgg-read-body ptag)))
 328     (24 ;preferred key server
 329      (cons 'preferred-key-server
 330            (pgg-read-body-string ptag)))
 331     ;; 25 = primary user id
 332     (26 ;policy URL
 333      (cons 'policy-url (pgg-read-body-string ptag)))
 334     ;; 27 = key flags
 335     ;; 28 = signer's user id
 336     ;; 29 = reason for revocation
 337     ;; 100 to 110 = internal or user-defined
 338     ))
 339
 340 (defun pgg-parse-signature-packet (ptag)
 341   (let* ((signature-version (pgg-byte-after))
 342          (result (list (cons 'version signature-version)))
 343          hashed-material field n)
 344     (cond
 345      ((= signature-version 3)
 346       (pgg-skip-bytes 2)
 347       (setq hashed-material (pgg-read-bytes 5))
 348       (pgg-set-alist result
 349                      'signature-type
 350                      (cdr (assq (pop hashed-material)
 351                                 pgg-parse-signature-type-alist)))
 352       (pgg-set-alist result
 353                      'creation-time
 354                      (pgg-parse-time-field hashed-material))
 355       (pgg-set-alist result
 356                      'key-identifier
 357                      (pgg-format-key-identifier
 358                       (pgg-read-bytes-string 8)))
 359       (pgg-set-alist result
 360                      'public-key-algorithm (pgg-read-byte))
 361       (pgg-set-alist result
 362                      'hash-algorithm (pgg-read-byte)))
 363      ((= signature-version 4)
 364       (pgg-skip-bytes 1)
 365       (pgg-set-alist result
 366                      'signature-type
 367                      (cdr (assq (pgg-read-byte)
 368                                 pgg-parse-signature-type-alist)))
 369       (pgg-set-alist result
 370                      'public-key-algorithm
 371                      (pgg-read-byte))
 372       (pgg-set-alist result
 373                      'hash-algorithm (pgg-read-byte))
 374       (when (>= 10000 (setq n (pgg-read-bytes 2)
 375                             n (logior (lsh (car n) 8)
 376                                       (nth 1 n))))
 377         (save-restriction
 378           (narrow-to-region (point)(+ n (point)))
 379           (nconc result
 380                  (mapcar (function cdr) ;remove packet types
 381                          (pgg-parse-packets
 382                           #'pgg-parse-signature-subpacket-header
 383                           #'pgg-parse-signature-subpacket)))
 384           (goto-char (point-max))))
 385       (when (>= 10000 (setq n (pgg-read-bytes 2)
 386                             n (logior (lsh (car n) 8)
 387                                       (nth 1 n))))
 388         (save-restriction
 389           (narrow-to-region (point)(+ n (point)))
 390           (nconc result
 391                  (mapcar (function cdr) ;remove packet types
 392                          (pgg-parse-packets
 393                           #'pgg-parse-signature-subpacket-header
 394                           #'pgg-parse-signature-subpacket)))))))
 395
 396     (setcdr (setq field (assq 'public-key-algorithm
 397                               result))
 398             (cdr (assq (cdr field)
 399                        pgg-parse-public-key-algorithm-alist)))
 400     (setcdr (setq field (assq 'hash-algorithm
 401                               result))
 402             (cdr (assq (cdr field)
 403                        pgg-parse-hash-algorithm-alist)))
 404     result))
 405
 406 (defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
 407   (let (result)
 408     (pgg-set-alist result
 409                    'version (pgg-read-byte))
 410     (pgg-set-alist result
 411                    'key-identifier
 412                    (pgg-format-key-identifier
 413                     (pgg-read-bytes-string 8)))
 414     (pgg-set-alist result
 415                    'public-key-algorithm
 416                    (cdr (assq (pgg-read-byte)
 417                               pgg-parse-public-key-algorithm-alist)))
 418     result))
 419
 420 (defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
 421   (let (result)
 422     (pgg-set-alist result
 423                    'version
 424                    (pgg-read-byte))
 425     (pgg-set-alist result
 426                    'symmetric-key-algorithm
 427                    (cdr (assq (pgg-read-byte)
 428                               pgg-parse-symmetric-key-algorithm-alist)))
 429     result))
 430
 431 (defun pgg-parse-public-key-packet (ptag)
 432   (let* ((key-version (pgg-read-byte))
 433          (result (list (cons 'version key-version)))
 434          field)
 435     (cond
 436      ((= 3 key-version)
 437       (pgg-set-alist result
 438                      'creation-time
 439                      (let ((bytes (pgg-read-bytes 4)))
 440                        (pgg-parse-time-field bytes)))
 441       (pgg-set-alist result
 442                      'key-expiry (pgg-read-bytes 2))
 443       (pgg-set-alist result
 444                      'public-key-algorithm (pgg-read-byte)))
 445      ((= 4 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                      'public-key-algorithm (pgg-read-byte))))
 452
 453     (setcdr (setq field (assq 'public-key-algorithm
 454                               result))
 455             (cdr (assq (cdr field)
 456                        pgg-parse-public-key-algorithm-alist)))
 457     result))
 458
 459 (defun pgg-decode-packets ()
 460   (let* ((marker
 461           (set-marker (make-marker)
 462                       (and (re-search-forward "^=")
 463                            (match-beginning 0))))
 464          (checksum (buffer-substring (point) (+ 4 (point)))))
 465     (delete-region marker (point-max))
 466     (mime-decode-region (point-min) marker "base64")
 467     (static-when (fboundp 'pgg-parse-crc24-string )
 468       (or pgg-ignore-packet-checksum
 469           (string-equal
 470            (funcall (mel-find-function 'mime-encode-string "base64")
 471                     (pgg-parse-crc24-string
 472                      (buffer-substring (point-min)(point-max))))
 473            checksum)
 474           (error "PGP packet checksum does not match")))))
 475
 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