lisp/pgg-parse.el

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