sha1.lisp

(defpackage :sha1
  (:use :cl)
  (:shadow :block)
  (:export :init
           :update
           :digest
           :hexdigest))
(in-package :sha1)

(deftype u8 () '(unsigned-byte 8))
(deftype u32 () '(unsigned-byte 32))

(declaim (inline mod32+)
         (ftype (function (u32 u32) u32) mod32+))
(defun mod32+ (x y)
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (ldb (byte 32 0) (+ x y)))

(declaim (inline rol32)
         (ftype (function (u32 (unsigned-byte 5)) u32) rol32))
(defun rol32 (x n)
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (ldb (byte 32 0) (logior (ldb (byte 32 0) (ash x n)) (ash x (- n 32)))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (declaim (inline f1 f2 f3 f4)
           (ftype (function (u32 u32 u32) u32) f1 f2 f3 f4))
  (defun f1 (b c d)
    (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
    (logior (logand b c) (logandc1 b d)))

  (defun f2 (b c d)
    (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
    (logxor b c d))

  (defun f3 (b c d)
    (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
    (logior (logand b c) (logand b d) (logand c d)))

  (defun f4 (b c d)
    (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
    (logxor b c d))

  (defun f (i)
    (cond ((<= 0 i 19) 'f1)
          ((<= 20 i 39) 'f2)
          ((<= 40 i 59) 'f3)
          ((<= 60 i 79) 'f4)))

  (let ((k1 #x5A827999)
        (k2 #x6ED9EBA1)
        (k3 #x8F1BBCDC)
        (k4 #xCA62C1D6))
    (defparameter *k*
      (make-array 80 :element-type 'u32
                  :initial-contents
                  (concatenate 'list
                               (loop repeat 20 collect k1)
                               (loop repeat 20 collect k2)
                               (loop repeat 20 collect k3)
                               (loop repeat 20 collect k4)))))
  )  ;; eval-when

(defmacro step-b (w)
  (loop for i from 16 to 79
     collect `(setf (aref ,w ,i)
                    (rol32 (logxor (aref ,w ,(- i 3))
                                   (aref ,w ,(- i 8))
                                   (aref ,w ,(- i 14))
                                   (aref ,w ,(- i 16)))
                           1))
     into procedures
     finally (return `(progn ,@procedures))))

(defmacro step-d (a b c d e w)
  (loop for i from 0 to 79
     collect `(let ((temp (mod32+ (mod32+ (rol32 ,a 5)
                                          (,(f i) ,b ,c ,d))
                                  (mod32+ ,e
                                          (mod32+ (aref ,w ,i)
                                                  ,(aref *k* i))))))
                (setq ,e ,d
                      ,d ,c
                      ,c (rol32 ,b 30)
                      ,b ,a
                      ,a temp))
     into procedures
     finally (return `(progn ,@procedures))))

(deftype state-type () '(simple-array u32 (5)))
(deftype block-type () '(simple-array u8 (64)))
(deftype word-block-type () '(simple-array u32 (80)))
(deftype byte-length-type () '(unsigned-byte 59))

(defstruct (sha1-context (:conc-name ""))
  (state (make-array 5 :element-type 'u32) :type state-type)
  (byte-length 0 :type byte-length-type)
  (block (make-array 64 :element-type 'u8) :type block-type)
  (block-index 0 :type (integer 0 64))
  (word-block (make-array 80 :element-type 'u32) :type word-block-type)
  (computed nil :type (or null (simple-array u8 (20)))))

(defun init (&optional ctx)
  (declare ((or sha1-context null) ctx))
  (let* ((ctx (or ctx (make-sha1-context)))
         (state (state ctx)))
    (setf (aref state 0) #x67452301
          (aref state 1) #xEFCDAB89
          (aref state 2) #x98BADCFE
          (aref state 3) #x10325476
          (aref state 4) #xC3D2E1F0
          (byte-length ctx) 0
          (block-index ctx) 0
          (computed ctx) nil)
    ctx))

;; (array u8 64) -> (array u32 80)
(defun decode (u8-array u32-array)
  (declare ((simple-array u8 (64)) u8-array)
           ((simple-array u32 (80)) u32-array))
  (loop for i from 0
     for j from 0 below 64 by 4
     do (setf (aref u32-array i)
              (logior (ash (aref u8-array j)       24)
                      (ash (aref u8-array (+ j 1)) 16)
                      (ash (aref u8-array (+ j 2)) 8)
                      (aref u8-array (+ j 3))))))

(defun process-message-block (ctx)
  (declare (sha1-context ctx)
           (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (let ((h (the state-type (state ctx)))
        (m (the block-type (block ctx)))
        (w (the word-block-type (word-block ctx))))
    ;; a
    (decode m w)

    ;; b
    (step-b w)

    ;; c
    (let ((a (aref h 0))
          (b (aref h 1))
          (c (aref h 2))
          (d (aref h 3))
          (e (aref h 4)))

      ;; d
      (step-d a b c d e w)

      ;; e
      (setf (aref h 0) (mod32+ (aref h 0) a)
            (aref h 1) (mod32+ (aref h 1) b)
            (aref h 2) (mod32+ (aref h 2) c)
            (aref h 3) (mod32+ (aref h 3) d)
            (aref h 4) (mod32+ (aref h 4) e))))
  (setf (block-index ctx) 0))

(defun update (ctx input &key start end)
  (declare (sha1-context ctx)
           ((simple-array u8 (*)) input)
           (optimize (speed 3) (safety 0) (space 0) (debug 0)))

  (let* ((start (or start 0))
         (end (or end (- (length input) start))))
    (declare (fixnum start end))

    (with-slots (block-index block byte-length) ctx
      (declare ((integer 0 64) block-index)
               (block-type block)
               (byte-length-type byte-length))
      (loop for i from start below end
         do (progn
              (setf (aref block block-index) (aref input i))
              (incf block-index)
              (incf byte-length)
              (when (= block-index 64)
                (process-message-block ctx)))))
    ctx))

(defun encode (n out off)
  (declare (u32 n)
           ((simple-array u8 (*)) out)
           ((integer 0 *) off))
  (setf (aref out off)       (ldb (byte 8 24) n)
        (aref out (+ off 1)) (ldb (byte 8 16) n)
        (aref out (+ off 2)) (ldb (byte 8 8) n)
        (aref out (+ off 3)) (ldb (byte 8 0) n)))

(defun pad (ctx)
  (with-slots (state block block-index byte-length) ctx
    (flet ((pad1 ()
             (setf (aref block block-index) #x80)
             (incf block-index))
           (pad0 (end)
             (loop while (< block-index end)
                do (progn
                     (setf (aref block block-index) #x00)
                     (incf block-index)))))

      (if (>= block-index 56)
          (progn
            (pad1)
            (pad0 64)
            (process-message-block ctx)
            (pad0 56))
          (progn
            (pad1)
            (pad0 56)))

      (let ((l (ldb (byte 64 0) (* 8 byte-length))))
        (encode (ldb (byte 32 32) l) block 56)
        (encode (ldb (byte 32 0) l) block 60))

      (process-message-block ctx))))

(defun digest (ctx)
  (declare (sha1-context ctx))
  (or (computed ctx)
      (with-slots (state) ctx
        (pad ctx)
        (setf (computed ctx)
              (let ((digest (make-array 20 :element-type 'u8)))
                (encode (aref state 0) digest 0)
                (encode (aref state 1) digest 4)
                (encode (aref state 2) digest 8)
                (encode (aref state 3) digest 12)
                (encode (aref state 4) digest 16)
                digest)))))

(let ((digits "0123456789abcdef"))
  (defun hexdigest (ctx)
    (declare (sha1-context ctx))
    (let* ((bytes (digest ctx))
           (hex (make-string 40)))
      (loop for i from 0 below 20
         for j from 0 by 2
         do (let ((b (aref bytes i)))
              (setf (aref hex j)      (schar digits (logand (ash b -4) #xf))
                    (aref hex (1+ j)) (schar digits (logand b #xf)))))
      hex)))

;;;
;;; test
;;;
(defmacro run ((testcase) &body clauses)
  (loop for (arg expected repeat-count) in clauses
     collect `(,testcase ,(sb-ext:string-to-octets arg)
                         ,expected
                         ,repeat-count)
     into procedures
     finally (return `(progn ,@procedures))))

(defun run-test ()
  (let ((ctx (init)))
    (flet ((mytest (arg expected repeat-count)
             (init ctx)
             (dotimes (i repeat-count)
               (update ctx arg))
             (let ((actual (hexdigest ctx)))
               (unless (string-equal actual expected)
                 (warn "expected ~S but was ~S" expected actual)))))
      (run (mytest)
        ;; rfc3174 tests
        ("abc" "A9993E364706816ABA3E25717850C26C9CD0D89D" 1)
        ("abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" "84983E441C3BD26EBAAE4AA1F95129E5E54670F1" 1)
        ("a" "34AA973CD4C4DAA4F61EEB2BDBAD27316534016F" 1000000)
        ("0123456701234567012345670123456701234567012345670123456701234567" "DEA356A2CDDD90C7A7ECEDC5EBB563934F460452" 10)))))