git.chise.org Git - elisp/gnus.git-/blob - lisp/pgg-parse.el

   1 ;;; pgg-parse.el --- OpenPGP packet parsing
   2
   3 ;; Copyright (C) 1999 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 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 (require 'custom)
  41
  42 (defgroup pgg-parse ()
  43   "OpenPGP packet parsing"
  44   :group 'pgg)
  45
  46 (defcustom pgg-parse-public-key-algorithm-alist
  47   '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
  48   "Alist of the assigned number to the public key algorithm."
  49   :group 'pgg-parse
  50   :type '(repeat
  51           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  52
  53 (defcustom pgg-parse-symmetric-key-algorithm-alist
  54   '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
  55   "Alist of the assigned number to the simmetric key algorithm."
  56   :group 'pgg-parse
  57   :type '(repeat
  58           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  59
  60 (defcustom pgg-parse-hash-algorithm-alist
  61   '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2))
  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-int-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-int-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-int-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   (let* ((marker
 468           (set-marker (make-marker)
 469                       (and (re-search-forward "^=")
 470                            (match-beginning 0))))
 471          (checksum (buffer-substring (point) (+ 4 (point)))))
 472     (delete-region marker (point-max))
 473     (base64-decode-region (point-min) marker)
 474     (when (fboundp 'pgg-parse-crc24-string)
 475       (or pgg-ignore-packet-checksum
 476           (string-equal
 477            (base64-encode-string (pgg-parse-crc24-string
 478                                   (buffer-string)))
 479            checksum)
 480           (error "PGP packet checksum does not match")))))
 481
 482 (defun pgg-decode-armor-region (start end)
 483   (save-restriction
 484     (narrow-to-region start end)
 485     (goto-char (point-min))
 486     (re-search-forward "^-+BEGIN PGP" nil t)
 487     (delete-region (point-min)
 488                    (and (search-forward "\n\n")
 489                         (match-end 0)))
 490     (pgg-decode-packets)
 491     (goto-char (point-min))
 492     (pgg-parse-packets)))
 493
 494 (defun pgg-parse-armor (string)
 495   (with-temp-buffer
 496     (buffer-disable-undo)
 497     (if (fboundp 'set-buffer-multibyte)
 498         (set-buffer-multibyte nil))
 499     (insert string)
 500     (pgg-decode-armor-region (point-min)(point))))
 501
 502 (eval-and-compile
 503   (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte)
 504                                        'string-as-unibyte
 505                                      'identity)))
 506
 507 (defun pgg-parse-armor-region (start end)
 508   (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end))))
 509
 510 (provide 'pgg-parse)
 511
 512 ;;; pgg-parse.el ends here