[bpt/emacs.git] / lisp / pgg-parse.el

;;; pgg-parse.el --- OpenPGP packet parsing

;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
;;   2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Daiki Ueno <ueno@unixuser.org>
;; 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 3 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;    This module is based on

;;	[OpenPGP] RFC 2440: "OpenPGP Message Format"
;;	    by John W. Noerenberg, II <jwn2@qualcomm.com>,
;;          Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>,
;;          Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com>
;;	    (1998/11)

;;; Code:

(eval-when-compile
  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
  (require 'cl))

(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) (8 . SHA256) (9 . SHA384)
    (10 . SHA512))
  "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-number-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-number-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-number-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)))))

  (defvar pgg-parse-crc24)

  (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))

;; p-d-p only calls this if it is defined, but the compiler does not
;; recognize that.
(declare-function pgg-parse-crc24-string "pgg-parse" (string))

(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
Commit	Line	Data
23f87bed MB	1	;;; pgg-parse.el --- OpenPGP packet parsing
23f87bed MB	2
aaef169d	3	;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
409cc4a3	4	;; 2006, 2007, 2008 Free Software Foundation, Inc.
23f87bed MB	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
eb3fa2cf	12	;; GNU Emacs is free software: you can redistribute it and/or modify
23f87bed	13	;; it under the terms of the GNU General Public License as published by
eb3fa2cf GM	14	;; the Free Software Foundation, either version 3 of the License, or
eb3fa2cf GM	15	;; (at your option) any later version.
23f87bed MB	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
eb3fa2cf	23	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23f87bed MB	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
21ee0911 MB	37	(eval-when-compile
	38	(unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
	39	(require 'cl))
23f87bed	40
23f87bed	41	(defgroup pgg-parse ()
8d764d76	42	"OpenPGP packet parsing."
23f87bed MB	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
bcc7dd61 MB	60	'((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384)
bcc7dd61 MB	61	(10 . SHA512))
23f87bed MB	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"
e9bd5782	116	;; (string-to-number-list ,string)))
23f87bed MB	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))
e9bd5782	139	;; `(string-to-number-list (pgg-read-bytes-string ,nbytes))
23f87bed MB	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))
e9bd5782	149	;; `(string-to-number-list (pgg-read-body-string ,ptag))
23f87bed MB	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
14ecd9e4 GM	181	(defvar pgg-parse-crc24)
14ecd9e4 GM	182
23f87bed MB	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))
357	(pgg-set-alist result
358	'signature-type
359	(cdr (assq (pop hashed-material)
360	pgg-parse-signature-type-alist)))
361	(pgg-set-alist result
362	'creation-time
363	(pgg-parse-time-field hashed-material))
364	(pgg-set-alist result
365	'key-identifier
366	(pgg-format-key-identifier
367	(pgg-read-bytes-string 8)))
368	(pgg-set-alist result
369	'public-key-algorithm (pgg-read-byte))
370	(pgg-set-alist result
371	'hash-algorithm (pgg-read-byte)))
372	((= signature-version 4)
373	(pgg-skip-bytes 1)
374	(pgg-set-alist result
375	'signature-type
376	(cdr (assq (pgg-read-byte)
377	pgg-parse-signature-type-alist)))
378	(pgg-set-alist result
379	'public-key-algorithm
380	(pgg-read-byte))
381	(pgg-set-alist result
382	'hash-algorithm (pgg-read-byte))
383	(when (>= 10000 (setq n (pgg-read-bytes 2)
384	n (logior (lsh (car n) 8)
385	(nth 1 n))))
386	(save-restriction
387	(narrow-to-region (point)(+ n (point)))
388	(nconc result
389	(mapcar (function cdr) ;remove packet types
390	(pgg-parse-packets
391	#'pgg-parse-signature-subpacket-header
392	#'pgg-parse-signature-subpacket)))
393	(goto-char (point-max))))
394	(when (>= 10000 (setq n (pgg-read-bytes 2)
395	n (logior (lsh (car n) 8)
396	(nth 1 n))))
397	(save-restriction
398	(narrow-to-region (point)(+ n (point)))
399	(nconc result
400	(mapcar (function cdr) ;remove packet types
401	(pgg-parse-packets
402	#'pgg-parse-signature-subpacket-header
403	#'pgg-parse-signature-subpacket)))))))
404
405	(setcdr (setq field (assq 'public-key-algorithm
406	result))
407	(cdr (assq (cdr field)
408	pgg-parse-public-key-algorithm-alist)))
409	(setcdr (setq field (assq 'hash-algorithm
410	result))
411	(cdr (assq (cdr field)
412	pgg-parse-hash-algorithm-alist)))
413	result))
414
415	(defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
416	(let (result)
417	(pgg-set-alist result
418	'version (pgg-read-byte))
419	(pgg-set-alist result
420	'key-identifier
421	(pgg-format-key-identifier
422	(pgg-read-bytes-string 8)))
423	(pgg-set-alist result
424	'public-key-algorithm
425	(cdr (assq (pgg-read-byte)
426	pgg-parse-public-key-algorithm-alist)))
427	result))
428
429	(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
430	(let (result)
431	(pgg-set-alist result
432	'version
433	(pgg-read-byte))
434	(pgg-set-alist result
435	'symmetric-key-algorithm
436	(cdr (assq (pgg-read-byte)
437	pgg-parse-symmetric-key-algorithm-alist)))
438	result))
439
440	(defun pgg-parse-public-key-packet (ptag)
441	(let* ((key-version (pgg-read-byte))
442	(result (list (cons 'version key-version)))
443	field)
444	(cond
445	((= 3 key-version)
446	(pgg-set-alist result
447	'creation-time
448	(let ((bytes (pgg-read-bytes 4)))
449	(pgg-parse-time-field bytes)))
450	(pgg-set-alist result
451	'key-expiry (pgg-read-bytes 2))
452	(pgg-set-alist result
453	'public-key-algorithm (pgg-read-byte)))
454	((= 4 key-version)
455	(pgg-set-alist result
456	'creation-time
457	(let ((bytes (pgg-read-bytes 4)))
458	(pgg-parse-time-field bytes)))
459	(pgg-set-alist result
460	'public-key-algorithm (pgg-read-byte))))
461
462	(setcdr (setq field (assq 'public-key-algorithm
463	result))
464	(cdr (assq (cdr field)
465	pgg-parse-public-key-algorithm-alist)))
466	result))
467
14ecd9e4 GM	468	;; p-d-p only calls this if it is defined, but the compiler does not
	469	;; recognize that.
	470	(declare-function pgg-parse-crc24-string "pgg-parse" (string))
	471
23f87bed MB	472	(defun pgg-decode-packets ()
	473	(if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t)
	474	(let ((p (match-beginning 0))
	475	(checksum (match-string 1)))
	476	(delete-region p (point-max))
	477	(if (ignore-errors (base64-decode-region (point-min) p))
	478	(or (not (fboundp 'pgg-parse-crc24-string))
	479	pgg-ignore-packet-checksum
	480	(string-equal (base64-encode-string (pgg-parse-crc24-string
	481	(buffer-string)))
	482	checksum)
	483	(progn
	484	(message "PGP packet checksum does not match")
	485	nil))
	486	(message "PGP packet contain invalid base64")
	487	nil))
	488	(message "PGP packet checksum not found")
	489	nil))
	490
	491	(defun pgg-decode-armor-region (start end)
	492	(save-restriction
	493	(narrow-to-region start end)
	494	(goto-char (point-min))
	495	(re-search-forward "^-+BEGIN PGP" nil t)
	496	(delete-region (point-min)
	497	(and (search-forward "\n\n")
	498	(match-end 0)))
	499	(when (pgg-decode-packets)
	500	(goto-char (point-min))
	501	(pgg-parse-packets))))
	502
	503	(defun pgg-parse-armor (string)
	504	(with-temp-buffer
	505	(buffer-disable-undo)
	506	(if (fboundp 'set-buffer-multibyte)
	507	(set-buffer-multibyte nil))
	508	(insert string)
	509	(pgg-decode-armor-region (point-min)(point))))
	510
	511	(eval-and-compile
	512	(defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte)
	513	'string-as-unibyte
	514	'identity)))
	515
	516	(defun pgg-parse-armor-region (start end)
	517	(pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end))))
	518
	519	(provide 'pgg-parse)
	520
cbee283d	521	;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e
23f87bed	522	;;; pgg-parse.el ends here