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