lisp/obsolete/pgg-parse.el

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