cgit.sxemacs.org Git - packages/blob - xemacs-packages/pgg/pgg-parse.el

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