;;;; cipher.lisp -- generic functions for symmetric encryption

(in-package :crypto)

(defgeneric encrypt (cipher plaintext ciphertext
                            &key plaintext-start plaintext-end
                            ciphertext-start)
  (:documentation "Encrypt the data in PLAINTEXT between PLAINTEXT-START
and PLAINTEXT-END according to CIPHER.  Places the encrypted data in
CIPHERTEXT, beginning at CIPHERTEXT-START.  Less data than
 (- PLAINTEXT-END PLAINTEXT-START) may be encrypted, depending on the
alignment constraints of CIPHER and the amount of space available in
CIPHERTEXT."))

(defgeneric decrypt (cipher ciphertext plaintext
                            &key ciphertext-start ciphertext-end
                            plaintext-start)
  (:documentation "Decrypt the data in CIPHERTEXT between CIPHERTEXT-START
and CIPHERTEXT-END according to CIPHER.  Places the decrypted data in
PLAINTEXT, beginning at PLAINTEXT-START.  Less data than
 (- CIPHERTEXT-END CIPHERTEXT-START) may be encrypted, depending on the
alignment constraints of CIPHER and the amount of space available in
PLAINTEXT."))

(defun encrypt-in-place (cipher text &key (start 0) end)
  (encrypt cipher text text
           :plaintext-start start :plaintext-end (or end (length text))
           :ciphertext-start start))

(defun decrypt-in-place (cipher text &key (start 0) end)
  (decrypt cipher text text
           :ciphertext-start start :ciphertext-end (or end (length text))
           :plaintext-start start))

(defclass cipher ()
  ((mode :initarg :mode :accessor mode)
   (initialized-p :initform nil :accessor initialized-p)))

;;; Block ciphers are denoted by the use of the {8,16}-byte-block-mixin.
(defclass stream-cipher (cipher)
  ())


;;; utilities for wordwise fetches and stores

;;; we attempt to make this as efficient as possible.  the first check we
;;; do is to see whether or not the range
;;; [INITIAL-OFFSET, INITIAL-OFFSET + BLOCK-SIZE) is within the bounds of
;;; the array.  if not, then we do the fetches as normal.  if so, then we
;;; can either (DECLARE (SAFETY 0)) to avoid the bounds-checking on the
;;; fetches, or we can do full-word fetches if INITIAL-OFFSET is
;;; word-addressable and the implementation supports it.
#+nil
(defmacro with-words (((&rest word-vars) array initial-offset
                       &key (size 4) (big-endian t))
                      &body body)
  (let ((ref-sym (ubref-fun-name (* size 8) big-endian))
        (n-bytes (* (length word-vars) size)))
    (flet ((generate-fetches (n-fetches)
             (loop for offset from 0 by size below (* n-fetches size)
                   collect `(,ref-sym ,array (+ ,initial-offset ,offset)))))
      `(multiple-value-bind ,word-vars (let ((length (length ,array)))
                                         (cond
                                           ((<= ,initial-offset (- length ,n-bytes))
                                            ,(if (and (member :sbcl *features*)
                                                      (= size 4)
                                                      (or (and big-endian (member :big-endian *features*))
                                                          (and (not big-endian) (member :little-endian *features*))))
                                                 `(if (logtest ,initial-offset (1- ,size))
                                                      ;; do FETCH-UB* way
                                                      (locally (declare (optimize (safety 0)))
                                                        (values ,@(generate-fetches (length word-vars))))
                                                      (let ((word-offset (truncate ,initial-offset 4)))
                                                        (values
                                                         ,@(loop for offset from 0 below (length word-vars)
                                                              collect `(sb-kernel:%vector-raw-bits ,array (+ word-offset ,offset))))))
                                                  `(locally (declare (optimize (safety 0)))
                                                     (values ,@(generate-fetches (length word-vars))))))
                                           (t
                                            (values ,@(generate-fetches (length word-vars))))))
         (declare (type (unsigned-byte ,(* size 8)) ,@word-vars))
         (macrolet ((store-words (buffer buffer-offset &rest word-vars)
                      (loop for word-var in word-vars
                         for offset from 0 by ,size
                         collect `(setf (,',ref-sym ,buffer (+ ,buffer-offset ,offset)) ,word-var)
                         into stores
                         finally (return `(progn ,@stores)))))
           ,@body)))))

(defmacro with-words (((&rest word-vars) array initial-offset
                       &key (size 4) (big-endian t))
                      &body body)
  (let ((ref-sym (ubref-fun-name (* size 8) big-endian)))
    (loop for word-var in word-vars
          for offset from 0 by size
          collect `(,word-var (,ref-sym ,array (+ ,initial-offset ,offset)))
          into let-bindings
          finally (return `(macrolet ((store-words (buffer buffer-offset &rest word-vars)
                                       (loop for word-var in word-vars
                                             for offset from 0 by ,size
                                             collect `(setf (,',ref-sym ,buffer (+ ,buffer-offset ,offset)) ,word-var)
                                             into stores
                                             finally (return `(progn ,@stores)))))
                             (let ,let-bindings
                               (declare (type (unsigned-byte ,(* size 8)) ,@word-vars))
                               ,@body))))))


;;; mixins for dispatching

(defclass 8-byte-block-mixin ()
  ())

(defclass 16-byte-block-mixin ()
  ())


;;; defining ciphers

;;; the idea behind this is that one only has to implement encryption
;;; and decryption of a block for a particular cipher (and perhaps
;;; some key generation) and then "define" the cipher with some
;;; parameters.  necessary interface functions will be auto-generated
;;; with this macro.

;;; possible things to go in INITARGS
;;;
;;; * (:encrypt-function #'cipher-encrypt-block)
;;; * (:decrypt-function #'cipher-decrypt-block)
;;; * (:key-length (:fixed &rest lengths))
;;; * (:key-length (:variable low high increment))
;;; * (:constructor #'create-cipher-context)
(defmacro defcipher (name &rest initargs)
  (%defcipher name initargs))

;;; KLUDGE: we add the blocksize to these two forms so that we can declare
;;; the type of the *-START parameters correctly.  That is, good Lisp
;;; implementations will see that references into the plaintext and
;;; ciphertext can never overflow into bignum land; shorter code should
;;; then be generated.  This is a kludge, however, because we're putting
;;; the blocksize in three different places: once in the encryptor, once
;;; in the decryptor, and once in the DEFCIPHER form.  It would be nice
;;; if there was one single place to put everything.
(defmacro define-block-encryptor (algorithm blocksize &body body)
  `(defun ,(intern (format nil "~A-ENCRYPT-BLOCK" algorithm))
    (context plaintext plaintext-start ciphertext ciphertext-start)
    (declare (optimize (speed 3) (debug 0) (space 0)))
    (declare (type simple-octet-vector plaintext ciphertext)
     (type (integer 0 ,(- array-dimension-limit blocksize))
      plaintext-start ciphertext-start))
    ,@body))

(defmacro define-block-decryptor (algorithm blocksize &body body)
  `(defun ,(intern (format nil "~A-DECRYPT-BLOCK" algorithm))
    (context ciphertext ciphertext-start plaintext plaintext-start)
    (declare (optimize (speed 3) (debug 0) (space 0)))
    (declare (type simple-octet-vector ciphertext plaintext)
     (type (integer 0 ,(- array-dimension-limit blocksize))
      ciphertext-start plaintext-start))
    ,@body))

(defmacro define-stream-cryptor (algorithm &body body)
  `(defun ,(intern (format nil "~A-CRYPT" algorithm))
       (context plaintext plaintext-start ciphertext ciphertext-start length)
     (declare (optimize (speed 3) (debug 0) (space 0)))
     (declare (type (simple-array (unsigned-byte 8) (*)) plaintext ciphertext))
     (declare (type index plaintext-start ciphertext-start length))
     ,@body))

(defgeneric verify-key (cipher key)
  (:documentation "Return T if KEY is a valid encryption key for CIPHER."))

;; Catch various errors.
(defmethod verify-key (cipher key)
  ;; check the key first
  (when (cl:null key)
    (error 'key-not-supplied :cipher cipher))
  (unless (typep key '(vector (unsigned-byte 8)))
    (error 'type-error :datum key :expected-type '(vector (unsigned-byte 8))))
  ;; hmmm, the key looks OK.  what about the cipher?
  (unless (member cipher (list-all-ciphers))
    (error 'unsupported-cipher :name cipher)))

(defgeneric schedule-key (cipher key)
  (:documentation "Schedule KEY for CIPHER, filling CIPHER with any
round keys, etc. needed for encryption and decryption."))

(defmethod schedule-key :before ((cipher cipher) key)
  (verify-key cipher key))

;;; introspection
(defclass cipher-info ()
  ((class-name :reader %class-name :initarg :class-name)
   (name :reader cipher :initarg :cipher)
   (block-length :reader %block-length :initarg :block-length)
   (key-lengths :reader %key-lengths :initarg :key-lengths)))

(defmethod print-object ((object cipher-info) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "~A" (cipher object))))

(defun %find-cipher (name)
  (and (symbolp name)
       (let ((name (massage-symbol name)))
         (and name (get name '%cipher-info)))))

(defun (setf %find-cipher) (cipher-info name)
  (setf (get (massage-symbol name) '%cipher-info) cipher-info))

(defgeneric key-lengths (cipher)
  (:documentation "Return a list of possible lengths of a key for
CIPHER.  CIPHER may either be a cipher name as accepted by
MAKE-CIPHER or a cipher object as returned by MAKE-CIPHER.  NIL
is returned if CIPHER does not name a known cipher or is not a
cipher object."))

(defmethod key-lengths (cipher)
  (let ((cipher-info (%find-cipher cipher)))
    (and cipher-info (%key-lengths cipher-info))))

(defmethod key-lengths ((cipher cipher))
  (key-lengths (class-name (class-of cipher))))

(defgeneric block-length (cipher)
  (:documentation "Return the number of bytes in an encryption or
decryption block for CIPHER.  CIPHER may either be a cipher name
as accepted by MAKE-CIPHER or a cipher object as returned by
MAKE-CIPHER.  NIL is returned if CIPHER does not name a known
cipher or is not a cipher object."))

(defmethod block-length ((cipher symbol))
  (let ((cipher-info (%find-cipher (massage-symbol cipher))))
    (and cipher-info (%block-length cipher-info))))

(defmethod block-length ((cipher cipher))
  (block-length (class-name (class-of cipher))))

(defmethod block-length ((cipher 8-byte-block-mixin))
  8)

(defmethod block-length ((cipher 16-byte-block-mixin))
  16)

(defun list-all-ciphers ()
  (loop for symbol being each external-symbol of (find-package :ironclad)
     if (%find-cipher symbol)
     collect symbol))

(defun cipher-supported-p (name)
  "Return T if the cipher NAME is supported as an argument to MAKE-CIPHER."
  (not (cl:null (%find-cipher name))))

(defun acceptable-key-lengths* (key-length-spec)
  (ecase (car key-length-spec)
    (:fixed (loop for length in (cdr key-length-spec)
               collect `(= length ,length) into forms
               finally (return `(or ,@forms))))
    (:variable (destructuring-bind (low high increment) (cdr key-length-spec)
                 (if (= increment 1)
                     `(<= ,low length ,high)
                     ;; Punt.  It'd be a weird cipher implemented otherwise.
                     (error "Need to implement the (/= INCREMENT 1) case"))))))

(defun acceptable-key-lengths (key-length-spec)
  (ecase (car key-length-spec)
    (:fixed (cdr key-length-spec))
    (:variable (destructuring-bind (low high increment) (cdr key-length-spec)
                 (loop for i from low to high by increment
                       collect i)))))

(defun generate-key-verifier-methods (name key-length-spec)
  (let ((acceptable-key-lengths (acceptable-key-lengths key-length-spec)))
    `(defmethod verify-key ((cipher ,name) (key vector))
      (unless (equal (array-element-type key) '(unsigned-byte 8))
        (error 'type-error :expected-type '(vector (unsigned-byte 8))
               :datum key))
      (let ((length (length key)))
        (cond 
          (,(acceptable-key-lengths* key-length-spec) (copy-seq key))
          (t (error 'invalid-key-length
                    :cipher ',name
                    :accepted-lengths ',acceptable-key-lengths)))))))

(defun generate-common-cipher-methods (name block-length key-length-spec)
  `(progn
     ;; make sure we pass in valid keys
     ,(generate-key-verifier-methods name key-length-spec)
     (setf (%find-cipher ',name)
           (make-instance 'cipher-info
                          :class-name ',name
                          :cipher ',name
                          :block-length ,block-length
                          :key-lengths ',(acceptable-key-lengths key-length-spec)))))

(defun generate-block-cipher-forms (name key-length-spec
                                    encrypt-function decrypt-function)
  (declare (ignorable key-length-spec))
  `(progn
     (defmethod encrypt-function ((cipher ,name))
       #',encrypt-function)
     (defmethod decrypt-function ((cipher ,name))
       #',decrypt-function)))

(defun generate-stream-cipher-forms (name key-length-spec crypt-function)
  (declare (ignorable key-length-spec))
  `(progn
     (defmethod encrypt-function ((cipher ,name))
       #',crypt-function)
     (defmethod decrypt-function ((cipher ,name))
       #',crypt-function)))

(defun %defcipher (name initargs)
  (let ((encrypt-function nil)
        (decrypt-function nil)
        (crypt-function nil)
        (block-length nil)
        (mode :block)
        (key-length-spec nil)
        (constructor nil))
    (declare (ignorable constructor))
    (loop for (arg value) in initargs
          do (case arg
               (:encrypt-function
                (if (not encrypt-function)
                    (setf encrypt-function value)
                    (error "Specified :ENCRYPT-FUNCTION multiple times.")))
               (:decrypt-function
                (if (not decrypt-function)
                    (setf decrypt-function value)
                    (error "Specified :DECRYPT-FUNCTION multiple times.")))
               (:crypt-function
                (if (not crypt-function)
                    (setf crypt-function value)
                    (error "Specified :CRYPT-FUNCTION multiple times.")))
               (:mode
                (setf mode value))
               (:block-length
                (cond
                  (block-length
                   (error "Specified :BLOCK-LENGTH multiple times."))
                  ((or (not (integerp value))
                       (not (plusp value)))
                   (error ":BLOCK-LENGTH must be a positive, integral number."))
                  (t
                   (setf block-length value))))
               (:key-length
                (cond
                  (key-length-spec
                   (error "Specified :KEY-LENGTH multiple times."))
                  ((not (consp value))
                   (error ":KEY-LENGTH value must be a list."))
                  ((and (not (eq :fixed (car value)))
                        (not (eq :variable (car value))))
                   (error "First element of :KEY-LENGTH spec must be either :FIXED or :VARIABLE."))
                  ((eq :fixed (car value))
                   (if (and (cdr value)
                            (every #'integerp (cdr value))
                            (every #'plusp (cdr value)))
                       (setf key-length-spec value)
                       ;;; FIXME: better error message
                       (error "bad :FIXED specification for :KEY-LENGTH.")))
                  ((eq :variable (car value))
                   (if (and (cl:null (nthcdr 4 value))
                            (every #'integerp (cdr value))
                            (every #'plusp (cdr value))
                            (< (cadr value) (caddr value)))
                       (setf key-length-spec value)
                       (error "bad :VARIABLE specification for :KEY-LENGTH."))))))
          finally (cond
                    ((and (eq mode :block) key-length-spec encrypt-function decrypt-function)
                     (return
                       `(progn
                          (eval-when (:compile-toplevel :load-toplevel)
                            (export ',name :ironclad))
                          ,(generate-common-cipher-methods name block-length key-length-spec)
                          ,(generate-block-cipher-forms name key-length-spec
                                                        encrypt-function decrypt-function))))
                    ((and (eq mode :stream) crypt-function key-length-spec)
                     (return
                       `(progn
                          (eval-when (:compile-toplevel :load-toplevel)
                            (export ',name :ironclad))
                          ,(generate-common-cipher-methods name 1 key-length-spec)
                          ,(generate-stream-cipher-forms name key-length-spec crypt-function))))
                    (t
                     (error "Didn't specify all required fields for DEFCIPHER"))))))