DES encrypt/decrypt

adups.lisp

(in-package #:adups)

(defun to-byte-array (source &optional (transform #'identity))
  (let ((result (make-array (length source) :element-type '(unsigned-byte 8))))
    (map-into result transform source)))

(defun make-des-cipher (key &key (iv '(1 2 3 4 5 6 7 8)))
  (let ((key (to-byte-array key (if (stringp key) #'char-code #'identity)))
        (iv (to-byte-array iv)))
    (ironclad:make-cipher :des
                          :key key
                          :initialization-vector iv
                          :mode :cbc)))

(defun encrypt (data &optional (cipher (make-des-cipher "NotCrack"))
                     &aux (length (length data)))
  (multiple-value-bind (quotient reminder)
      (ceiling length 8)
    (multiple-value-bind (padded-length pad-size)
        (if (zerop reminder)
            (values (* (1+ quotient) 8) 8)
            (values (* quotient 8) (abs reminder)))
      (let ((result (make-array padded-length
                                :element-type '(unsigned-byte 8))))
        (map-into result (if (stringp data) #'char-code #'identity) data)
        ;; Add padding using PKCS#5, which seems to be same as PKCS#7,
        ;; but with a constant length of 8; see:
        ;;
        ;; https://en.wikipedia.org/wiki/Padding_%28cryptography%29#Byte_padding
        ;; https://tools.ietf.org/html/rfc5652#section-6.3
        ;;
        (fill result pad-size :start (- padded-length pad-size))
        (ironclad:encrypt-in-place cipher result)
        result))))

(defun encrypt-string (string &optional (cipher (make-des-cipher "NotCrack")))
  (check-type string string)
  (encrypt #+sbcl (sb-ext:string-to-octets string :external-format :utf-8)
           #-sbcl (trivial-utf-8:string-to-utf-8-bytes string)
           cipher))

(defun check-padding (buffer n &aux (length (length buffer)))
  (assert (<= 1 n 8)
          (n)
          "Invalid padding: ~S (expected an integer from 1 to 8)" n)
  (assert (loop for i from (- length n) below length
                always (= n (aref buffer i)))
          (buffer)
          "Expected ~D padding bytes, got: ~A"
          n (subseq buffer (max 0 (- length n)))))

(defun decrypt (data &optional (cipher (make-des-cipher "NotCrack"))
                     &aux (length (length data)))
  (let ((buffer (make-array length :element-type '(unsigned-byte 8))))
    (ironclad:decrypt cipher data buffer)
    ;; Remove padding (assumed to be PKCS#7).
    (let ((n (aref buffer (1- length))))
      (check-padding buffer n)
      (subseq buffer 0 (- length n)))))

(defun decrypt-string (bytes &optional (cipher (make-des-cipher "NotCrack")))
  #+sbcl (sb-ext:octets-to-string (decrypt bytes cipher)
                                  :external-format :utf-8)
  #-sbcl (trivial-utf-8:utf-8-bytes-to-string (decrypt bytes cipher)))

(defun decrypt-xx (string &rest args)
  (apply #'decrypt-string (base64:base64-string-to-usb8-array string) args))

(defun fwupgradeprovider/decrypt-file (path)
  (with-open-file (in path :direction :input
                           :element-type 'base-char)
    ;; Aww, the cl-base64:base64-stream-to-usb8-array function is not
    ;; implemented...
    (let* ((length (file-length in))
           (data (make-string length :element-type 'base-char)))
      (assert (= length (read-sequence data in)))
      (let ((encrypted (cl-base64:base64-string-to-usb8-array data)))
        (decrypt-string encrypted)))))

(defun from-hex (string &aux (length (length string)))
  (assert (zerop (rem length 2)))
  (let* ((nbytes (truncate length 2))
         (result (make-array nbytes :element-type '(unsigned-byte 8))))
    (loop for i from 0 below nbytes
          for start = (* i 2)
          for end = (+ 2 start)
          do (setf (aref result i)
                   (parse-integer string :start start :end end :radix 16)))
    result))

(defun adups/unscramble-byte (x)
  (declare (type (unsigned-byte 8) x)
           (optimize speed))
  ;; Bits have been rotated 3 positions left, so we take the 3 least
  ;; significant bits and make them be most significant 3 bits.
  (dpb (ldb (byte 3 0) x)
       (byte 3 5)
       (ldb (byte 5 3) x)))

(defun adups/unscramble-key (path)
  (with-open-file (in path :direction :input :element-type '(unsigned-byte 8))
    (let* ((n3 (read-byte in))
           (n (ldb (byte 4 4) n3))
           (n2 (ldb (byte 4 0) n3)))
      (declare (type (unsigned-byte 8) n3)
               (type (unsigned-byte 4) n n2))

      (when (< 0 n)
        (assert (= 8 (read-byte in)))
        (loop repeat (1- n) do (assert (zerop (read-byte in)))))

      (let* ((b (let ((buf (make-array n2 :element-type '(unsigned-byte 8))))
                  (assert (= n2 (read-sequence buf in)))
                  buf))
             (a (map-into (make-array n2 :element-type '(unsigned-byte 8))
                          #'adups/unscramble-byte
                          b)))
        (with-output-to-string (out)
          (loop with i = 0
                for byte = (read-byte in nil nil)
                while byte
                do (write-char (code-char (logxor byte (aref a i))) out)
                   (setf i (rem (1+ i) n2))))))))