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