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



;;; Encryption based on RSA algorithm.

;;; RSA Data Security, Inc.  Public-Key Crypyography Standards (PKCS).
;;; "PKCS#1: RSA Encryption Standard", (version 1.5, revised 1 November
;;; 1993), RSA Laboratories.

;;; Common Lisp implementation: 1994, Mark Nahabedian,
;;; Massachusetts Institute of Technology.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Compute (mod (expt base exponent) modulus) hopefully more
;;; efficiently.
(defun mod-expt (base exponent modulus)
  (assert (typep base 'integer))
  (assert (typep exponent 'integer))
  (assert (typep modulus 'integer))
  (let ((result 1)
	(base base)
	(exponent exponent))
    (if (zerop exponent)
	1
	(loop 
	  (cond 
	    ((= exponent 1)
	     (return (mod (* result base) modulus)))
	    ((oddp exponent)
	     (setq result (mod (* result base) modulus)
		   exponent (1- exponent)))
	    (t (setq base (mod (* base base) modulus)
		     exponent (floor exponent 2))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Key generation

;;; You need to provide two large prime numbers PRIME1 and PRIME2, and
;;; an exponent E.  Suggested values are 3 or 65537.

;;; (PRIME1 - 1) and E must have no common divisors. 
;;; (PRIME2 - 1) and E must have no common divisors. 

(defun test-key-components (prime1 prime2 exponent)
  (let ((ok-p t))
    (macrolet ((test-prime prime)
	       `(unless (/= 1 (gcd (1- ,prime) exponent))
		  (setq ok-p nil)
		  (format *error-output*
			  "~&(1- ~a) and EXPONENT must have no common factors" ',prime)))
      (test-prime prime1)
      (test-prime prime2))
    ok-p))

;;; The public modulus PMODULUS is the product of PRIME1 and PRIME2.
;;; PMODULUS must be greater than (EXPT 2 (* 8 12)) to work with the 12
;;; byte data blocks of the encryption standard.

(defun public-modulus-range (block-size-in-octets)
  (declare (values lower upper))
  (let ((lower (expt 2 (* 8 (1- block-size-in-octets)))))
    (values lower (* lower (expt 2 8)))))

(defun compute-public-modulus (prime1 prime2)
  (* prime1 prime2))

;;; The private exponent is a positive integer D such that (D * E - 1)
;;; is divisible by both (PRIME1 - 1) and (PRIME2 - 1)

#|
;;; why dosn't this work
(defun compute-private-exponent (prime1 prime2 public-exponent)
  ;; there can be many.  Compute the smallest one.
  (let ((temp (/ (1+ (lcm (1- prime1) (1- prime2))) public-exponent)))
    (* (numerator temp) (denominator temp))))
|#

(defun test-private-exponent (prime1 prime2 public-exponent private-exponent)
  (let ((test (1- (* private-exponent public-exponent))))
    (and (zerop (mod test (1- prime1)))
	 (zerop (mod test (1- prime2))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; converting between integers and octet strings

;;; These could be made more efficient with access to the bignum inards.
;;; It would be nice if there were a way to cons only a single bignum of
;;; the right size and just build it in place from the data in the
;;; vector.

(defun integer-to-octet-vector (integer &key vector start (octet-type '(unsigned-byte 8)))
  (let* ((required-length (ceiling (integer-length integer) 8))
	 (result (or vector
		     (make-array required-length
				 :element-type octet-type
				 :initial-element (coerce 0 octet-type))))
	 (start (or start
		    (if (array-has-fill-pointer-p result)
			(fill-pointer result)
			0)))
	 (end (+ start required-length)))
    (when (> end (length result))
      (if (adjustable-array-p result)
	  (setq result (adjust-array result (list end)))
	  (error "~s is not big enough" result)))
    (do* ((index (1- end) (1- index))
	  (bytespec (byte 8 0)
		    (byte 8 (+ 8 (byte-position bytespec))))
	  (stop-at start))
	((< index stop-at))
      (setf (aref result index)
	    (coerce (ldb bytespec integer) (array-element-type result))))
    (when (array-has-fill-pointer-p result)
      (setf (fill-pointer result) end))
    result))

(defun octet-vector-to-integer (vector &optional (start 0) (end (length vector)))
  (let ((integer 0))
    (do ((i start (1+ i)))
	((>= i end))
      (setq integer (+ (* integer 256) (char-int (aref vector i)))))
    integer))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; block formatting

;;; The block size should be the same as the size of the encryption modulus.
;;; BLOCK-TYPE:  0 or 1 for private key encryption, 2 for public key.
(defun format-encryption-block (block-type data block-size &key
					   (start 0) (end (length data))
					   block-array)
  (declare (values block-array new-start))
  (let ((block-array (or block-array
			 (make-array block-size 
				     :element-type '(unsigned-byte 8))))
	(data-length (min (- end start)
			  (- block-size 1 1 8 1))))		;0 BT PS 0
    (setf (aref block-array 0) 0)
    (setf (aref block-array 1) block-type)
    (do ((index 2 (1+ index)))
	((>= index (- block-size data-length 1))
	 (setf (aref block-array index) 0))
      (setf (aref block-array index)
	    (ecase block-type 
	      ((0) 0)
	      ((1) #xff)
	      ((2) (1+ (random 255))))))
    (when (= block-type 0)
      (assert (not (zerop (aref data start)))))
    (do ((from-index start (1+ from-index))
	 (to-index (- block-size data-length) (1+ to-index)))
	((>= to-index block-size))
      (setf (aref block-array to-index)
	    (aref data from-index)))
    (values block-array (+ start data-length))))

(defun extract-data-from-encryption-block (block-array &key data-array start)
  (let* ((data-array (or data-array 
			 (make-array 100
				     :element-type '(unsigned-byte 8)
				     :fill-pointer 0
				     :adjustable t)))
	 (start (or start
		    (if (array-has-fill-pointer-p data-array)
			(fill-pointer data-array)
			0)))
	 data-bytes)
    (assert (zerop (aref block-array 0)))
    (assert (member (aref block-array 1) '(0 1 2)))		;known block types
    (let ((from-index 2)
	  (to-index start))
      ;; skip pad string.  For block type 0, must rely on first data byte being non-zero.
      (loop
	(when (zerop (aref block-array from-index))
	  (return))
	(incf from-index))
      (assert (zerop (aref block-array from-index)))
      (incf from-index)
      (setq data-bytes (- (length block-array) from-index))
      (when (> (+ start data-bytes) (length data-array))
	;; maybe should adjust by some larger number of the array has a fill pointer?
	(setq data-array (adjust-array data-array (+ start data-bytes))))
      ;; copy the data
      (loop
	(when (>= from-index (length block-array))
	  (return))
	(setf (aref data-array to-index)
	      (coerce (aref block-array from-index)
		      (array-element-type data-array)))
	(incf from-index)
	(incf to-index))
      (when (array-has-fill-pointer-p data-array)
	(incf (fill-pointer data-array) data-bytes)))
    data-array))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; encrypting and decrypting

(defun rsa-encrypt-block (input-vector input-start output-vector output-start
				       block-length exponent modulus)
  (let ((integer (octet-vector-to-integer input-vector 
					  input-start 
					  (+ input-start block-length))))
    (integer-to-octet-vector (mod-expt integer exponent modulus)
			     :vector output-vector 
			     :start output-start)))

(defun rsa-encrypt (data exponent modulus block-size)
  ;; is this right?
  (assert (< block-size (- (ceiling (integer-length modulus) 8) 11)))
  ;;; do block formatting stuff
  (let ((data-index 0)
	block encrypted-block)
    (loop
      (when (>= data-index (length data))
	(return))
      (multiple-value-setq (block data-index)
	(format-encryption-block 1 data block-size :start data-start
				 :block-array block))
      (rsa-encrypt-block block 0 encrypted-block 0 block-size exponent modulus)
      
      )))