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

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

;; Copyright (C) 1999, 2002, 2003, 2004, 2005 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 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

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

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