cl-keccak, Week 3

Posted 2018-07-30

With three weeks spent on the cl-keccak project, the thing is nearing completion. Currently there exists a (hopefully) working sponge, taking in an arbitrarily long vector of bits, and returning an equally arbitrarily long vector of bits. And after fixing two bugs in last week's post, my state transitions match those of s.mg keccak.

However, cl-keccak does not seem to agree with s.mg keccak on return hashes. For instance, if we place1

Long live the Republic!

in a file, ascii encoded, cl-keccak reports the hash as

18B75F434B28705333D18C57627085596EBF2AF68F52D3CF5796C01EAA682D4D5F259D2F89F9AEE082BC577B4DBEB8882D5F125DCE5FC977F701817487F06078

where the raw binary data (reported by xxd -b) is

00000000: 01001100 01101111 01101110 01100111 00100000 01101100  Long l
00000006: 01101001 01110110 01100101 00100000 01110100 01101000  ive th
0000000c: 01100101 00100000 01110010 01100101 01110000 01110101  e repu
00000012: 01100010 01101100 01101001 01100011 00100001 00001010  blic!.

Whereas s.mg keccak (taken from vtools) reports

dc3c4ed4bcbdc55d0917cbea51272f30b0d0dfa5d029100871e383be39568cec30afd298878a7d7f51ce5bad6bc01d651adf1ac5355652cf623d55b9d7da97dc

for the same file. So, I'm going to put the current state of my work below, and attempt to hash out the details this week in the logs.

As for parameters, cl-keccak uses

  • 6 for the Keccak L parameter
  • 1600 for the width
  • 1344 for the bitrate
  • 512 for the output bits

The primary function, keccak-sponge, takes a bit-vector as input and returns a bit-vector as output. At this level, there are no endianness issues whatsoever.

When interfacing with the disk, cl-keccak uses read-byte, which on my machine reads bits in 8 at a time, returning an integer as an (unsigned-byte 8). cl-keccak then converts this integer into a bit-vector which is 8 bits long, creating a little-endian representation of the integer. Ideally, I would like be able to read from the disk a single bit at the time, but as far as I am aware, this is not possible (and not meaningful on a byte-addressed architecture). Hence cl-keccak relies on the system to consistently interpret stored bytes as the same integer on differing hardware architectures.

Finally for this week, here is the current state of the program2:

package.lisp:

(defpackage "CL-KECCAK"
  (:use "COMMON-LISP" "CL-USER")
  (:export keccak-sponge))

bits.lisp:

(in-package "CL-KECCAK")

(defun bit-chunk (bit-vector chunk-size)
  (assert (= 0 (mod (length bit-vector) chunk-size)))
  (let ((chunks '()))
    (dotimes (c (/ (length bit-vector) chunk-size))
      (setq chunks (append chunks (list (subseq bit-vector
                                                (* c chunk-size)
                                                (* (1+ c) chunk-size))))))
    chunks))

(defun bit-pad-right (bv n)
  (do ((x (coerce bv 'list) (append x '(0))))
      ((>= (length x) n)
       (coerce x 'simple-bit-vector))))

(defun bit-pad-right-and-chunk (bit-vector chunk-size)
  (bit-chunk (bit-pad-right bit-vector
                            (* chunk-size (ceiling (length bit-vector)
                                                   chunk-size)))
             chunk-size))

(defun concatenate-bit-vectors (bit-vector-list)
  (reduce #'(lambda (a b) (concatenate 'simple-bit-vector a b))
          bit-vector-list))

(defun bit-vector-to-integer (bv)
  (reduce #'(lambda (a b) (+ a (* 2 b)))
          bv
          :from-end t))

(defun integer-to-bit-vector (n)
  (labels ((bit-array-iter (n array)
             (if (zerop n)
                 array
                 (multiple-value-bind (q r)
                     (floor n 2)
                   (bit-array-iter q
                                   (append array (list r)))))))
    (bit-pad-right (bit-array-iter n '()) 8)))

(defun file-to-bit-vector (filepath)
  (with-open-file (f filepath :direction :input :element-type 'bit)
    (concatenate-bit-vectors
     (mapcar #'integer-to-bit-vector
             (let ((s (make-sequence 'list (file-length f))))
               (read-sequence s f)
               s)))))

cl-keccak.lisp:

(in-package "CL-KECCAK")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; configure the keccak_L parameter here

(defconstant +keccak_L+ 6)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; magic numbers

(defconstant +row-size+ 5)
(defconstant +column-size+ 5)
(defconstant +lane-size+ (expt 2 +keccak_L+))
(defconstant +keccak-width+ (* +row-size+ +column-size+ +lane-size+))
(defconstant +round-quantity+ (+ 12 (* 2 +keccak_L+)))

(defparameter *default-bitrate* 1344)
(defparameter *default-output-bits* 512)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lanes

;; definition of a lane
(deftype lane () `(simple-bit-vector ,+lane-size+))

;; instantiation lanes
(defun make-lane ()
  (make-sequence 'lane +lane-size+ :initial-element 0))

(defun copy-lane (lane)
  (make-array `(,+lane-size+) :element-type 'bit
              :initial-contents lane))

;; basic operations on lanes
(defun lane-and (a b)
  (declare (type lane a b))
  (bit-and a b))

(defun lane-xor (a b)
  (declare (type lane a b))
  (bit-xor a b))

(defun lane-not (a)
  (declare (type lane a))
  (bit-not a))

(defun lane-rot (a n)
  (let* ((rtn (make-lane)))
    (dotimes (z +lane-size+)
      (setf (aref rtn (mod (+ z n) +lane-size+))
            (aref a z)))
    rtn))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; magic lanes

(defconstant +round-constants+
  (let ((magic
         '(#*1000000000000000000000000000000000000000000000000000000000000000
           #*0100000100000001000000000000000000000000000000000000000000000000
           #*0101000100000001000000000000000000000000000000000000000000000001
           #*0000000000000001000000000000000100000000000000000000000000000001
           #*1101000100000001000000000000000000000000000000000000000000000000
           #*1000000000000000000000000000000100000000000000000000000000000000
           #*1000000100000001000000000000000100000000000000000000000000000001
           #*1001000000000001000000000000000000000000000000000000000000000001
           #*0101000100000000000000000000000000000000000000000000000000000000
           #*0001000100000000000000000000000000000000000000000000000000000000
           #*1001000000000001000000000000000100000000000000000000000000000000
           #*0101000000000000000000000000000100000000000000000000000000000000
           #*1101000100000001000000000000000100000000000000000000000000000000
           #*1101000100000000000000000000000000000000000000000000000000000001
           #*1001000100000001000000000000000000000000000000000000000000000001
           #*1100000000000001000000000000000000000000000000000000000000000001
           #*0100000000000001000000000000000000000000000000000000000000000001
           #*0000000100000000000000000000000000000000000000000000000000000001
           #*0101000000000001000000000000000000000000000000000000000000000000
           #*0101000000000000000000000000000100000000000000000000000000000001
           #*1000000100000001000000000000000100000000000000000000000000000001
           #*0000000100000001000000000000000000000000000000000000000000000001
           #*1000000000000000000000000000000100000000000000000000000000000000
           #*0001000000000001000000000000000100000000000000000000000000000001)))
    (make-array '(24)
                :element-type 'lane
                :initial-contents
                (mapcar #'(lambda (x) (subseq x 0 +lane-size+))
                        magic))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; states

(deftype state () `(array lane (,+row-size+ ,+column-size+)))

(defun make-state ()
  (make-array `(,+row-size+ ,+column-size+)
              :element-type 'lane
              :initial-element (make-lane)))

(defun lane (a x y)
  (declare (type state a)
           (type fixnum x y))
  (aref a (mod x +row-size+) (mod y +column-size+)))

(defmethod set-lane (a x y L)
  (setf (aref a (mod x +row-size+) (mod y +column-size+))
        L))

(defsetf lane set-lane)

(defun copy-state (state)
  (let ((s (make-array `(,+row-size+ ,+column-size+)
                       :initial-element (make-lane)
                       :element-type 'lane)))
    (dotimes (x +row-size+)
      (dotimes (y +column-size+)
        (setf (lane s x y)
              (copy-lane (lane state x y)))))
    s))

(defun state-linearize (state &optional
                                (start 0)
                                (end +keccak-width+))
  (let ((r '()))
    (dotimes (y +column-size+)
      (dotimes (x +row-size+)
        (setq r (append r (list (lane state x y))))))
    (subseq (concatenate-bit-vectors r)
            start
            end)))

(defun state-xor (state bit-vector)
  (assert (<= (length bit-vector) +keccak-width+))
  (let ((s (copy-state state))
        (x 0)
        (y 0)
        (chunks (bit-pad-right-and-chunk bit-vector +lane-size+)))
    (dolist (c chunks)
      (setf (lane s x y)
            (lane-xor (lane state x y)
                      c))
      (setf x (mod (1+ x) +row-size+))
      (if (= 0 (mod x +row-size+))
          (setf y (mod (1+ x) +column-size+))))
    s))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; keccak round operations

(defmacro with-return-state (s &rest body)
  `(let ((,(first s) (if (= ,(length s) 2)
                         (copy-state ,(second s))
                         (make-state))))
     (progn ,@body)
     ,(first s)))

(defun theta (a)
  (with-return-state (b)
    (let* ((c (make-sequence '(vector lane) +row-size+
                             :initial-element (make-lane)))
           (d (make-sequence '(vector lane) +row-size+
                             :initial-element (make-lane))))
      (dotimes (x +row-size+)
        (setf (aref c x)
              (lane a x 0))
        (loop for y from 1 below +column-size+
           do (setf (aref c x)
                    (lane-xor (aref c x)
                              (lane a x y)))))
      (dotimes (x +row-size+)
        (setf (aref d x)
              (lane-xor (aref c (mod (- x 1) +row-size+))
                        (lane-rot (aref c (mod (+ x 1) +row-size+))
                                  1)))
        (dotimes (y +column-size+)
          (setf (lane b x y)
                (lane-xor (lane a x y)
                          (aref d x))))))))

(defun rho (a)
  (with-return-state (b)
    (setf (lane b 0 0) (lane a 0 0))
    (let ((x 1) (y 0))
      (dotimes (q 24)
        (setf (lane b x y)
              (lane-rot (lane a x y)
                        (/ (* (+ q 1)
                              (+ q 2))
                           2)))
        (psetq x y
               y (+ (* 2 x)
                    (* 3 y)))))))

(defun k-pi (a)
  (with-return-state (b)
    (dotimes (x +row-size+)
      (dotimes (y +column-size+)
        (setf (lane b y (+ (* 2 x)
                           (* 3 y)))
              (lane a x y))))))

(defun chi (a)
  (with-return-state (b)
    (dotimes (x +row-size+)
      (dotimes (y +column-size+)
        (setf (lane b x y)
              (lane-xor (lane a x y)
                        (lane-and (lane-not (lane a (+ x 1) y))
                                  (lane a (+ x 2) y))))))))

(defun iota (r a)
  (with-return-state (b a)
    (setf (lane b 0 0)
          (lane-xor (lane b 0 0)
                    (aref +round-constants+ r)))))

(defun keccak-permute (a)
  (with-return-state (b a)
    (dotimes (r +round-quantity+)
      (setq b (iota r (chi (k-pi (rho (theta b)))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sponge

(defun keccak-pad (bit-vector bitrate)
  (let ((bv-tmp (concatenate 'simple-bit-vector bit-vector #*1)))
    (concatenate 'simple-bit-vector
                 (bit-pad-right bv-tmp (1- (* bitrate
                                              (1+ (floor (length bv-tmp)
                                                         bitrate)))))
                 #*1)))

(defun keccak-absorb (bit-vector bitrate)
  (assert (<= bitrate +keccak-width+))
  (with-return-state (s)
    (dolist (c (bit-chunk (keccak-pad bit-vector bitrate) bitrate))
      (setq s (keccak-permute (state-xor s c))))))

(defun keccak-squeeze (state bitrate output-bit-quantity)
  (assert (<= bitrate +keccak-width+))
  (multiple-value-bind (full-blocks remaining-bits)
      (floor output-bit-quantity bitrate)
    (concatenate-bit-vectors
     (mapcar (lambda (x)
               (setq state (keccak-permute state))
               (state-linearize state 0 x))
             (append (make-sequence 'list full-blocks
                                    :initial-element bitrate)
                     (if (zerop remaining-bits)
                         '()
                         (list remaining-bits)))))))

(defun keccak-sponge (input-bit-vector &optional
                                         (bitrate *default-bitrate*)
                                         (output-bits *default-output-bits*))
  (keccak-squeeze (keccak-absorb input-bit-vector bitrate)
                  bitrate
                  output-bits))

(defun keccak-hash-file (filepath)
  (write-to-string (bit-vector-to-integer (keccak-sponge (file-to-bit-vector filepath)
                                                         *default-bitrate*
                                                         *default-output-bits*))
                   :base 16))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; for use as an executable

(defun main ()
  (let ((args #+sbcl (cdr sb-ext:*posix-argv*)
              #+ccl (cdr ccl:*command-line-argument-list*)))
    (princ (keccak-hash-file (first args)))))

cl-keccak-tests.lisp:

(in-package "CL-KECCAK")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility functions for moving between integers and lanes
;; these are not used in cl-keccak proper. rather, they are
;; for testing and generating the round constants


(defun bit-truncate-right (bv n)
  (subseq bv 0 n))

(defun integer-to-lane (n)
  (labels ((bit-array-iter (n array)
             (if (zerop n)
                 array
                 (multiple-value-bind (q r)
                     (floor n 2)
                   (bit-array-iter q
                                   (append array (list r)))))))
    (bit-truncate-right (bit-pad-right (bit-array-iter n '())
                                       +lane-size+)
                        +lane-size+)))

(defun lane-to-integer (bv)
  (reduce #'(lambda (a b) (+ a (* 2 b)))
          bv
          :from-end t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; code used to generate the magic lanes.
;; this code is retained for user verification.
;; numbers used to generate the lanes can be found here:
;; https://keccak.team/keccak_specs_summary.html#roundConstants

;; (defparameter *magic-constants*
;;   (make-array '(24)
;;               :element-type 'lane
;;               :initial-contents
;;               (mapcar #'integer-to-lane
;;                       '(#x0000000000000001
;;                         #x0000000000008082
;;                         #x800000000000808a
;;                         #x8000000080008000
;;                         #x000000000000808b
;;                         #x0000000080000001
;;                         #x8000000080008081
;;                         #x8000000000008009
;;                         #x000000000000008a
;;                         #x0000000000000088
;;                         #x0000000080008009
;;                         #x000000008000000a
;;                         #x000000008000808b
;;                         #x800000000000008b
;;                         #x8000000000008089
;;                         #x8000000000008003
;;                         #x8000000000008002
;;                         #x8000000000000080
;;                         #x000000000000800a
;;                         #x800000008000000a
;;                         #x8000000080008081
;;                         #x8000000000008080
;;                         #x0000000080000001
;;                         #x8000000080008008))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; procedures for making states

(defun make-state-using-lane-generator (nullary-lane-generator)
  (with-return-state (a)
    (dotimes (x +row-size+)
      (dotimes (y +column-size+)
        (setf (lane a x y) (funcall nullary-lane-generator))))))

(defun make-ascending-state ()
  (make-state-using-lane-generator
   (let ((b -1))
     (lambda ()
       (integer-to-lane (incf b))))))

(defun make-randomized-state ()
  (make-state-using-lane-generator
   (lambda () (integer-to-lane (random (expt 2 +lane-size+))))))

(defun make-bit-ascending-state ()
  (make-state-using-lane-generator
   (let ((b 0))
     (lambda () (integer-to-lane (if (= b 0) (incf b) (setq b (expt 2 b))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; procedures for testing states

(defun diff-states (state1 state2)
  (let ((diff '()))
    (dotimes (x +row-size+)
      (dotimes (y +column-size+)
        (if (not (equal (lane state1 x y)
                        (lane state2 x y)))
            (setq diff (append diff (list (cons x y)))))))
    diff))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; printing the state

(defun print-state (a &optional (stream t))
  (let ((fmt-str (format nil "~~{~~~d,'0X~~^ ~~}"
                         (max 0 (/ +lane-size+ 4)))))
    (dotimes (y +column-size+)
      (format stream fmt-str (mapcar #'(lambda (x) (lane-to-integer (lane a x y)))
                                     '(0 1 2 3 4)))
      (format stream "~%"))))

(defun print-readable-state (a &optional (stream t))
  (let ((fmt-str (format nil "(~~{#x~~~d,'0X~~^ ~~})"
                         (max 0 (/ +lane-size+ 4)))))
    (format stream "#2A(")
    (dotimes (x +row-size+)
      (format stream fmt-str (mapcar #'(lambda (y) (lane-to-integer (lane a x y)))
                                     '(0 1 2 3 4)))
      (format stream
              (if (= x (1- +row-size+)) ")" "~%    ")))))

(defun read-printed-state (stream)
  (with-return-state (b)
    (let ((a (read stream)))
      (dotimes (x +row-size+)
        (dotimes (y +column-size+)
          (setf (lane b x y)
                (integer-to-lane (aref a x y))))))))

(defun print-keccak-permute (state stream)
  (format stream ";; Initial state:~%")
  (print-state state stream)
  (let ((maps `(("theta" . ,#'theta)
                ("rho" . ,#'rho)
                ("pi" . ,#'k-pi)
                ("chi" . ,#'chi))))
    (dotimes (r +round-quantity+)
      (let ((maps (append maps `(("iota" . ,#'(lambda (a) (iota r a)))))))
        (format stream "~%~%~%;; Round ~d~%~%" r)
        (dolist (m maps)
          (format stream "~%;; After ~a:~%" (car m))
          (print-state (setq state
                             (funcall (cdr m) state))
                       stream)))))
  (format stream "~%~%~%;; Final state:~%")
  (print-state state stream))

(defun test-permute-and-write (state output-file)
  (with-open-file (s output-file :direction :output :if-exists :supersede)
    (print-keccak-permute state s)))

Makefile:

LISP=sbcl

all: ${LISP}

sbcl:
    sbcl --no-sysinit --no-userinit --disable-debugger \
        --load package.lisp \
        --load bits.lisp \
        --load cl-keccak.lisp \
        --eval "(sb-ext:save-lisp-and-die #p\"cl-keccak\" :toplevel #'cl-keccak::main :executable t)"

ccl:
    ccl --no-init \
        --load package.lisp \
        --load bits.lisp \
        --load cl-keccak.lisp
        --eval "(ccl:save-application #P\"cl-keccak\" :toplevel-function #'cl-keccak::main :prepend-kernel t)"
  1. no trailing newline []
  2. I am not placing these as files or signing them on purpose. This weeks release is very likely broken []

4 Responses to “cl-keccak, Week 3”

  1. Diana Coman says:
    Did you check first the test vectors? As far as I recall the reference had me pulling my hair out with a similar trouble at first (matching transitions, not matching hashes) over the way bits are extracted from the sponge at the end - perhaps worth a look.
  2. esthlos says:
    Good call. The test vectors are not matching. I'll check the sponge.
  3. Diana Coman says:
    The first link to "last week's post" goes to phf's post on his blog!
  4. esthlos says:
    Thanks, and apologies to phf.

Leave a Reply (USE HTML! Space not preserved!)