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