emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/gnus/pgg-parse.el [emacs-unicode-2]


From: Miles Bader
Subject: [Emacs-diffs] Changes to emacs/lisp/gnus/pgg-parse.el [emacs-unicode-2]
Date: Thu, 09 Sep 2004 06:03:01 -0400

Index: emacs/lisp/gnus/pgg-parse.el
diff -c /dev/null emacs/lisp/gnus/pgg-parse.el:1.2.2.1
*** /dev/null   Thu Sep  9 09:38:27 2004
--- emacs/lisp/gnus/pgg-parse.el        Thu Sep  9 09:36:25 2004
***************
*** 0 ****
--- 1,516 ----
+ ;;; pgg-parse.el --- OpenPGP packet parsing
+ 
+ ;; Copyright (C) 1999, 2003 Free Software Foundation, Inc.
+ 
+ ;; Author: Daiki Ueno <address@hidden>
+ ;; Created: 1999/10/28
+ ;; Keywords: PGP, OpenPGP, GnuPG
+ 
+ ;; This file is part of GNU Emacs.
+ 
+ ;; GNU Emacs is free software; you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation; either version 2, or (at your option)
+ ;; any later version.
+ 
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;; GNU General Public License for more details.
+ 
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs; see the file COPYING.  If not, write to the
+ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ ;; Boston, MA 02111-1307, USA.
+ 
+ ;;; Commentary:
+ 
+ ;;    This module is based on
+ 
+ ;;    [OpenPGP] RFC 2440: "OpenPGP Message Format"
+ ;;        by John W. Noerenberg, II <address@hidden>,
+ ;;          Jon Callas <address@hidden>, Lutz Donnerhacke <address@hidden>,
+ ;;          Hal Finney <address@hidden> and Rodney Thayer <address@hidden>
+ ;;        (1998/11)
+ 
+ ;;; Code:
+ 
+ (eval-when-compile (require 'cl))
+ 
+ (require 'custom)
+ 
+ (defgroup pgg-parse ()
+   "OpenPGP packet parsing"
+   :group 'pgg)
+ 
+ (defcustom pgg-parse-public-key-algorithm-alist
+   '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
+   "Alist of the assigned number to the public key algorithm."
+   :group 'pgg-parse
+   :type '(repeat
+         (cons (sexp :tag "Number") (sexp :tag "Type"))))
+ 
+ (defcustom pgg-parse-symmetric-key-algorithm-alist
+   '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
+   "Alist of the assigned number to the simmetric key algorithm."
+   :group 'pgg-parse
+   :type '(repeat
+         (cons (sexp :tag "Number") (sexp :tag "Type"))))
+ 
+ (defcustom pgg-parse-hash-algorithm-alist
+   '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2))
+   "Alist of the assigned number to the cryptographic hash algorithm."
+   :group 'pgg-parse
+   :type '(repeat
+         (cons (sexp :tag "Number") (sexp :tag "Type"))))
+ 
+ (defcustom pgg-parse-compression-algorithm-alist
+   '((0 . nil); Uncompressed
+     (1 . ZIP)
+     (2 . ZLIB))
+   "Alist of the assigned number to the compression algorithm."
+   :group 'pgg-parse
+   :type '(repeat
+         (cons (sexp :tag "Number") (sexp :tag "Type"))))
+ 
+ (defcustom pgg-parse-signature-type-alist
+   '((0 . "Signature of a binary document")
+     (1 . "Signature of a canonical text document")
+     (2 . "Standalone signature")
+     (16 . "Generic certification of a User ID and Public Key packet")
+     (17 . "Persona certification of a User ID and Public Key packet")
+     (18 . "Casual certification of a User ID and Public Key packet")
+     (19 . "Positive certification of a User ID and Public Key packet")
+     (24 . "Subkey Binding Signature")
+     (31 . "Signature directly on a key")
+     (32 . "Key revocation signature")
+     (40 . "Subkey revocation signature")
+     (48 . "Certification revocation signature")
+     (64 . "Timestamp signature."))
+   "Alist of the assigned number to the signature type."
+   :group 'pgg-parse
+   :type '(repeat
+         (cons (sexp :tag "Number") (sexp :tag "Type"))))
+ 
+ (defcustom pgg-ignore-packet-checksum t; XXX
+   "If non-nil checksum of each ascii armored packet will be ignored."
+   :group 'pgg-parse
+   :type 'boolean)
+ 
+ (defvar pgg-armor-header-lines
+   '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$"
+     "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
+     "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$"
+     "^-----BEGIN PGP SIGNATURE-----\r?$")
+   "Armor headers.")
+ 
+ (eval-and-compile
+   (defalias 'pgg-char-int (if (fboundp 'char-int)
+                             'char-int
+                           'identity)))
+ 
+ (defmacro pgg-format-key-identifier (string)
+   `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c)))
+             ,string "")
+   ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
+   ;;                 (string-to-int-list ,string)))
+   )
+ 
+ (defmacro pgg-parse-time-field (bytes)
+   `(list (logior (lsh (car ,bytes) 8)
+                (nth 1 ,bytes))
+        (logior (lsh (nth 2 ,bytes) 8)
+                (nth 3 ,bytes))
+        0))
+ 
+ (defmacro pgg-byte-after (&optional pos)
+   `(pgg-char-int (char-after ,(or pos `(point)))))
+ 
+ (defmacro pgg-read-byte ()
+   `(pgg-char-int (char-after (prog1 (point) (forward-char)))))
+ 
+ (defmacro pgg-read-bytes-string (nbytes)
+   `(buffer-substring
+     (point) (prog1 (+ ,nbytes (point))
+             (forward-char ,nbytes))))
+ 
+ (defmacro pgg-read-bytes (nbytes)
+   `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes))
+   ;; `(string-to-int-list (pgg-read-bytes-string ,nbytes))
+   )
+ 
+ (defmacro pgg-read-body-string (ptag)
+   `(if (nth 1 ,ptag)
+        (pgg-read-bytes-string (nth 1 ,ptag))
+      (pgg-read-bytes-string (- (point-max) (point)))))
+ 
+ (defmacro pgg-read-body (ptag)
+   `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag))
+   ;; `(string-to-int-list (pgg-read-body-string ,ptag))
+   )
+ 
+ (defalias 'pgg-skip-bytes 'forward-char)
+ 
+ (defmacro pgg-skip-header (ptag)
+   `(pgg-skip-bytes (nth 2 ,ptag)))
+ 
+ (defmacro pgg-skip-body (ptag)
+   `(pgg-skip-bytes (nth 1 ,ptag)))
+ 
+ (defmacro pgg-set-alist (alist key value)
+   `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
+ 
+ (when (fboundp 'define-ccl-program)
+ 
+   (define-ccl-program pgg-parse-crc24
+     '(1
+       ((loop
+       (read r0) (r1 ^= r0) (r2 ^= 0)
+       (r5 = 0)
+       (loop
+        (r1 <<= 1)
+        (r1 += ((r2 >> 15) & 1))
+        (r2 <<= 1)
+        (if (r1 & 256)
+            ((r1 ^= 390) (r2 ^= 19707)))
+        (if (r5 < 7)
+            ((r5 += 1)
+             (repeat))))
+       (repeat)))))
+ 
+   (defun pgg-parse-crc24-string (string)
+     (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
+       (ccl-execute-on-string pgg-parse-crc24 h string)
+       (format "%c%c%c"
+             (logand (aref h 1) 255)
+             (logand (lsh (aref h 2) -8) 255)
+             (logand (aref h 2) 255)))))
+ 
+ (defmacro pgg-parse-length-type (c)
+   `(cond
+     ((< ,c 192) (cons ,c 1))
+     ((< ,c 224)
+      (cons (+ (lsh (- ,c 192) 8)
+             (pgg-byte-after (+ 2 (point)))
+             192)
+          2))
+     ((= ,c 255)
+      (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
+                        (pgg-byte-after (+ 3 (point))))
+                (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
+                        (pgg-byte-after (+ 5 (point)))))
+          5))
+     (t;partial body length
+      '(0 . 0))))
+ 
+ (defun pgg-parse-packet-header ()
+   (let ((ptag (pgg-byte-after))
+       length-type content-tag packet-bytes header-bytes)
+     (if (zerop (logand 64 ptag));Old format
+       (progn
+         (setq length-type (logand ptag 3)
+               length-type (if (= 3 length-type) 0 (lsh 1 length-type))
+               content-tag (logand 15 (lsh ptag -2))
+               packet-bytes 0
+               header-bytes (1+ length-type))
+         (dotimes (i length-type)
+           (setq packet-bytes
+                 (logior (lsh packet-bytes 8)
+                         (pgg-byte-after (+ 1 i (point)))))))
+       (setq content-tag (logand 63 ptag)
+           length-type (pgg-parse-length-type
+                        (pgg-byte-after (1+ (point))))
+           packet-bytes (car length-type)
+           header-bytes (1+ (cdr length-type))))
+     (list content-tag packet-bytes header-bytes)))
+ 
+ (defun pgg-parse-packet (ptag)
+   (case (car ptag)
+     (1 ;Public-Key Encrypted Session Key Packet
+      (pgg-parse-public-key-encrypted-session-key-packet ptag))
+     (2 ;Signature Packet
+      (pgg-parse-signature-packet ptag))
+     (3 ;Symmetric-Key Encrypted Session Key Packet
+      (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
+     ;; 4        -- One-Pass Signature Packet
+     ;; 5        -- Secret Key Packet
+     (6 ;Public Key Packet
+      (pgg-parse-public-key-packet ptag))
+     ;; 7        -- Secret Subkey Packet
+     ;; 8        -- Compressed Data Packet
+     (9 ;Symmetrically Encrypted Data Packet
+      (pgg-read-body-string ptag))
+     (10 ;Marker Packet
+      (pgg-read-body-string ptag))
+     (11 ;Literal Data Packet
+      (pgg-read-body-string ptag))
+     ;; 12       -- Trust Packet
+     (13 ;User ID Packet
+      (pgg-read-body-string ptag))
+     ;; 14       -- Public Subkey Packet
+     ;; 60 .. 63 -- Private or Experimental Values
+     ))
+ 
+ (defun pgg-parse-packets (&optional header-parser body-parser)
+   (let ((header-parser
+        (or header-parser
+            (function pgg-parse-packet-header)))
+       (body-parser
+        (or body-parser
+            (function pgg-parse-packet)))
+       result ptag)
+     (while (> (point-max) (1+ (point)))
+       (setq ptag (funcall header-parser))
+       (pgg-skip-header ptag)
+       (push (cons (car ptag)
+                 (save-excursion
+                   (funcall body-parser ptag)))
+           result)
+       (if (zerop (nth 1 ptag))
+         (goto-char (point-max))
+       (forward-char (nth 1 ptag))))
+     result))
+ 
+ (defun pgg-parse-signature-subpacket-header ()
+   (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
+     (list (pgg-byte-after (+ (cdr length-type) (point)))
+         (1- (car length-type))
+         (1+ (cdr length-type)))))
+ 
+ (defun pgg-parse-signature-subpacket (ptag)
+   (case (car ptag)
+     (2 ;signature creation time
+      (cons 'creation-time
+          (let ((bytes (pgg-read-bytes 4)))
+            (pgg-parse-time-field bytes))))
+     (3 ;signature expiration time
+      (cons 'signature-expiry
+          (let ((bytes (pgg-read-bytes 4)))
+            (pgg-parse-time-field bytes))))
+     (4 ;exportable certification
+      (cons 'exportability (pgg-read-byte)))
+     (5 ;trust signature
+      (cons 'trust-level (pgg-read-byte)))
+     (6 ;regular expression
+      (cons 'regular-expression
+          (pgg-read-body-string ptag)))
+     (7 ;revocable
+      (cons 'revocability (pgg-read-byte)))
+     (9 ;key expiration time
+      (cons 'key-expiry
+          (let ((bytes (pgg-read-bytes 4)))
+            (pgg-parse-time-field bytes))))
+     ;; 10 = placeholder for backward compatibility
+     (11 ;preferred symmetric algorithms
+      (cons 'preferred-symmetric-key-algorithm
+          (cdr (assq (pgg-read-byte)
+                     pgg-parse-symmetric-key-algorithm-alist))))
+     (12 ;revocation key
+      )
+     (16 ;issuer key ID
+      (cons 'key-identifier
+          (pgg-format-key-identifier (pgg-read-body-string ptag))))
+     (20 ;notation data
+      (pgg-skip-bytes 4)
+      (cons 'notation
+          (let ((name-bytes (pgg-read-bytes 2))
+                (value-bytes (pgg-read-bytes 2)))
+            (cons (pgg-read-bytes-string
+                   (logior (lsh (car name-bytes) 8)
+                           (nth 1 name-bytes)))
+                  (pgg-read-bytes-string
+                   (logior (lsh (car value-bytes) 8)
+                           (nth 1 value-bytes)))))))
+     (21 ;preferred hash algorithms
+      (cons 'preferred-hash-algorithm
+          (cdr (assq (pgg-read-byte)
+                     pgg-parse-hash-algorithm-alist))))
+     (22 ;preferred compression algorithms
+      (cons 'preferred-compression-algorithm
+          (cdr (assq (pgg-read-byte)
+                     pgg-parse-compression-algorithm-alist))))
+     (23 ;key server preferences
+      (cons 'key-server-preferences
+          (pgg-read-body ptag)))
+     (24 ;preferred key server
+      (cons 'preferred-key-server
+          (pgg-read-body-string ptag)))
+     ;; 25 = primary user id
+     (26 ;policy URL
+      (cons 'policy-url (pgg-read-body-string ptag)))
+     ;; 27 = key flags
+     ;; 28 = signer's user id
+     ;; 29 = reason for revocation
+     ;; 100 to 110 = internal or user-defined
+     ))
+ 
+ (defun pgg-parse-signature-packet (ptag)
+   (let* ((signature-version (pgg-byte-after))
+        (result (list (cons 'version signature-version)))
+        hashed-material field n)
+     (cond
+      ((= signature-version 3)
+       (pgg-skip-bytes 2)
+       (setq hashed-material (pgg-read-bytes 5))
+       (pgg-set-alist result
+                    'signature-type
+                    (cdr (assq (pop hashed-material)
+                               pgg-parse-signature-type-alist)))
+       (pgg-set-alist result
+                    'creation-time
+                    (pgg-parse-time-field hashed-material))
+       (pgg-set-alist result
+                    'key-identifier
+                    (pgg-format-key-identifier
+                     (pgg-read-bytes-string 8)))
+       (pgg-set-alist result
+                    'public-key-algorithm (pgg-read-byte))
+       (pgg-set-alist result
+                    'hash-algorithm (pgg-read-byte)))
+      ((= signature-version 4)
+       (pgg-skip-bytes 1)
+       (pgg-set-alist result
+                    'signature-type
+                    (cdr (assq (pgg-read-byte)
+                               pgg-parse-signature-type-alist)))
+       (pgg-set-alist result
+                    'public-key-algorithm
+                    (pgg-read-byte))
+       (pgg-set-alist result
+                    'hash-algorithm (pgg-read-byte))
+       (when (>= 10000 (setq n (pgg-read-bytes 2)
+                           n (logior (lsh (car n) 8)
+                                     (nth 1 n))))
+       (save-restriction
+         (narrow-to-region (point)(+ n (point)))
+         (nconc result
+                (mapcar (function cdr) ;remove packet types
+                        (pgg-parse-packets
+                         #'pgg-parse-signature-subpacket-header
+                         #'pgg-parse-signature-subpacket)))
+         (goto-char (point-max))))
+       (when (>= 10000 (setq n (pgg-read-bytes 2)
+                           n (logior (lsh (car n) 8)
+                                     (nth 1 n))))
+       (save-restriction
+         (narrow-to-region (point)(+ n (point)))
+         (nconc result
+                (mapcar (function cdr) ;remove packet types
+                        (pgg-parse-packets
+                         #'pgg-parse-signature-subpacket-header
+                         #'pgg-parse-signature-subpacket)))))))
+ 
+     (setcdr (setq field (assq 'public-key-algorithm
+                             result))
+           (cdr (assq (cdr field)
+                      pgg-parse-public-key-algorithm-alist)))
+     (setcdr (setq field (assq 'hash-algorithm
+                             result))
+           (cdr (assq (cdr field)
+                      pgg-parse-hash-algorithm-alist)))
+     result))
+ 
+ (defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
+   (let (result)
+     (pgg-set-alist result
+                  'version (pgg-read-byte))
+     (pgg-set-alist result
+                  'key-identifier
+                  (pgg-format-key-identifier
+                   (pgg-read-bytes-string 8)))
+     (pgg-set-alist result
+                  'public-key-algorithm
+                  (cdr (assq (pgg-read-byte)
+                             pgg-parse-public-key-algorithm-alist)))
+     result))
+ 
+ (defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
+   (let (result)
+     (pgg-set-alist result
+                  'version
+                  (pgg-read-byte))
+     (pgg-set-alist result
+                  'symmetric-key-algorithm
+                  (cdr (assq (pgg-read-byte)
+                             pgg-parse-symmetric-key-algorithm-alist)))
+     result))
+ 
+ (defun pgg-parse-public-key-packet (ptag)
+   (let* ((key-version (pgg-read-byte))
+        (result (list (cons 'version key-version)))
+        field)
+     (cond
+      ((= 3 key-version)
+       (pgg-set-alist result
+                    'creation-time
+                    (let ((bytes (pgg-read-bytes 4)))
+                      (pgg-parse-time-field bytes)))
+       (pgg-set-alist result
+                    'key-expiry (pgg-read-bytes 2))
+       (pgg-set-alist result
+                    'public-key-algorithm (pgg-read-byte)))
+      ((= 4 key-version)
+       (pgg-set-alist result
+                    'creation-time
+                    (let ((bytes (pgg-read-bytes 4)))
+                      (pgg-parse-time-field bytes)))
+       (pgg-set-alist result
+                    'public-key-algorithm (pgg-read-byte))))
+ 
+     (setcdr (setq field (assq 'public-key-algorithm
+                             result))
+           (cdr (assq (cdr field)
+                      pgg-parse-public-key-algorithm-alist)))
+     result))
+ 
+ (defun pgg-decode-packets ()
+   (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t)
+       (let ((p (match-beginning 0))
+           (checksum (match-string 1)))
+       (delete-region p (point-max))
+       (if (ignore-errors (base64-decode-region (point-min) p))
+           (or (not (fboundp 'pgg-parse-crc24-string))
+               pgg-ignore-packet-checksum
+               (string-equal (base64-encode-string (pgg-parse-crc24-string
+                                                    (buffer-string)))
+                             checksum)
+               (progn
+                 (message "PGP packet checksum does not match")
+                 nil))
+         (message "PGP packet contain invalid base64")
+         nil))
+     (message "PGP packet checksum not found")
+     nil))
+ 
+ (defun pgg-decode-armor-region (start end)
+   (save-restriction
+     (narrow-to-region start end)
+     (goto-char (point-min))
+     (re-search-forward "^-+BEGIN PGP" nil t)
+     (delete-region (point-min)
+                  (and (search-forward "\n\n")
+                       (match-end 0)))
+     (when (pgg-decode-packets)
+       (goto-char (point-min))
+       (pgg-parse-packets))))
+ 
+ (defun pgg-parse-armor (string)
+   (with-temp-buffer
+     (buffer-disable-undo)
+     (if (fboundp 'set-buffer-multibyte)
+       (set-buffer-multibyte nil))
+     (insert string)
+     (pgg-decode-armor-region (point-min)(point))))
+ 
+ (eval-and-compile
+   (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte)
+                                      'string-as-unibyte
+                                    'identity)))
+ 
+ (defun pgg-parse-armor-region (start end)
+   (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end))))
+ 
+ (provide 'pgg-parse)
+ 
+ ;;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e
+ ;;; pgg-parse.el ends here




reply via email to

[Prev in Thread] Current Thread [Next in Thread]