cgit.sxemacs.org Git - gnus/blob - lisp/pgg-parse.el

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