;;;; octet-stream.lisp -- like string-streams, but with (VECTOR (UNSIGNED-BYTE 8))

(in-package :crypto)


;;; portability definitions

(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *binary-input-stream-class*
  (quote
   #+sbcl sb-gray:fundamental-binary-input-stream
   #+openmcl ccl:fundamental-binary-input-stream
   #+cmu ext:fundamental-binary-input-stream
   #+allegro excl:fundamental-binary-input-stream
   #-(or sbcl openmcl cmu allegro) (error "octet streams not supported in this implementation")))

(defvar *binary-output-stream-class*
  (quote
   #+sbcl sb-gray:fundamental-binary-output-stream
   #+openmcl ccl:fundamental-binary-output-stream
   #+cmu ext:fundamental-binary-output-stream
   #+allegrao excl:fundamental-binary-output-stream
   #-(or sbcl openmcl cmu allegro) (error "octet streams not supported in this implementation")))

;;; FIXME: how to do CMUCL support for this?
(defvar *stream-element-type-function*
  (quote
   #+sbcl sb-gray::stream-element-type
   #+openmcl cl:stream-element-type
   #+cmu cl:stream-element-type
   #+allegro excl:stream-element-type
   #-(or sbcl openmcl cmu allegro) (error "octet streams not supported in this implementation")))

(defvar *stream-read-byte-function*
  (quote
   #+sbcl sb-gray:stream-read-byte
   #+openmcl ccl:stream-read-byte
   #+cmu ext:stream-read-byte
   #+allegro excl:stream-read-byte
   #-(or sbcl openmcl cmu allegro) (error "octet streams not supported in this implementation")))

(defvar *stream-write-byte-function*
  (quote
   #+sbcl sb-gray:stream-write-byte
   #+openmcl ccl:stream-write-byte
   #+cmu ext:stream-write-byte
   #+allegro excl:stream-write-byte
   #-(or sbcl openmcl cmu allegro) (error "octet streams not supported in this implementation")))

;;; FIXME: would be nice to support STREAM-{READ,WRITE}-SEQUENCE, too.  The
;;; function name hacking is here, but the actual implementation (and
;;; possible arglist headaches) are not.
(defvar *stream-read-sequence-function*
  (quote
   #+sbcl sb-gray:stream-read-sequence
   #+openmcl ccl:stream-read-vector
   #+cmu ext:stream-read-sequence
   #+allegro excl:stream-read-sequence
   #-(or sbcl openmcl cmu allegro) (error "octet streams not supported in this implementation")))

(defvar *stream-write-sequence-function*
  (quote
   #+sbcl sb-gray:stream-write-sequence
   #+openmcl ccl:stream-write-vector
   #+cmu ext:stream-write-sequence
   #+allegro excl:stream-write-sequence
   #-(or sbcl openmcl cmu allegro) (error "octet streams not supported in this implementation")))
)


;;; implementation via Gray streams

;;; These could be specialized for particular implementations by hooking
;;; in directly to the "native" stream methods for the implementation.

(defclass octet-stream ()
  ((buffer :accessor buffer :initarg :buffer :type (simple-array (unsigned-byte 8) (*)))))

;;; FIXME: how to do CMUCL support for this?
(defmethod #.*stream-element-type-function* ((stream octet-stream))
  '(unsigned-byte 8))


;;; input streams

(defclass octet-input-stream (octet-stream #.*binary-input-stream-class*)
  ((index :accessor index :initarg :index :type index)
   (end :accessor end :initarg :end :type index)))

(defmethod #.*stream-read-byte-function* ((stream octet-input-stream))
  (let ((buffer (buffer stream))
        (index (index stream)))
    (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
    (cond
      ((>= index (end stream)) :eof)
      (t
       (setf (index stream) (1+ index))
       (aref buffer index)))))

(defun make-octet-input-stream (buffer &optional (start 0) end)
  "As MAKE-STRING-INPUT-STREAM, only with octets instead of characters."
  (declare (type (simple-array (unsigned-byte 8) (*)) buffer)
           (type index start)
           (type (or index null) end))
  (let ((end (or end (length buffer))))
    (make-instance 'octet-input-stream
                   :buffer buffer :index start :end end)))


;;; output streams

(defclass octet-output-stream (octet-stream #.*binary-output-stream-class*)
  ((index :accessor index :initform 0 :type index)))

(defmethod #.*stream-write-byte-function* ((stream octet-output-stream) integer)
  (declare (type (unsigned-byte 8) integer))
  (let* ((buffer (buffer stream))
         (length (length buffer))
         (index (index stream)))
    (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
    (when (>= index (length buffer))
      (let ((new-buffer (make-array (* 2 length)
                                    :element-type '(unsigned-byte 8))))
        (declare (type (simple-array (unsigned-byte 8) (*)) new-buffer))
        (replace new-buffer buffer)
        (setf buffer new-buffer
              (buffer stream) new-buffer)))
    (setf (aref buffer index) integer
          (index stream) (1+ index))
    integer))

#+sbcl
(defmethod sb-gray:stream-write-sequence ((stream octet-output-stream) sequence &optional (start 0) end)
  (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
  (let* ((buffer (buffer stream))
         (buffer-length (length buffer))
         (sequence-length (- (or end (length sequence)) start))
         (index (index stream)))
    (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
    (when (> (+ index sequence-length) buffer-length)
      (let ((new-buffer (make-array (* 2 (+ index sequence-length))
                                    :element-type '(unsigned-byte 8))))
        (declare (type (simple-array (unsigned-byte 8) (*)) new-buffer))
        (replace new-buffer buffer)
        (setf buffer new-buffer
              (buffer stream) new-buffer)))
    (locally (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
      (replace buffer sequence :start1 index
               :start2 start :end2 (or end (length sequence)))
      (setf (index stream) (+ index sequence-length))
      sequence)))

(defun get-output-stream-octets (stream)
  "As GET-OUTPUT-STREAM-STRING, only with an octet output-stream instead
of a string output-stream."
  (let ((buffer (buffer stream))
        (index (index stream)))
    (setf (index stream) 0)
    (subseq buffer 0 index)))

(defun make-octet-output-stream ()
  "As MAKE-STRING-OUTPUT-STREAM, only with octets instead of characters."
  (make-instance 'octet-output-stream
                 :buffer (make-array 128 :element-type '(unsigned-byte 8))))


;;; digesting streams

(defclass digesting-stream (#.*binary-output-stream-class*)
  ((digest :initarg :digest :reader stream-digest)
   (buffer :initform (make-array 64 :element-type '(unsigned-byte 8))
           :reader stream-buffer)
   (position :initform 0
             :reader stream-buffer-position)))

(defmethod #.*stream-element-type-function* ((stream digesting-stream))
  '(unsigned-byte 8))

(defun make-digesting-stream (digest)
  (make-instance 'digesting-stream :digest (make-digest digest)))

(defmethod #.*stream-write-byte-function* ((stream digesting-stream) byte)
  (declare (type (unsigned-byte 8) byte))
  (with-slots (digest buffer position) stream
    (setf (aref buffer position) byte)
    (when (= (incf position) 64)
      (update-digest digest buffer :start 0 :end 64)
      (setf position 0))
    byte))

(defmethod produce-digest ((stream digesting-stream))
  (with-slots (digest buffer position) stream
    (unless (zerop position)
      (update-digest digest buffer :start 0 :end position)
      (setf position 0))
    (let ((copy (copy-digest digest)))
      (produce-digest copy))))


;;; encrypting and decrypting streams

(defclass crypting-stream ()
  ((cipher :initarg :cipher :reader stream-cipher)
   (buffer :initarg :buffer :reader stream-buffer)
   (buffer-length :initarg :buffer-length :reader stream-buffer-length)
   (position :initform 0 :reader stream-buffer-position)
   (padding :initarg :padding :reader stream-padding)))

(defmethod #.*stream-element-type-function* ((stream crypting-stream))
  '(unsigned-byte 8))

(defclass encrypting-input-stream (crypting-stream #.*binary-input-stream-class*) ())
(defclass encrypting-output-stream (crypting-stream #.*binary-output-stream-class*) ())
(defclass decrypting-input-stream (crypting-stream #.*binary-input-stream-class*) ())
(defclass decrypting-output-stream (crypting-stream #.*binary-output-stream-class*) ())

(deftype stream-direction () '(member :input :output))

(defun make-encrypting-stream (cipher mode key
                               &key initialization-vector
                               direction (padding :none))
  (declare (type stream-direction direction))
  (declare (ignorable padding))
  (let* ((context (make-cipher cipher mode key initialization-vector))
         (block-length (max (block-length cipher) 16))
         (buffer (make-array block-length :element-type '(unsigned-byte 8))))
    (if (eq direction :input)
        (make-instance 'encrypting-input-stream
                       :cipher context :buffer buffer
                       :buffer-length block-length)
        (make-instance 'encrypting-output-stream
                       :cipher context :buffer buffer
                       :buffer-length block-length))))

(defun make-decrypting-stream (cipher mode key
                               &key initialization-vector (padding :none)
                               (direction :input))
  (declare (type stream-direction direction))
  (declare (ignorable padding))
  (let* ((context (make-cipher cipher mode key initialization-vector))
         (block-length (max (block-length cipher) 16))
         (buffer (make-array block-length :element-type '(unsigned-byte 8))))
    (if (eq direction :input)
        (make-instance 'decrypting-input-stream
                       :cipher context :buffer buffer
                       :buffer-length block-length)
        (make-instance 'decrypting-output-stream
                       :cipher context :buffer buffer
                       :buffer-length block-length))))

(defmethod #.*stream-read-byte-function* ((stream encrypting-input-stream))
  (crypting-stream-read-byte stream #'encrypt))

(defmethod #.*stream-read-byte-function* ((stream decrypting-input-stream))
  (crypting-stream-read-byte stream #'decrypt))

(defmethod #.*stream-write-byte-function* ((stream encrypting-output-stream) byte)
  (declare (type (unsigned-byte 8) byte))
  (crypting-stream-write-byte stream byte #'encrypt))

(defmethod #.*stream-write-byte-function* ((stream decrypting-output-stream) byte)
  (declare (type (unsigned-byte 8) byte))
  (crypting-stream-write-byte stream byte #'decrypt))
