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