cgit.sxemacs.org Git - gnus/blob - lisp/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))
  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 (when (fboundp 'define-ccl-program)
 163
 164   (define-ccl-program pgg-parse-crc24
 165     '(1
 166       ((loop
 167         (read r0) (r1 ^= r0) (r2 ^= 0)
 168         (r5 = 0)
 169         (loop
 170          (r1 <<= 1)
 171          (r1 += ((r2 >> 15) & 1))
 172          (r2 <<= 1)
 173          (if (r1 & 256)
 174              ((r1 ^= 390) (r2 ^= 19707)))
 175          (if (r5 < 7)
 176              ((r5 += 1)
 177               (repeat))))
 178         (repeat)))))
 179
 180   (defun pgg-parse-crc24-string (string)
 181     (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
 182       (ccl-execute-on-string pgg-parse-crc24 h string)
 183       (format "%c%c%c"
 184               (logand (aref h 1) 255)
 185               (logand (lsh (aref h 2) -8) 255)
 186               (logand (aref h 2) 255)))))
 187
 188 (defmacro pgg-parse-length-type (c)
 189   `(cond
 190     ((< ,c 192) (cons ,c 1))
 191     ((< ,c 224)
 192      (cons (+ (lsh (- ,c 192) 8)
 193               (pgg-byte-after (+ 2 (point)))
 194               192)
 195            2))
 196     ((= ,c 255)
 197      (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
 198                          (pgg-byte-after (+ 3 (point))))
 199                  (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
 200                          (pgg-byte-after (+ 5 (point)))))
 201            5))
 202     (t;partial body length
 203      '(0 . 0))))
 204
 205 (defun pgg-parse-packet-header ()
 206   (let ((ptag (pgg-byte-after))
 207         length-type content-tag packet-bytes header-bytes)
 208     (if (zerop (logand 64 ptag));Old format
 209         (progn
 210           (setq length-type (logand ptag 3)
 211                 length-type (if (= 3 length-type) 0 (lsh 1 length-type))
 212                 content-tag (logand 15 (lsh ptag -2))
 213                 packet-bytes 0
 214                 header-bytes (1+ length-type))
 215           (dotimes (i length-type)
 216             (setq packet-bytes
 217                   (logior (lsh packet-bytes 8)
 218                           (pgg-byte-after (+ 1 i (point)))))))
 219       (setq content-tag (logand 63 ptag)
 220             length-type (pgg-parse-length-type
 221                          (pgg-byte-after (1+ (point))))
 222             packet-bytes (car length-type)
 223             header-bytes (1+ (cdr length-type))))
 224     (list content-tag packet-bytes header-bytes)))
 225
 226 (defun pgg-parse-packet (ptag)
 227   (case (car ptag)
 228     (1 ;Public-Key Encrypted Session Key Packet
 229      (pgg-parse-public-key-encrypted-session-key-packet ptag))
 230     (2 ;Signature Packet
 231      (pgg-parse-signature-packet ptag))
 232     (3 ;Symmetric-Key Encrypted Session Key Packet
 233      (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
 234     ;; 4        -- One-Pass Signature Packet
 235     ;; 5        -- Secret Key Packet
 236     (6 ;Public Key Packet
 237      (pgg-parse-public-key-packet ptag))
 238     ;; 7        -- Secret Subkey Packet
 239     ;; 8        -- Compressed Data Packet
 240     (9 ;Symmetrically Encrypted Data Packet
 241      (pgg-read-body-string ptag))
 242     (10 ;Marker Packet
 243      (pgg-read-body-string ptag))
 244     (11 ;Literal Data Packet
 245      (pgg-read-body-string ptag))
 246     ;; 12       -- Trust Packet
 247     (13 ;User ID Packet
 248      (pgg-read-body-string ptag))
 249     ;; 14       -- Public Subkey Packet
 250     ;; 60 .. 63 -- Private or Experimental Values
 251     ))
 252
 253 (defun pgg-parse-packets (&optional header-parser body-parser)
 254   (let ((header-parser
 255          (or header-parser
 256              (function pgg-parse-packet-header)))
 257         (body-parser
 258          (or body-parser
 259              (function pgg-parse-packet)))
 260         result ptag)
 261     (while (> (point-max) (1+ (point)))
 262       (setq ptag (funcall header-parser))
 263       (pgg-skip-header ptag)
 264       (push (cons (car ptag)
 265                   (save-excursion
 266                     (funcall body-parser ptag)))
 267             result)
 268       (if (zerop (nth 1 ptag))
 269           (goto-char (point-max))
 270         (forward-char (nth 1 ptag))))
 271     result))
 272
 273 (defun pgg-parse-signature-subpacket-header ()
 274   (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
 275     (list (pgg-byte-after (+ (cdr length-type) (point)))
 276           (1- (car length-type))
 277           (1+ (cdr length-type)))))
 278
 279 (defun pgg-parse-signature-subpacket (ptag)
 280   (case (car ptag)
 281     (2 ;signature creation time
 282      (cons 'creation-time
 283            (let ((bytes (pgg-read-bytes 4)))
 284              (pgg-parse-time-field bytes))))
 285     (3 ;signature expiration time
 286      (cons 'signature-expiry
 287            (let ((bytes (pgg-read-bytes 4)))
 288              (pgg-parse-time-field bytes))))
 289     (4 ;exportable certification
 290      (cons 'exportability (pgg-read-byte)))
 291     (5 ;trust signature
 292      (cons 'trust-level (pgg-read-byte)))
 293     (6 ;regular expression
 294      (cons 'regular-expression
 295            (pgg-read-body-string ptag)))
 296     (7 ;revocable
 297      (cons 'revocability (pgg-read-byte)))
 298     (9 ;key expiration time
 299      (cons 'key-expiry
 300            (let ((bytes (pgg-read-bytes 4)))
 301              (pgg-parse-time-field bytes))))
 302     ;; 10 = placeholder for backward compatibility
 303     (11 ;preferred symmetric algorithms
 304      (cons 'preferred-symmetric-key-algorithm
 305            (cdr (assq (pgg-read-byte)
 306                       pgg-parse-symmetric-key-algorithm-alist))))
 307     (12 ;revocation key
 308      )
 309     (16 ;issuer key ID
 310      (cons 'key-identifier
 311            (pgg-format-key-identifier (pgg-read-body-string ptag))))
 312     (20 ;notation data
 313      (pgg-skip-bytes 4)
 314      (cons 'notation
 315            (let ((name-bytes (pgg-read-bytes 2))
 316                  (value-bytes (pgg-read-bytes 2)))
 317              (cons (pgg-read-bytes-string
 318                     (logior (lsh (car name-bytes) 8)
 319                             (nth 1 name-bytes)))
 320                    (pgg-read-bytes-string
 321                     (logior (lsh (car value-bytes) 8)
 322                             (nth 1 value-bytes)))))))
 323     (21 ;preferred hash algorithms
 324      (cons 'preferred-hash-algorithm
 325            (cdr (assq (pgg-read-byte)
 326                       pgg-parse-hash-algorithm-alist))))
 327     (22 ;preferred compression algorithms
 328      (cons 'preferred-compression-algorithm
 329            (cdr (assq (pgg-read-byte)
 330                       pgg-parse-compression-algorithm-alist))))
 331     (23 ;key server preferences
 332      (cons 'key-server-preferences
 333            (pgg-read-body ptag)))
 334     (24 ;preferred key server
 335      (cons 'preferred-key-server
 336            (pgg-read-body-string ptag)))
 337     ;; 25 = primary user id
 338     (26 ;policy URL
 339      (cons 'policy-url (pgg-read-body-string ptag)))
 340     ;; 27 = key flags
 341     ;; 28 = signer's user id
 342     ;; 29 = reason for revocation
 343     ;; 100 to 110 = internal or user-defined
 344     ))
 345
 346 (defun pgg-parse-signature-packet (ptag)
 347   (let* ((signature-version (pgg-byte-after))
 348          (result (list (cons 'version signature-version)))
 349          hashed-material field n)
 350     (cond
 351      ((= signature-version 3)
 352       (pgg-skip-bytes 2)
 353       (setq hashed-material (pgg-read-bytes 5))
 354       (pgg-set-alist result
 355                      'signature-type
 356                      (cdr (assq (pop hashed-material)
 357                                 pgg-parse-signature-type-alist)))
 358       (pgg-set-alist result
 359                      'creation-time
 360                      (pgg-parse-time-field hashed-material))
 361       (pgg-set-alist result
 362                      'key-identifier
 363                      (pgg-format-key-identifier
 364                       (pgg-read-bytes-string 8)))
 365       (pgg-set-alist result
 366                      'public-key-algorithm (pgg-read-byte))
 367       (pgg-set-alist result
 368                      'hash-algorithm (pgg-read-byte)))
 369      ((= signature-version 4)
 370       (pgg-skip-bytes 1)
 371       (pgg-set-alist result
 372                      'signature-type
 373                      (cdr (assq (pgg-read-byte)
 374                                 pgg-parse-signature-type-alist)))
 375       (pgg-set-alist result
 376                      'public-key-algorithm
 377                      (pgg-read-byte))
 378       (pgg-set-alist result
 379                      'hash-algorithm (pgg-read-byte))
 380       (when (>= 10000 (setq n (pgg-read-bytes 2)
 381                             n (logior (lsh (car n) 8)
 382                                       (nth 1 n))))
 383         (save-restriction
 384           (narrow-to-region (point)(+ n (point)))
 385           (nconc result
 386                  (mapcar (function cdr) ;remove packet types
 387                          (pgg-parse-packets
 388                           #'pgg-parse-signature-subpacket-header
 389                           #'pgg-parse-signature-subpacket)))
 390           (goto-char (point-max))))
 391       (when (>= 10000 (setq n (pgg-read-bytes 2)
 392                             n (logior (lsh (car n) 8)
 393                                       (nth 1 n))))
 394         (save-restriction
 395           (narrow-to-region (point)(+ n (point)))
 396           (nconc result
 397                  (mapcar (function cdr) ;remove packet types
 398                          (pgg-parse-packets
 399                           #'pgg-parse-signature-subpacket-header
 400                           #'pgg-parse-signature-subpacket)))))))
 401
 402     (setcdr (setq field (assq 'public-key-algorithm
 403                               result))
 404             (cdr (assq (cdr field)
 405                        pgg-parse-public-key-algorithm-alist)))
 406     (setcdr (setq field (assq 'hash-algorithm
 407                               result))
 408             (cdr (assq (cdr field)
 409                        pgg-parse-hash-algorithm-alist)))
 410     result))
 411
 412 (defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
 413   (let (result)
 414     (pgg-set-alist result
 415                    'version (pgg-read-byte))
 416     (pgg-set-alist result
 417                    'key-identifier
 418                    (pgg-format-key-identifier
 419                     (pgg-read-bytes-string 8)))
 420     (pgg-set-alist result
 421                    'public-key-algorithm
 422                    (cdr (assq (pgg-read-byte)
 423                               pgg-parse-public-key-algorithm-alist)))
 424     result))
 425
 426 (defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
 427   (let (result)
 428     (pgg-set-alist result
 429                    'version
 430                    (pgg-read-byte))
 431     (pgg-set-alist result
 432                    'symmetric-key-algorithm
 433                    (cdr (assq (pgg-read-byte)
 434                               pgg-parse-symmetric-key-algorithm-alist)))
 435     result))
 436
 437 (defun pgg-parse-public-key-packet (ptag)
 438   (let* ((key-version (pgg-read-byte))
 439          (result (list (cons 'version key-version)))
 440          field)
 441     (cond
 442      ((= 3 key-version)
 443       (pgg-set-alist result
 444                      'creation-time
 445                      (let ((bytes (pgg-read-bytes 4)))
 446                        (pgg-parse-time-field bytes)))
 447       (pgg-set-alist result
 448                      'key-expiry (pgg-read-bytes 2))
 449       (pgg-set-alist result
 450                      'public-key-algorithm (pgg-read-byte)))
 451      ((= 4 key-version)
 452       (pgg-set-alist result
 453                      'creation-time
 454                      (let ((bytes (pgg-read-bytes 4)))
 455                        (pgg-parse-time-field bytes)))
 456       (pgg-set-alist result
 457                      'public-key-algorithm (pgg-read-byte))))
 458
 459     (setcdr (setq field (assq 'public-key-algorithm
 460                               result))
 461             (cdr (assq (cdr field)
 462                        pgg-parse-public-key-algorithm-alist)))
 463     result))
 464
 465 (defun pgg-decode-packets ()
 466   (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t)
 467       (let ((p (match-beginning 0))
 468             (checksum (match-string 1)))
 469         (delete-region p (point-max))
 470         (if (ignore-errors (base64-decode-region (point-min) p))
 471             (or (not (fboundp 'pgg-parse-crc24-string))
 472                 pgg-ignore-packet-checksum
 473                 (string-equal (base64-encode-string (pgg-parse-crc24-string
 474                                                      (buffer-string)))
 475                               checksum)
 476                 (progn
 477                   (message "PGP packet checksum does not match")
 478                   nil))
 479           (message "PGP packet contain invalid base64")
 480           nil))
 481     (message "PGP packet checksum not found")
 482     nil))
 483
 484 (defun pgg-decode-armor-region (start end)
 485   (save-restriction
 486     (narrow-to-region start end)
 487     (goto-char (point-min))
 488     (re-search-forward "^-+BEGIN PGP" nil t)
 489     (delete-region (point-min)
 490                    (and (search-forward "\n\n")
 491                         (match-end 0)))
 492     (when (pgg-decode-packets)
 493       (goto-char (point-min))
 494       (pgg-parse-packets))))
 495
 496 (defun pgg-parse-armor (string)
 497   (with-temp-buffer
 498     (buffer-disable-undo)
 499     (if (fboundp 'set-buffer-multibyte)
 500         (set-buffer-multibyte nil))
 501     (insert string)
 502     (pgg-decode-armor-region (point-min)(point))))
 503
 504 (eval-and-compile
 505   (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte)
 506                                        'string-as-unibyte
 507                                      'identity)))
 508
 509 (defun pgg-parse-armor-region (start end)
 510   (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end))))
 511
 512 (provide 'pgg-parse)
 513
 514 ;;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e
 515 ;;; pgg-parse.el ends here