;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (PGP :use FUTURE-COMMON-LISP); Base: 10 -*-

;;; Read a PGP file, as described in net-dist.mit.edu:/pub/PGP/pgformat.doc

;;; 1994, Mark Nahabedian, MA=assachusetts Institute of Technology

(defvar *last-certificate-for-user-id-association* nil)

(defun read-pgp-file (pathname)
  (with-open-file (stream pathname 
			  :direction :input
			  :element-type '(unsigned-byte 8))
    (let ((pgp-packets nil)
	  (*last-certificate-for-user-id-association* nil))
      (handler-case 
	(loop
	  (push (read-pgp-packet stream) pgp-packets))
	(end-of-file))
      (nreverse pgp-packets))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; reading utilities

(defun read-pgp-integer (number-of-bytes stream)
  (declare (values integer number-of-bytes-read))
  (let ((result 0))
    (dotimes (i number-of-bytes)
      (setq result (+ (* result 256)
		      (read-byte stream))))
    (values result number-of-bytes)))

(defun read-pgp-big-integer (stream)
  (declare (values integer number-of-bytes-read))
  (let ((number-of-bits (read-pgp-integer 2 stream)))
    (multiple-value-bind (integer bytes)
	(read-pgp-integer (ceiling number-of-bits 8) stream)
      (values integer (+ bytes 2)))))

(defun read-pgp-string (length stream)
  (declare (values string number-of-bytes-read))
  (let ((string (make-string length)))
    (dotimes (index length)
      (setf (aref string index)
	    (scl:ascii-to-char (read-byte stream))))
    (values string length)))

(defconstant pgp-timestamp-base (encode-universal-time 0 0 0 1 1 1970))

(defun pgp-timestamp->universal-time (pgp-timestamp)
  (unless (zerop pgp-timestamp)
    (+ pgp-timestamp pgp-timestamp-base)))

(defun universal-time->pgp-timestamp (ut)
  (- ut pgp-timestamp-base))

(defun read-pgp-timestamp (stream)
  (declare (values universal-time number-of-bytes-read))
  (let ((timestamp (read-pgp-integer 4 stream)))
    (values (pgp-timestamp->universal-time timestamp) 4)))


(defmacro with-remaining-packet-length ((length-var initial-length) &body body)
  (let ((readers '(read-pgp-integer read-pgp-big-integer read-pgp-timestamp 
				    read-pgp-string)))
    `(let ((,length-var ,initial-length))
       (flet (,@(mapcar #'(lambda (name)
			    `(,name (&rest args)
			      (when (<= ,length-var 0)
				(error "Bad size for PGP packet"))
			      (multiple-value-bind (value length)
				  (apply #',name args)
				(decf ,length-var length)
				value)))
			readers))
	 ,@body))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; reading packets

(defclass pgp-packet ()
    ((ctb-byte :initarg :ctb-byte)
     (length :initarg :length :reader pgp-pkt-length)))

(defconstant ctb-types
	     '((#b0000 pgp-pkt-unknown)
	       (#b0001 pgp-pkt-public-key-encrypted)
	       (#b0010 pgp-pkt-secret-key-encrypted)
	       (#b0011 pgp-pkt-unknown)
	       (#b0100 pgp-pkt-unknown)
	       (#b0101 pgp-pkt-secret-key-certificate)
	       (#b0110 pgp-pkt-public-key-certificate)
	       (#b0111 pgp-pkt-unknown)
	       (#b1000 pgp-pkt-compressed-data)
	       (#b1001 pgp-pkt-conventional-key-encrypted-data)
	       (#b1010 pgp-pkt-unknown)
	       (#b1011 pgp-pkt-raw-literal-plaintext-data)
	       (#b1100 pgp-pkt-keyring-trust-packet)
	       (#b1101 pgp-pkt-user-id)
	       (#b1110 pgp-pkt-comment)
	       (#b1111 pgp-pkt-unknown)))

(defun decode-pgp-cypher-type-byte (byte)
  (declare (values type length-of-length))
  (when (ldb-test (byte 1 7) byte)
    (let ((type-code (ldb (byte 4 2) byte) )
	  (length-of-length (ldb (byte 2 0) byte)))
      (values (or (second (assoc type-code ctb-types))
		  'pgp-pkt-unknown)
	      (ecase length-of-length
		(#b00 1) (#b01 2) (#b10 4) (#b11 nil))))))

(defun read-pgp-packet (stream)
  (let ((ctb (read-byte stream)))
    (multiple-value-bind (type length-of-length)
	(decode-pgp-cypher-type-byte ctb)
      (when type
	(let ((pkt (make-instance type 
				  :ctb-byte ctb
				  :length (when length-of-length
					    (read-pgp-integer length-of-length stream)))))
	  (read-pgp-packet-1 pkt stream)
	  pkt)))))

(defgeneric read-pgp-packet-1 (pkt stream))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; specific packet types

(defclass pgp-pkt-unknown (pgp-packet) ())

;;; default method
(defmethod read-pgp-packet-1 ((pkt pgp-packet) stream)
  (if (pgp-pkt-length pkt)
    (dotimes (i (pgp-pkt-length pkt))
      (read-byte stream))
    (error "Don't know how much data to throw away for PGP packet ~s" pkt))
  pkt)


(defclass pgp-pkt-user-id (pgp-packet)
    ((user-id :reader pgp-user-id)))

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-user-id) stream)
  (with-slots (user-id) pkt
    (setq user-id (read-pgp-string (pgp-pkt-length pkt) stream))
    (when *last-certificate-for-user-id-association*
      (setf (certificate-user-id *last-certificate-for-user-id-association*)
	    user-id)))
  pkt)


(defclass pgp-pkt-comment (pgp-packet)
    ((comment :reader pgp-pkt-comment)))

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-comment) stream)
  (with-slots (comment) pkt
    (setq comment (read-pgp-string (pgp-pkt-length pkt) stream)))
  pkt)


(defclass pgp-pkt-raw-literal-plaintext-data (pgp-packet)
    ((mode)
     (filename)
     (timestamp)
     (data)))

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-raw-literal-plaintext-data) stream)
  (with-slots (mode filename timestamp data) pkt
    (with-remaining-packet-length (remaining-length (pgp-pkt-length pkt))
      (setq mode (scl:ascii-to-char (read-pgp-integer 1 stream)))
      (let ((file-name-length (read-pgp-integer 1 stream)))
	(setq filename (read-pgp-string file-name-length stream)))
      (setq timestamp (read-pgp-timestamp stream))
      (ecase mode
	(#\b 
	 (setq data (make-array remaining-length 
				:element-type '(unsigned-byte 8)))
	 (dotimes (i remaining-length)
	   (setf (aref data i) (read-byte stream))))
	(#\c 
	 (setq data (make-array remaining-length
				:element-type 'character))
	 (dotimes (i remaining-length)
	   (setf (aref data i) (scl:ascii-to-char (read-byte stream)))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compressed data packet

(defclass pgp-pkt-compressed-data (pgp-packet)
    ((compression-algorithm)
     (decompressed-data)))

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-compressed-data) stream)
  (with-slots (compression-algorithm decompressed-data) pkt
    (setq compression-algorithm (read-byte stream))
    (setq decompressed-data (decompress compression-algorithm stream))))

(defmethod decompress ((algorithm-byte (eql 1)) stream)
  ;; PKZIP 
  (let ((data (make-array 100 
			  :element-type '(unsigned-byte 8)
			  :fill-pointer 0
			  :adjustable t)))
    (error "unimplemented")
    data))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Encrypted data pacvkets

(defclass pgp-pkt-public-key-encrypted (pgp-packet)
    (version key-id algorithm encrypted-data))

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-public-key-encrypted) stream)
  (with-slots (version key-id algorithm encrypted-data) pkt
    (with-remaining-packet-length (remaining-length (pgp-pkt-length pkt))
      (setq version (read-pgp-integer 1 stream))
      (assert (= version 2))
      (setq key-id (read-pgp-integer 8 stream))
      (setq algorithm (read-pgp-integer 1 stream))
      (assert (= algorithm 1))					;currently only RSA
      (setq encrypted-data (make-array remaining-length 
				       :element-type '(unsigned-byte 8)))
      (dotimes (i remaining-length)
	(setf (aref encrypted-data i) (read-byte stream))))))


(defclass pgp-pkt-secret-key-encrypted (pgp-packet)
    (version signature-classification signature-timestamp
	     key-id public-key-algorithm digest-algorithm 
	     digest-first-two-bytes encrypted-data))

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-secret-key-encrypted) stream)
  (with-slots (version signature-classification
		       signature-timestamp key-id public-key-algorithm
		       digest-algorithm digest-first-two-bytes encrypted-data)
	      pkt
    (with-remaining-packet-length (remaining-length (pgp-pkt-length pkt))
      (setq version (read-pgp-integer 1 stream))
      (assert (or (= version 2) (= version 3)))
      (assert (= 5 (read-pgp-integer 1 stream)))
      (setq signature-classification (read-pgp-integer 1 stream))
      (setq signature-timestamp (read-pgp-timestamp stream))
      (setq key-id (read-pgp-integer 8 stream))
      (setq public-key-algorithm (read-pgp-integer 1 stream))
      (assert (= public-key-algorithm 1))			;currently only RSA
      (setq digest-algorithm (read-pgp-integer 1 stream))
      (assert (= digest-algorithm 1))				;currently only MD5
      (setq digest-first-two-bytes (read-pgp-integer 2 stream))
      (setq encrypted-data (make-array remaining-length 
				       :element-type '(unsigned-byte 8)))
      (dotimes (i remaining-length)
	(setf (aref encrypted-data i) (read-byte stream))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Key certificates

(defclass certificate-info (pgp-packet)
    ((version-byte)
     (timestamp)
     (validity-period)						;in days
     (algorithm-key :initform nil :reader certificate-key)
     (user-id :initform nil :accessor certificate-user-id)))

(defmethod read-pgp-certificate-info ((pkt certificate-info) stream remaining-length)
  (declare (values remaining-length))
  (with-remaining-packet-length (remaining-length remaining-length)
    (with-slots (version-byte timestamp validity-period algorithm-key)
		pkt
      (setq version-byte (read-pgp-integer 1 stream)) 
      (assert (or (= version-byte 2) (= version-byte 3)))
      (setq timestamp (read-pgp-timestamp stream))				   
      (setq validity-period (read-pgp-integer 2 stream))
      (when (zerop validity-period)
	(setq validity-period :forever))
      remaining-length)))

(defclass pgp-pkt-public-key-certificate (certificate-info pgp-packet)
    ())

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-public-key-certificate) stream)
  (let ((remaining-length (pgp-pkt-length pkt)))
    (setq remaining-length 
	  (read-pgp-certificate-info pkt stream remaining-length))
    (setq remaining-length 
	  (read-pgp-algorithm-key pkt stream remaining-length))
    (assert (zerop remaining-length))
    (setq *last-certificate-for-user-id-association* pkt)
    pkt))


(defclass pgp-pkt-secret-key-certificate (certificate-info pgp-packet)
    ())

(defmethod read-pgp-packet-1 ((pkt pgp-pkt-secret-key-certificate) stream)
  (let ((remaining-length (pgp-pkt-length pkt)))
    (setq remaining-length 
	  (read-pgp-certificate-info pkt stream remaining-length))
    (setq remaining-length 
	  (read-pgp-algorithm-key pkt stream remaining-length))
    (assert (zerop remaining-length))
    (setq *last-certificate-for-user-id-association* pkt)
    pkt))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; encryption algorithm keys

(defparameter +encryption-algorithm-type-code+
	      '((1 pgp-key-rsa)))

(defclass pgp-key ()
    ((from-pkt :initarg :packet :reader key-pgp-packet)))

(defclass pgp-key-rsa (pgp-key)
    ((public-modulus :initarg :public-modulus
		     :reader rsa-public-modulus)
     (public-exponent :initarg :public-exponent 
		      :reader rsa-public-exponent)
     (protecting-cypher :initform nil :reader key-protecting-cypher)
     (pkcs-d :initform nil 
	     :initarg :d
	     :reader rsa-exponent-d)
     (pkcs-p :initform nil
	     :initarg :p
	     :reader rsa-factor-p)
     (pkcs-q :initform nil 
	     :initarg :q
	     :reader rsa-factor-q)
     (pkcs-u :initform nil
	     :initarg :u
	     :reader rsa-inverse-u)))


(defmethod read-pgp-algorithm-key ((pkt certificate-info) stream remaining-length)
  (with-slots (algorithm-key) pkt
    (let ((algorithm (second (assoc (read-byte stream) 
				    +encryption-algorithm-type-code+)))
	  (remaining-length (1- remaining-length)))
      (when algorithm
	(setq algorithm-key
	      (make-instance algorithm :packet pkt))
	(setq remaining-length 
	      (read-pgp-algorithm-key-1 algorithm-key pkt stream remaining-length)))
      remaining-length)))

(defgeneric read-pgp-algorithm-key-1 (algorithm-key pkt stream remaining-length))

(defmethod read-pgp-algorithm-key-1 ((algorithm-key pgp-key-rsa) 
				     (pkt certificate-info) stream remaining-length)
  (declare (values remaining-length))
  (with-remaining-packet-length (remaining-length remaining-length)
    (let (pc)
    (with-slots (public-modulus public-exponent 
				protecting-cypher
				pkcs-d pkcs-p pkcs-q pkcs-u) algorithm-key
      (setq public-modulus (read-pgp-big-integer stream))
      (setq public-exponent (read-pgp-big-integer stream))
      (when (typep pkt 'pgp-pkt-secret-key-certificate)
	(setq pc (read-pgp-integer 1 stream))
	(ecase pc
	  (0 (setq protecting-cypher nil))
	  (1 (setq protecting-cypher (read-pgp-integer 8 stream))))
	(setq pkcs-d (read-pgp-big-integer stream))
	(setq pkcs-p (read-pgp-big-integer stream))
	(setq pkcs-q (read-pgp-big-integer stream))
	(setq pkcs-u (read-pgp-big-integer stream))
	(read-pgp-integer 2 stream))))				;ignore checksum
    remaining-length))


#||

;;; This is from a key we sucessfully extracted:

(defconstant sample-rsa-key
   (make-instance 'pgp-key-rsa
		  :public-modulus
		  34011670771958036139018076955289720219052860541188550794164163802527046309215071561437523982031801770418740749923001
		  :public-exponent         17
		  :D
		  16005492127980252300714389155430456573671934372324023903130586709249479249268111167463339752537867727956173190985361
		  :P 5698185493900598132612717055995790731747249194755816611023
		  :Q 5968859878002306387722613521931217157085599317116902468087
		  :U 2114949439782823234954339504400156162903273715071772599341))

||#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This needs to be after the class definitions so that TYPEP won't barf

(defun list-keys-in-keyring-file (pathname)
  "Extract information about the keys in a PGP keyring file.
Values is a list of key descriptions.  Each key description is a list of
whenther the key is public or secret, the owner (user) of the key,
the key type, a flag indicating if the key is password protected, and 
the certificate as read from the keyring file."
  (let ((packets (read-pgp-file pathname))
	(keys nil))
    (dolist (packet packets)
      (typecase packet
	(pgp-pkt-secret-key-certificate
	  (let ((key (certificate-key packet)))
	    (push (list :secret (certificate-user-id packet)
			(class-name (class-of key))
			(if (key-protecting-cypher key) t nil)
			packet)
		  keys)))
	(pgp-pkt-public-key-certificate
	  (let ((key (certificate-key packet)))
	    (push (list :public (certificate-user-id packet)
			(class-name (class-of key))
			nil
			packet)
		  keys)))))
    (nreverse keys)))