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
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;;    This module is based on
  28
  29 ;;      [OpenPGP] RFC 2440: "OpenPGP Message Format"
  30 ;;          by John W. Noerenberg, II <jwn2@qualcomm.com>,
  31 ;;          Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>,
  32 ;;          Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com>
  33 ;;          (1998/11)
  34
  35 ;;; Code:
  36
  37 (eval-when-compile
  38   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
  39   (require 'cl))
  40
  41 (defgroup pgg-parse ()
  42   "OpenPGP packet parsing."
  43   :group 'pgg)
  44
  45 (defcustom pgg-parse-public-key-algorithm-alist
  46   '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
  47   "Alist of the assigned number to the public key algorithm."
  48   :group 'pgg-parse
  49   :type '(repeat
  50           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  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 '(repeat
  57           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  58
  59 (defcustom pgg-parse-hash-algorithm-alist
  60   '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384)
  61     (10 . SHA512))
  62   "Alist of the assigned number to the cryptographic hash algorithm."
  63   :group 'pgg-parse
  64   :type '(repeat
  65           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  66
  67 (defcustom pgg-parse-compression-algorithm-alist
  68   '((0 . nil); Uncompressed
  69     (1 . ZIP)
  70     (2 . ZLIB))
  71   "Alist of the assigned number to the compression algorithm."
  72   :group 'pgg-parse
  73   :type '(repeat
  74           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  75
  76 (defcustom pgg-parse-signature-type-alist
  77   '((0 . "Signature of a binary document")
  78     (1 . "Signature of a canonical text document")
  79     (2 . "Standalone signature")
  80     (16 . "Generic certification of a User ID and Public Key packet")
  81     (17 . "Persona certification of a User ID and Public Key packet")
  82     (18 . "Casual certification of a User ID and Public Key packet")
  83     (19 . "Positive certification of a User ID and Public Key packet")
  84     (24 . "Subkey Binding Signature")
  85     (31 . "Signature directly on a key")
  86     (32 . "Key revocation signature")
  87     (40 . "Subkey revocation signature")
  88     (48 . "Certification revocation signature")
  89     (64 . "Timestamp signature."))
  90   "Alist of the assigned number to the signature type."
  91   :group 'pgg-parse
  92   :type '(repeat
  93           (cons (sexp :tag "Number") (sexp :tag "Type"))))
  94
  95 (defcustom pgg-ignore-packet-checksum t; XXX
  96   "If non-nil checksum of each ascii armored packet will be ignored."
  97   :group 'pgg-parse
  98   :type 'boolean)
  99
 100 (defvar pgg-armor-header-lines
 101   '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$"
 102     "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
 103     "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$"
 104     "^-----BEGIN PGP SIGNATURE-----\r?$")
 105   "Armor headers.")
 106
 107 (eval-and-compile
 108   (defalias 'pgg-char-int (if (fboundp 'char-int)
 109                               'char-int
 110                             'identity)))
 111
 112 (defmacro pgg-format-key-identifier (string)
 113   `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c)))
 114               ,string "")
 115   ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
 116   ;;                 (string-to-number-list ,string)))
 117   )
 118
 119 (defmacro pgg-parse-time-field (bytes)
 120   `(list (logior (lsh (car ,bytes) 8)
 121                  (nth 1 ,bytes))
 122          (logior (lsh (nth 2 ,bytes) 8)
 123                  (nth 3 ,bytes))
 124          0))
 125
 126 (defmacro pgg-byte-after (&optional pos)
 127   `(pgg-char-int (char-after ,(or pos `(point)))))
 128
 129 (defmacro pgg-read-byte ()
 130   `(pgg-char-int (char-after (prog1 (point) (forward-char)))))
 131
 132 (defmacro pgg-read-bytes-string (nbytes)
 133   `(buffer-substring
 134     (point) (prog1 (+ ,nbytes (point))
 135               (forward-char ,nbytes))))
 136
 137 (defmacro pgg-read-bytes (nbytes)
 138   `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes))
 139   ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes))
 140   )
 141
 142 (defmacro pgg-read-body-string (ptag)
 143   `(if (nth 1 ,ptag)
 144        (pgg-read-bytes-string (nth 1 ,ptag))
 145      (pgg-read-bytes-string (- (point-max) (point)))))
 146
 147 (defmacro pgg-read-body (ptag)
 148   `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag))
 149   ;; `(string-to-number-list (pgg-read-body-string ,ptag))
 150   )
 151
 152 (defalias 'pgg-skip-bytes 'forward-char)
 153
 154 (defmacro pgg-skip-header (ptag)
 155   `(pgg-skip-bytes (nth 2 ,ptag)))
 156
 157 (defmacro pgg-skip-body (ptag)
 158   `(pgg-skip-bytes (nth 1 ,ptag)))
 159
 160 (defmacro pgg-set-alist (alist key value)
 161   `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
 162
 163 (when (fboundp 'define-ccl-program)
 164
 165   (define-ccl-program pgg-parse-crc24
 166     '(1
 167       ((loop
 168         (read r0) (r1 ^= r0) (r2 ^= 0)
 169         (r5 = 0)
 170         (loop
 171          (r1 <<= 1)
 172          (r1 += ((r2 >> 15) & 1))
 173          (r2 <<= 1)
 174          (if (r1 & 256)
 175              ((r1 ^= 390) (r2 ^= 19707)))
 176          (if (r5 < 7)
 177              ((r5 += 1)
 178               (repeat))))
 179         (repeat)))))
 180
 181   (defvar pgg-parse-crc24)
 182
 183   (defun pgg-parse-crc24-string (string)
 184     (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
 185       (ccl-execute-on-string pgg-parse-crc24 h string)
 186       (format "%c%c%c"
 187               (logand (aref h 1) 255)
 188               (logand (lsh (aref h 2) -8) 255)
 189               (logand (aref h 2) 255)))))
 190
 191 (defmacro pgg-parse-length-type (c)
 192   `(cond
 193     ((< ,c 192) (cons ,c 1))
 194     ((< ,c 224)
 195      (cons (+ (lsh (- ,c 192) 8)
 196               (pgg-byte-after (+ 2 (point)))
 197               192)
 198            2))
 199     ((= ,c 255)
 200      (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
 201                          (pgg-byte-after (+ 3 (point))))
 202                  (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
 203                          (pgg-byte-after (+ 5 (point)))))
 204            5))
 205     (t;partial body length
 206      '(0 . 0))))
 207
 208 (defun pgg-parse-packet-header ()
 209   (let ((ptag (pgg-byte-after))
 210         length-type content-tag packet-bytes header-bytes)
 211     (if (zerop (logand 64 ptag));Old format
 212         (progn
 213           (setq length-type (logand ptag 3)
 214                 length-type (if (= 3 length-type) 0 (lsh 1 length-type))
 215                 content-tag (logand 15 (lsh ptag -2))
 216                 packet-bytes 0
 217                 header-bytes (1+ length-type))
 218           (dotimes (i length-type)
 219             (setq packet-bytes
 220                   (logior (lsh packet-bytes 8)
 221                           (pgg-byte-after (+ 1 i (point)))))))
 222       (setq content-tag (logand 63 ptag)
 223             length-type (pgg-parse-length-type
 224                          (pgg-byte-after (1+ (point))))
 225             packet-bytes (car length-type)
 226             header-bytes (1+ (cdr length-type))))
 227     (list content-tag packet-bytes header-bytes)))
 228
 229 (defun pgg-parse-packet (ptag)
 230   (case (car ptag)
 231     (1 ;Public-Key Encrypted Session Key Packet
 232      (pgg-parse-public-key-encrypted-session-key-packet ptag))
 233     (2 ;Signature Packet
 234      (pgg-parse-signature-packet ptag))
 235     (3 ;Symmetric-Key Encrypted Session Key Packet
 236      (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
 237     ;; 4        -- One-Pass Signature Packet
 238     ;; 5        -- Secret Key Packet
 239     (6 ;Public Key Packet
 240      (pgg-parse-public-key-packet ptag))
 241     ;; 7        -- Secret Subkey Packet
 242     ;; 8        -- Compressed Data Packet
 243     (9 ;Symmetrically Encrypted Data Packet
 244      (pgg-read-body-string ptag))
 245     (10 ;Marker Packet
 246      (pgg-read-body-string ptag))
 247     (11 ;Literal Data Packet
 248      (pgg-read-body-string ptag))
 249     ;; 12       -- Trust Packet
 250     (13 ;User ID Packet
 251      (pgg-read-body-string ptag))
 252     ;; 14       -- Public Subkey Packet
 253     ;; 60 .. 63 -- Private or Experimental Values
 254     ))
 255
 256 (defun pgg-parse-packets (&optional header-parser body-parser)
 257   (let ((header-parser
 258          (or header-parser
 259              (function pgg-parse-packet-header)))
 260         (body-parser
 261          (or body-parser
 262              (function pgg-parse-packet)))
 263         result ptag)
 264     (while (> (point-max) (1+ (point)))
 265       (setq ptag (funcall header-parser))
 266       (pgg-skip-header ptag)
 267       (push (cons (car ptag)
 268                   (save-excursion
 269                     (funcall body-parser ptag)))
 270             result)
 271       (if (zerop (nth 1 ptag))
 272           (goto-char (point-max))
 273         (forward-char (nth 1 ptag))))
 274     result))
 275
 276 (defun pgg-parse-signature-subpacket-header ()
 277   (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
 278     (list (pgg-byte-after (+ (cdr length-type) (point)))
 279           (1- (car length-type))
 280           (1+ (cdr length-type)))))
 281
 282 (defun pgg-parse-signature-subpacket (ptag)
 283   (case (car ptag)
 284     (2 ;signature creation time
 285      (cons 'creation-time
 286            (let ((bytes (pgg-read-bytes 4)))
 287              (pgg-parse-time-field bytes))))
 288     (3 ;signature expiration time
 289      (cons 'signature-expiry
 290            (let ((bytes (pgg-read-bytes 4)))
 291              (pgg-parse-time-field bytes))))
 292     (4 ;exportable certification
 293      (cons 'exportability (pgg-read-byte)))
 294     (5 ;trust signature
 295      (cons 'trust-level (pgg-read-byte)))
 296     (6 ;regular expression
 297      (cons 'regular-expression
 298            (pgg-read-body-string ptag)))
 299     (7 ;revocable
 300      (cons 'revocability (pgg-read-byte)))
 301     (9 ;key expiration time
 302      (cons 'key-expiry
 303            (let ((bytes (pgg-read-bytes 4)))
 304              (pgg-parse-time-field bytes))))
 305     ;; 10 = placeholder for backward compatibility
 306     (11 ;preferred symmetric algorithms
 307      (cons 'preferred-symmetric-key-algorithm
 308            (cdr (assq (pgg-read-byte)
 309                       pgg-parse-symmetric-key-algorithm-alist))))
 310     (12 ;revocation key
 311      )
 312     (16 ;issuer key ID
 313      (cons 'key-identifier
 314            (pgg-format-key-identifier (pgg-read-body-string ptag))))
 315     (20 ;notation data
 316      (pgg-skip-bytes 4)
 317      (cons 'notation
 318            (let ((name-bytes (pgg-read-bytes 2))
 319                  (value-bytes (pgg-read-bytes 2)))
 320              (cons (pgg-read-bytes-string
 321                     (logior (lsh (car name-bytes) 8)
 322                             (nth 1 name-bytes)))
 323                    (pgg-read-bytes-string
 324                     (logior (lsh (car value-bytes) 8)
 325                             (nth 1 value-bytes)))))))
 326     (21 ;preferred hash algorithms
 327      (cons 'preferred-hash-algorithm
 328            (cdr (assq (pgg-read-byte)
 329                       pgg-parse-hash-algorithm-alist))))
 330     (22 ;preferred compression algorithms
 331      (cons 'preferred-compression-algorithm
 332            (cdr (assq (pgg-read-byte)
 333                       pgg-parse-compression-algorithm-alist))))
 334     (23 ;key server preferences
 335      (cons 'key-server-preferences
 336            (pgg-read-body ptag)))
 337     (24 ;preferred key server
 338      (cons 'preferred-key-server
 339            (pgg-read-body-string ptag)))
 340     ;; 25 = primary user id
 341     (26 ;policy URL
 342      (cons 'policy-url (pgg-read-body-string ptag)))
 343     ;; 27 = key flags
 344     ;; 28 = signer's user id
 345     ;; 29 = reason for revocation
 346     ;; 100 to 110 = internal or user-defined
 347     ))
 348
 349 (defun pgg-parse-signature-packet (ptag)
 350   (let* ((signature-version (pgg-byte-after))
 351          (result (list (cons 'version signature-version)))
 352          hashed-material field n)
 353     (cond
 354      ((= signature-version 3)
 355       (pgg-skip-bytes 2)
 356       (setq hashed-material (pgg-read-bytes 5))