Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
1435 lines (1285 sloc) 46 KB
;;;============================================================================
;;; File: "digest.scm", Time-stamp: <2009-02-19 23:38:26 feeley>
;;; Copyright (c) 2005-2009 by Marc Feeley, All Rights Reserved.
;;;============================================================================
;;; Contains procedures to compute message digests.
(##namespace ("digest#"))
(##include "~~lib/gambit#.scm")
(declare
(standard-bindings)
(extended-bindings)
(not inline)
(not safe))
(define-macro (fx+ . args) `(##fx+ ,@args))
(define-macro (fx- . args) `(##fx- ,@args))
(define-macro (fx* . args) `(##fx* ,@args))
(define-macro (fxquotient . args) `(##fxquotient ,@args))
(define-macro (fxmin . args) `(##fxmin ,@args))
(define-macro (fx= . args) `(##fx= ,@args))
(define-macro (fx< . args) `(##fx< ,@args))
(define-macro (fx> . args) `(##fx> ,@args))
(define-macro (fx<= . args) `(##fx<= ,@args))
(define-macro (fx>= . args) `(##fx>= ,@args))
(define-macro (fxnot . args) `(##fxnot ,@args))
(define-macro (fxand . args) `(##fxand ,@args))
(define-macro (fxior . args) `(##fxior ,@args))
(define-macro (fxxor . args) `(##fxxor ,@args))
(define-macro (fxarithmetic-shift-right . args) `(##fxarithmetic-shift-right ,@args))
(define-macro (fxarithmetic-shift-left . args) `(##fxarithmetic-shift-left ,@args))
(define-macro (make-vector . args) `(##make-vector ,@args))
(define-macro (make-u8vector . args) `(##make-u8vector ,@args))
(define-macro (u8vector . args) `(##u8vector ,@args))
(define-macro (u8vector-length . args) `(##u8vector-length ,@args))
(define-macro (u8vector-ref . args) `(##u8vector-ref ,@args))
(define-macro (u8vector-set! . args) `(##u8vector-set! ,@args))
(define-macro (read-subu8vector . args) `(##read-subu8vector ,@args))
(define-macro (string-append . args) `(##string-append ,@args))
(define-macro (make-string . args) `(##make-string ,@args))
(define-macro (open-input-file . args) `(##open-input-file ,@args))
(define-macro (close-input-port . args) `(##close-input-port ,@args))
(define-macro (number->string . args) `(##number->string ,@args))
;;;----------------------------------------------------------------------------
(define-type digest
id: digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
end
update
state)
;;;----------------------------------------------------------------------------
;; CRC32 digest.
(define-type crc32-digest
id: crc32-digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
hi16
lo16)
(define crc32-table '#(
#x0000 #x0000 #x7707 #x3096 #xEE0E #x612C #x9909 #x51BA
#x076D #xC419 #x706A #xF48F #xE963 #xA535 #x9E64 #x95A3
#x0EDB #x8832 #x79DC #xB8A4 #xE0D5 #xE91E #x97D2 #xD988
#x09B6 #x4C2B #x7EB1 #x7CBD #xE7B8 #x2D07 #x90BF #x1D91
#x1DB7 #x1064 #x6AB0 #x20F2 #xF3B9 #x7148 #x84BE #x41DE
#x1ADA #xD47D #x6DDD #xE4EB #xF4D4 #xB551 #x83D3 #x85C7
#x136C #x9856 #x646B #xA8C0 #xFD62 #xF97A #x8A65 #xC9EC
#x1401 #x5C4F #x6306 #x6CD9 #xFA0F #x3D63 #x8D08 #x0DF5
#x3B6E #x20C8 #x4C69 #x105E #xD560 #x41E4 #xA267 #x7172
#x3C03 #xE4D1 #x4B04 #xD447 #xD20D #x85FD #xA50A #xB56B
#x35B5 #xA8FA #x42B2 #x986C #xDBBB #xC9D6 #xACBC #xF940
#x32D8 #x6CE3 #x45DF #x5C75 #xDCD6 #x0DCF #xABD1 #x3D59
#x26D9 #x30AC #x51DE #x003A #xC8D7 #x5180 #xBFD0 #x6116
#x21B4 #xF4B5 #x56B3 #xC423 #xCFBA #x9599 #xB8BD #xA50F
#x2802 #xB89E #x5F05 #x8808 #xC60C #xD9B2 #xB10B #xE924
#x2F6F #x7C87 #x5868 #x4C11 #xC161 #x1DAB #xB666 #x2D3D
#x76DC #x4190 #x01DB #x7106 #x98D2 #x20BC #xEFD5 #x102A
#x71B1 #x8589 #x06B6 #xB51F #x9FBF #xE4A5 #xE8B8 #xD433
#x7807 #xC9A2 #x0F00 #xF934 #x9609 #xA88E #xE10E #x9818
#x7F6A #x0DBB #x086D #x3D2D #x9164 #x6C97 #xE663 #x5C01
#x6B6B #x51F4 #x1C6C #x6162 #x8565 #x30D8 #xF262 #x004E
#x6C06 #x95ED #x1B01 #xA57B #x8208 #xF4C1 #xF50F #xC457
#x65B0 #xD9C6 #x12B7 #xE950 #x8BBE #xB8EA #xFCB9 #x887C
#x62DD #x1DDF #x15DA #x2D49 #x8CD3 #x7CF3 #xFBD4 #x4C65
#x4DB2 #x6158 #x3AB5 #x51CE #xA3BC #x0074 #xD4BB #x30E2
#x4ADF #xA541 #x3DD8 #x95D7 #xA4D1 #xC46D #xD3D6 #xF4FB
#x4369 #xE96A #x346E #xD9FC #xAD67 #x8846 #xDA60 #xB8D0
#x4404 #x2D73 #x3303 #x1DE5 #xAA0A #x4C5F #xDD0D #x7CC9
#x5005 #x713C #x2702 #x41AA #xBE0B #x1010 #xC90C #x2086
#x5768 #xB525 #x206F #x85B3 #xB966 #xD409 #xCE61 #xE49F
#x5EDE #xF90E #x29D9 #xC998 #xB0D0 #x9822 #xC7D7 #xA8B4
#x59B3 #x3D17 #x2EB4 #x0D81 #xB7BD #x5C3B #xC0BA #x6CAD
#xEDB8 #x8320 #x9ABF #xB3B6 #x03B6 #xE20C #x74B1 #xD29A
#xEAD5 #x4739 #x9DD2 #x77AF #x04DB #x2615 #x73DC #x1683
#xE363 #x0B12 #x9464 #x3B84 #x0D6D #x6A3E #x7A6A #x5AA8
#xE40E #xCF0B #x9309 #xFF9D #x0A00 #xAE27 #x7D07 #x9EB1
#xF00F #x9344 #x8708 #xA3D2 #x1E01 #xF268 #x6906 #xC2FE
#xF762 #x575D #x8065 #x67CB #x196C #x3671 #x6E6B #x06E7
#xFED4 #x1B76 #x89D3 #x2BE0 #x10DA #x7A5A #x67DD #x4ACC
#xF9B9 #xDF6F #x8EBE #xEFF9 #x17B7 #xBE43 #x60B0 #x8ED5
#xD6D6 #xA3E8 #xA1D1 #x937E #x38D8 #xC2C4 #x4FDF #xF252
#xD1BB #x67F1 #xA6BC #x5767 #x3FB5 #x06DD #x48B2 #x364B
#xD80D #x2BDA #xAF0A #x1B4C #x3603 #x4AF6 #x4104 #x7A60
#xDF60 #xEFC3 #xA867 #xDF55 #x316E #x8EEF #x4669 #xBE79
#xCB61 #xB38C #xBC66 #x831A #x256F #xD2A0 #x5268 #xE236
#xCC0C #x7795 #xBB0B #x4703 #x2202 #x16B9 #x5505 #x262F
#xC5BA #x3BBE #xB2BD #x0B28 #x2BB4 #x5A92 #x5CB3 #x6A04
#xC2D7 #xFFA7 #xB5D0 #xCF31 #x2CD9 #x9E8B #x5BDE #xAE1D
#x9B64 #xC2B0 #xEC63 #xF226 #x756A #xA39C #x026D #x930A
#x9C09 #x06A9 #xEB0E #x363F #x7207 #x6785 #x0500 #x5713
#x95BF #x4A82 #xE2B8 #x7A14 #x7BB1 #x2BAE #x0CB6 #x1B38
#x92D2 #x8E9B #xE5D5 #xBE0D #x7CDC #xEFB7 #x0BDB #xDF21
#x86D3 #xD2D4 #xF1D4 #xE242 #x68DD #xB3F8 #x1FDA #x836E
#x81BE #x16CD #xF6B9 #x265B #x6FB0 #x77E1 #x18B7 #x4777
#x8808 #x5AE6 #xFF0F #x6A70 #x6606 #x3BCA #x1101 #x0B5C
#x8F65 #x9EFF #xF862 #xAE69 #x616B #xFFD3 #x166C #xCF45
#xA00A #xE278 #xD70D #xD2EE #x4E04 #x8354 #x3903 #xB3C2
#xA767 #x2661 #xD060 #x16F7 #x4969 #x474D #x3E6E #x77DB
#xAED1 #x6A4A #xD9D6 #x5ADC #x40DF #x0B66 #x37D8 #x3BF0
#xA9BC #xAE53 #xDEBB #x9EC5 #x47B2 #xCF7F #x30B5 #xFFE9
#xBDBD #xF21C #xCABA #xC28A #x53B3 #x9330 #x24B4 #xA3A6
#xBAD0 #x3605 #xCDD7 #x0693 #x54DE #x5729 #x23D9 #x67BF
#xB366 #x7A2E #xC461 #x4AB8 #x5D68 #x1B02 #x2A6F #x2B94
#xB40B #xBE37 #xC30C #x8EA1 #x5A05 #xDF1B #x2D02 #xEF8D
))
(define (digest-update-crc32 digest u8vect start end)
(let ((state (digest-state digest)))
(let ((hi16 (crc32-digest-hi16 state))
(lo16 (crc32-digest-lo16 state)))
(let loop ((i start)
(hi hi16)
(lo lo16))
(if (fx< i end)
(let* ((x (u8vector-ref u8vect i))
(j (fx* 2 (fxand (fxxor lo x) #xff)))
(crc-hi (vector-ref crc32-table j))
(crc-lo (vector-ref crc32-table (fx+ j 1))))
(loop (fx+ i 1)
(fxxor
crc-hi
(fxarithmetic-shift-right hi 8))
(fxxor
crc-lo
(fx+ (fxarithmetic-shift-left (fxand hi #xff) 8)
(fxarithmetic-shift-right lo 8)))))
(begin
(crc32-digest-hi16-set! state hi)
(crc32-digest-lo16-set! state lo)))))))
(define (end-crc32 digest result-type)
(define (hex16 n) ;; assumes n is a fixnum
(let* ((s (number->string n 16))
(len (string-length s)))
(if (fx= len 4)
s
(string-append (make-string (fx- 4 len) #\0) s))))
(let ((state (digest-state digest)))
(let ((hi16 (fxxor (crc32-digest-hi16 state) #xffff))
(lo16 (fxxor (crc32-digest-lo16 state) #xffff)))
(case result-type
((hex)
(string-append (hex16 hi16) (hex16 lo16)))
((u8vector)
(u8vector (fxand #xff lo16)
(fxarithmetic-shift-right lo16 8)
(fxand #xff hi16)
(fxarithmetic-shift-right hi16 8)))
(else
(error "unsupported digest result-type" result-type))))))
(define (open-digest-crc32)
(make-digest
end-crc32
digest-update-crc32
(make-crc32-digest #xffff #xffff)))
;; Useful for debugging:
#;
(begin
(namespace ("" arithmetic-shift bitwise-and bitwise-xor))
(define crc32-poly #xEDB88320)
(define crc32-table-computed
(let ((v (make-vector 512)))
(let loop1 ((n 0))
(if (fx< n 256)
(let loop2 ((k 0) (c n))
(if (fx< k 8)
(loop2 (fx+ k 1)
(if (odd? c)
(bitwise-xor crc32-poly
(arithmetic-shift c -1))
(arithmetic-shift c -1)))
(begin
(vector-set! v (fx* n 2) (arithmetic-shift c -16))
(vector-set! v (fx+ 1 (fx* n 2)) (bitwise-and c #xffff))
(loop1 (fx+ n 1)))))))
v))
(if (not (equal? crc32-table-computed crc32-table))
(error "crc32-table is incorrect"))
#;
(define (digest-update-crc32 digest u8vect start end)
(let ((state (digest-state digest)))
(let ((hi16 (crc32-digest-hi16 state))
(lo16 (crc32-digest-lo16 state)))
(let loop ((i start)
(crc (fx+ (arithmetic-shift hi16 16)
lo16)))
(if (fx< i end)
(let* ((x (u8vector-ref u8vect i))
(crc (bitwise-xor crc x)))
(let loop2 ((j 8) (crc crc))
(if (fx> j 0)
(loop2 (fx- j 1)
(if (odd? crc)
(bitwise-xor crc32-poly
(arithmetic-shift crc -1))
(arithmetic-shift crc -1)))
(loop (fx+ i 1)
crc))))
(begin
(crc32-digest-hi16-set!
state
(arithmetic-shift crc -16))
(crc32-digest-lo16-set!
state
(bitwise-and crc #xffff))))))))
)
;;;----------------------------------------------------------------------------
(define (hash-block->hex-string hb big-endian? width)
(define (hex x)
(string-ref "0123456789abcdef" (fxand x 15)))
(let* ((len (fxquotient width 16))
(n (fx* len 4))
(str (make-string n)))
(let loop ((i (fx- len 1)) (j (fx- n 4)))
(if (fx< i 0)
str
(let ((x (vector-ref hb (if big-endian? (fxxor i 1) i)))
(j1 (if big-endian? (fx+ j 0) (fx+ j 2)))
(j2 (if big-endian? (fx+ j 2) (fx+ j 0))))
(string-set!
str
(fx+ j1 0)
(hex (fxarithmetic-shift-right x 12)))
(string-set!
str
(fx+ j1 1)
(hex (fxarithmetic-shift-right x 8)))
(string-set!
str
(fx+ j2 0)
(hex (fxarithmetic-shift-right x 4)))
(string-set!
str
(fx+ j2 1)
(hex (fxarithmetic-shift-right x 0)))
(loop (fx- i 1) (fx- j 4)))))))
(define (hash-block->u8vector hb big-endian? width)
(let* ((len (fxquotient width 16))
(n (fx* len 2))
(u8vect (make-u8vector n 0)))
(let loop ((i (fx- len 1)) (j (fx- n 2)))
(if (fx< i 0)
u8vect
(let ((x (vector-ref hb (if big-endian? (fxxor i 1) i)))
(j1 (if big-endian? (fx+ j 0) (fx+ j 1)))
(j2 (if big-endian? (fx+ j 1) (fx+ j 0))))
(u8vector-set! u8vect j1 (fxarithmetic-shift-right x 8))
(u8vector-set! u8vect j2 (fxand #xff x))
(loop (fx- i 1) (fx- j 2)))))))
(define-macro (LO var)
(string->symbol
(string-append (symbol->string var) "-" (symbol->string 'L))))
(define-macro (HI var)
(string->symbol
(string-append (symbol->string var) "-" (symbol->string 'H))))
(define-macro (wlet var lo hi body)
`(let ((,(string->symbol
(string-append (symbol->string var) "-" (symbol->string 'L)))
,lo)
(,(string->symbol
(string-append (symbol->string var) "-" (symbol->string 'H)))
,hi))
,body))
(define-macro (cast-u16 x)
`(fxand #xffff ,x))
(define-macro (shift-left-u16 n shift)
`(fxarithmetic-shift-left
(fxand ,n ,(fx- (expt 2 (fx- 16 shift)) 1))
,shift))
(define-macro (wshr dst w r body)
(if (fx< r 16)
`(wlet ,dst
(fxior
(fxarithmetic-shift-right (LO ,w) ,r)
(shift-left-u16 (HI ,w) ,(fx- 16 r)))
(fxarithmetic-shift-right (HI ,w) ,r)
,body)
`(wlet ,dst
(fxarithmetic-shift-right (HI ,w) ,(fx- r 16))
0
,body)))
(define-macro (wrot dst w r body)
(if (fx< r 16)
`(wlet ,dst
(fxior
(shift-left-u16 (LO ,w) ,r)
(fxarithmetic-shift-right (HI ,w) ,(fx- 16 r)))
(fxior
(shift-left-u16 (HI ,w) ,r)
(fxarithmetic-shift-right (LO ,w) ,(fx- 16 r)))
,body)
`(wlet ,dst
(fxior
(shift-left-u16 (HI ,w) ,(fx- r 16))
(fxarithmetic-shift-right (LO ,w) ,(fx- 32 r)))
(fxior
(shift-left-u16 (LO ,w) ,(fx- r 16))
(fxarithmetic-shift-right (HI ,w) ,(fx- 32 r)))
,body)))
(define-macro (wadd dst a b body)
`(wlet R
(fx+ (LO ,a) (LO ,b))
(fx+ (HI ,a) (HI ,b))
(wlet ,dst
(cast-u16 (LO R))
(cast-u16
(fx+ (HI R)
(fxarithmetic-shift-right (LO R) 16)))
,body)))
(define-macro (wxor dst a b body)
`(wlet ,dst
(fxxor (LO ,a) (LO ,b))
(fxxor (HI ,a) (HI ,b))
,body))
(define-macro (wior dst a b body)
`(wlet ,dst
(fxior (LO ,a) (LO ,b))
(fxior (HI ,a) (HI ,b))
,body))
(define-macro (wand dst a b body)
`(wlet ,dst
(fxand (LO ,a) (LO ,b))
(fxand (HI ,a) (HI ,b))
,body))
(define-macro (wnot dst a body)
`(wlet ,dst
(fxnot (LO ,a))
(fxnot (HI ,a))
,body))
(define-macro (wref dst v i body)
(if (number? i)
`(wlet ,dst
(vector-ref ,v ,(fx+ (fx* 2 i) 0))
(vector-ref ,v ,(fx+ (fx* 2 i) 1))
,body)
`(wlet ,dst
(vector-ref ,v (fx+ (fx* 2 ,i) 0))
(vector-ref ,v (fx+ (fx* 2 ,i) 1))
,body)))
(define-macro (wset v i x)
(if (number? i)
`(begin
(vector-set! ,v ,(fx+ (fx* 2 i) 0) (LO ,x))
(vector-set! ,v ,(fx+ (fx* 2 i) 1) (HI ,x)))
`(begin
(vector-set! ,v (fx+ (fx* 2 ,i) 0) (LO ,x))
(vector-set! ,v (fx+ (fx* 2 ,i) 1) (HI ,x)))))
;;;----------------------------------------------------------------------------
(define-type block-digest
id: block-digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
hash-update
hash
block
block-pos
bit-pos
big-endian?
width)
(define (convert-hash-block digest result-type)
(let* ((bd (digest-state digest))
(hash (block-digest-hash bd)))
(case result-type
((hex)
(hash-block->hex-string
hash
(block-digest-big-endian? bd)
(block-digest-width bd)))
((u8vector)
(hash-block->u8vector
hash
(block-digest-big-endian? bd)
(block-digest-width bd)))
(else
(error "unsupported digest result-type" result-type)))))
(define (process-last-block digest)
(let* ((bd
(digest-state digest))
(block-pos
(block-digest-block-pos bd))
(bit-pos
(block-digest-bit-pos bd))
(buf
(make-u8vector 8 0)))
(digest-update-u8 digest #x80) ;; add byte-aligned 1 bit
(let ((zero-padding-bytes
(fxquotient
(fxand 511 (fx- 448 (block-digest-bit-pos bd)))
8)))
(let loop1 ((n zero-padding-bytes))
(if (fx< 0 n)
(let ((m (fxmin 8 n)))
(digest-update-subu8vector
digest
buf
0
m) ;; add 0 bits
(loop1 (fx- n m))))))
(u8vector-set!
buf
0
(fxand #xff bit-pos))
(u8vector-set!
buf
1
(fxior
(fxarithmetic-shift-left (fxand #x7f block-pos) 1)
(fxand #x01 (fxarithmetic-shift-right bit-pos 8))))
(let loop2 ((i 2)
(n (fxarithmetic-shift-right block-pos 7)))
(if (fx> n 0)
(begin
(u8vector-set! buf i (fxand #xff n))
(loop2 (fx+ i 1)
(fxarithmetic-shift-right n 8)))))
(if (block-digest-big-endian? bd)
(let loop3 ((i 3))
(if (fx>= i 0)
(let ((t (u8vector-ref buf i)))
(u8vector-set! buf i (u8vector-ref buf (fx- 7 i)))
(u8vector-set! buf (fx- 7 i) t)
(loop3 (fx- i 1))))))
(digest-update-subu8vector digest buf 0 8)));; add message length (in bits)
(define (end-block-digest digest result-type)
(process-last-block digest)
(convert-hash-block digest result-type))
(define (digest-update-block-digest digest u8vect start end)
(let* ((bd (digest-state digest))
(block (block-digest-block bd)))
(define (aligned8 i bit-pos)
;; bit-pos is a multiple of 8
(if (fx< i end)
(let ((j (fxarithmetic-shift-right bit-pos 4)))
(if (fx= 0 (fxand bit-pos 15))
(begin
(if (block-digest-big-endian? bd)
(let ((j (fxxor j 1)))
(vector-set!
block
j
(fxarithmetic-shift-left
(u8vector-ref u8vect i)
8)))
(vector-set!
block
j
(u8vector-ref u8vect i)))
(let ((new-bit-pos (fx+ bit-pos 8)))
(aligned8 (fx+ i 1) new-bit-pos)))
(begin
(if (block-digest-big-endian? bd)
(let ((j (fxxor j 1)))
(vector-set!
block
j
(fx+ (vector-ref block j)
(u8vector-ref u8vect i))))
(vector-set!
block
j
(fx+ (vector-ref block j)
(fxarithmetic-shift-left
(u8vector-ref u8vect i)
8))))
(let ((new-bit-pos (fx+ bit-pos 8)))
(if (fx= 512 new-bit-pos)
(begin
((block-digest-hash-update bd) digest)
(block-digest-block-pos-set!
bd
(fx+ (block-digest-block-pos bd) 1))
(aligned16 (fx+ i 1) 0))
(aligned16 (fx+ i 1) new-bit-pos))))))
(block-digest-bit-pos-set! bd bit-pos)))
(define (aligned16 i bit-pos)
;; bit-pos is a multiple of 16
(if (fx< (fx+ i 1) end)
(let ((j (fxarithmetic-shift-right bit-pos 4)))
(if (block-digest-big-endian? bd)
(let ((j (fxxor j 1)))
(vector-set!
block
j
(fx+
(fxarithmetic-shift-left
(u8vector-ref u8vect i)
8)
(u8vector-ref u8vect (fx+ i 1)))))
(vector-set!
block
j
(fx+
(fxarithmetic-shift-left
(u8vector-ref u8vect (fx+ i 1))
8)
(u8vector-ref u8vect i))))
(let ((new-bit-pos (fx+ bit-pos 16)))
(if (fx= 512 new-bit-pos)
(begin
((block-digest-hash-update bd) digest)
(block-digest-block-pos-set!
bd
(fx+ (block-digest-block-pos bd) 1))
(aligned16 (fx+ i 2) 0))
(aligned16 (fx+ i 2) new-bit-pos))))
(aligned8 i bit-pos)))
(let ((bit-pos (block-digest-bit-pos bd)))
(cond ((fx= 0 (fxand bit-pos 15)) ;; 16 bit boundary?
(aligned16 start bit-pos))
(else
;; (fx= 0 (fxand bit-pos 7)) ;; 8 bit boundary?
(aligned8 start bit-pos))))))
;;;----------------------------------------------------------------------------
;; MD5 digest.
(define (hash-block-init-md5)
(vector #x2301 #x6745
#xab89 #xefcd
#xdcfe #x98ba
#x5476 #x1032))
(define-macro (wstp dst w f i n-hi16 n-lo16 r body)
`(wlet T1
,(cons (car f) (map (lambda (v) `(LO ,v)) (cdr f)))
,(cons (car f) (map (lambda (v) `(HI ,v)) (cdr f)))
(wadd T2 ,dst T1
(wref T3 block ,i
(wadd T4 T2 T3
(wlet T5
,n-lo16
,n-hi16
(wadd T6 T4 T5
(wrot T7 T6 ,r
(wadd ,dst ,w T7
,body)))))))))
(define-macro (fn-F x y z)
`(fxior
(fxand ,x ,y)
(fxand (fxnot ,x) ,z)))
(define-macro (fn-G x y z)
`(fxior
(fxand ,x ,z)
(fxand ,y (fxnot ,z))))
(define-macro (fn-H x y z)
`(fxxor ,x (fxxor ,y ,z)))
(define-macro (fn-I x y z)
`(cast-u16
(fxxor
,y
(fxior
,x
(fxnot ,z)))))
(define (digest-update-md5 digest)
(let* ((bd (digest-state digest))
(hash (block-digest-hash bd))
(block (block-digest-block bd)))
(define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-F B C D) 0 #xD76A #xA478 7
(wstp D A (fn-F A B C) 1 #xE8C7 #xB756 12
(wstp C D (fn-F D A B) 2 #x2420 #x70DB 17
(wstp B C (fn-F C D A) 3 #xC1BD #xCEEE 22
(wstp A B (fn-F B C D) 4 #xF57C #x0FAF 7
(wstp D A (fn-F A B C) 5 #x4787 #xC62A 12
(wstp C D (fn-F D A B) 6 #xA830 #x4613 17
(wstp B C (fn-F C D A) 7 #xFD46 #x9501 22
(stage2 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-F B C D) 8 #x6980 #x98D8 7
(wstp D A (fn-F A B C) 9 #x8B44 #xF7AF 12
(wstp C D (fn-F D A B) 10 #xFFFF #x5BB1 17
(wstp B C (fn-F C D A) 11 #x895C #xD7BE 22
(wstp A B (fn-F B C D) 12 #x6B90 #x1122 7
(wstp D A (fn-F A B C) 13 #xFD98 #x7193 12
(wstp C D (fn-F D A B) 14 #xA679 #x438E 17
(wstp B C (fn-F C D A) 15 #x49B4 #x0821 22
(stage3 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-G B C D) 1 #xF61E #x2562 5
(wstp D A (fn-G A B C) 6 #xC040 #xB340 9
(wstp C D (fn-G D A B) 11 #x265E #x5A51 14
(wstp B C (fn-G C D A) 0 #xE9B6 #xC7AA 20
(wstp A B (fn-G B C D) 5 #xD62F #x105D 5
(wstp D A (fn-G A B C) 10 #x0244 #x1453 9
(wstp C D (fn-G D A B) 15 #xD8A1 #xE681 14
(wstp B C (fn-G C D A) 4 #xE7D3 #xFBC8 20
(stage4 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-G B C D) 9 #x21E1 #xCDE6 5
(wstp D A (fn-G A B C) 14 #xC337 #x07D6 9
(wstp C D (fn-G D A B) 3 #xF4D5 #x0D87 14
(wstp B C (fn-G C D A) 8 #x455A #x14ED 20
(wstp A B (fn-G B C D) 13 #xA9E3 #xE905 5
(wstp D A (fn-G A B C) 2 #xFCEF #xA3F8 9
(wstp C D (fn-G D A B) 7 #x676F #x02D9 14
(wstp B C (fn-G C D A) 12 #x8D2A #x4C8A 20
(stage5 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-H B C D) 5 #xFFFA #x3942 4
(wstp D A (fn-H A B C) 8 #x8771 #xF681 11
(wstp C D (fn-H D A B) 11 #x6D9D #x6122 16
(wstp B C (fn-H C D A) 14 #xFDE5 #x380C 23
(wstp A B (fn-H B C D) 1 #xA4BE #xEA44 4
(wstp D A (fn-H A B C) 4 #x4BDE #xCFA9 11
(wstp C D (fn-H D A B) 7 #xF6BB #x4B60 16
(wstp B C (fn-H C D A) 10 #xBEBF #xBC70 23
(stage6 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-H B C D) 13 #x289B #x7EC6 4
(wstp D A (fn-H A B C) 0 #xEAA1 #x27FA 11
(wstp C D (fn-H D A B) 3 #xD4EF #x3085 16
(wstp B C (fn-H C D A) 6 #x0488 #x1D05 23
(wstp A B (fn-H B C D) 9 #xD9D4 #xD039 4
(wstp D A (fn-H A B C) 12 #xE6DB #x99E5 11
(wstp C D (fn-H D A B) 15 #x1FA2 #x7CF8 16
(wstp B C (fn-H C D A) 2 #xC4AC #x5665 23
(stage7 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-I B C D) 0 #xF429 #x2244 6
(wstp D A (fn-I A B C) 7 #x432A #xFF97 10
(wstp C D (fn-I D A B) 14 #xAB94 #x23A7 15
(wstp B C (fn-I C D A) 5 #xFC93 #xA039 21
(wstp A B (fn-I B C D) 12 #x655B #x59C3 6
(wstp D A (fn-I A B C) 3 #x8F0C #xCC92 10
(wstp C D (fn-I D A B) 10 #xFFEF #xF47D 15
(wstp B C (fn-I C D A) 1 #x8584 #x5DD1 21
(stage8 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H)
(wstp A B (fn-I B C D) 8 #x6FA8 #x7E4F 6
(wstp D A (fn-I A B C) 15 #xFE2C #xE6E0 10
(wstp C D (fn-I D A B) 6 #xA301 #x4314 15
(wstp B C (fn-I C D A) 13 #x4E08 #x11A1 21
(wstp A B (fn-I B C D) 4 #xF753 #x7E82 6
(wstp D A (fn-I A B C) 11 #xBD3A #xF235 10
(wstp C D (fn-I D A B) 2 #x2AD7 #xD2BB 15
(wstp B C (fn-I C D A) 9 #xEB86 #xD391 21
(stage9 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
(define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H)
(wref AA hash 0 (wadd A AA A (wset hash 0 A)))
(wref BB hash 1 (wadd B BB B (wset hash 1 B)))
(wref CC hash 2 (wadd C CC C (wset hash 2 C)))
(wref DD hash 3 (wadd D DD D (wset hash 3 D))))
(wref A hash 0
(wref B hash 1
(wref C hash 2
(wref D hash 3
(stage1 A-L A-H B-L B-H C-L C-H D-L D-H)))))))
(define (open-digest-md5)
(make-digest
end-block-digest
digest-update-block-digest
(make-block-digest
digest-update-md5
(hash-block-init-md5)
(make-vector 32 0)
0
0
#f
128)))
;;;----------------------------------------------------------------------------
;; SHA-1 digest.
(define (hash-block-init-sha-1)
(vector #x2301 #x6745
#xab89 #xefcd
#xdcfe #x98ba
#x5476 #x1032
#xe1f0 #xc3d2))
(define (digest-update-sha-1 digest)
(let* ((bd (digest-state digest))
(hash (block-digest-hash bd))
(block (block-digest-block bd)))
(wref OLDA hash 0
(wref OLDB hash 1
(wref OLDC hash 2
(wref OLDD hash 3
(wref OLDE hash 4
(let loop ((j 0)
(A-L OLDA-L) (A-H OLDA-H)
(B-L OLDB-L) (B-H OLDB-H)
(C-L OLDC-L) (C-H OLDC-H)
(D-L OLDD-L) (D-H OLDD-H)
(E-L OLDE-L) (E-H OLDE-H))
(define (stage1)
(if (fx< j 16)
(wref T1 block j
(stage2 T1-L T1-H))
(wref T1 block (fx- j 3)
(wref T2 block (fx- j 8)
(wxor T3 T1 T2
(wref T4 block (fx- j 14)
(wxor T5 T3 T4
(wref T6 block (fx- j 16)
(wxor T7 T5 T6
(wrot X T7 1
(begin
(wset block j X)
(stage2 X-L X-H))))))))))))
(define (stage2 X-L X-H)
(cond ((fx< j 20)
(wand T1 B C
(wnot T2 B
(wand T3 D T2
(wior T4 T1 T3
(wlet T5 #x7999 #x5a82
(wadd T6 T4 T5
(stage3 X-L X-H T6-L T6-H))))))))
((fx< j 40)
(wxor T1 B C
(wxor T2 D T1
(wlet T3 #xeba1 #x6ed9
(wadd T4 T2 T3
(stage3 X-L X-H T4-L T4-H))))))
((fx< j 60)
(wand T1 B C
(wand T2 B D
(wior T3 T1 T2
(wand T4 C D
(wior T5 T3 T4
(wlet T6 #xbcdc #x8f1b
(wadd T7 T5 T6
(stage3 X-L X-H T7-L T7-H)))))))))
(else
(wxor T1 B C
(wxor T2 D T1
(wlet T3 #xc1d6 #xca62
(wadd T4 T2 T3
(stage3 X-L X-H T4-L T4-H))))))))
(define (stage3 X-L X-H Y-L Y-H)
(wrot T1 A 5
(wadd T2 E T1
(wadd T3 X T2
(wadd T4 Y T3
(wrot T5 B 30
(loop (fx+ j 1)
T4-L T4-H
A-L A-H
T5-L T5-H
C-L C-H
D-L D-H)))))))
(if (fx< j 80)
(stage1)
(begin
(wadd NEWA A OLDA (wset hash 0 NEWA))
(wadd NEWB B OLDB (wset hash 1 NEWB))
(wadd NEWC C OLDC (wset hash 2 NEWC))
(wadd NEWD D OLDD (wset hash 3 NEWD))
(wadd NEWE E OLDE (wset hash 4 NEWE))))))))))))
(define (open-digest-sha-1)
(make-digest
end-block-digest
digest-update-block-digest
(make-block-digest
digest-update-sha-1
(hash-block-init-sha-1)
(make-vector 160 0)
0
0
#t
160)))
;;;----------------------------------------------------------------------------
;; SHA-224 and SHA-256 digests.
(define (hash-block-init-sha-224)
(vector #x9ed8 #xc105
#xd507 #x367c
#xdd17 #x3070
#x5939 #xf70e
#x0b31 #xffc0
#x1511 #x6858
#x8fa7 #x64f9
#x4fa4 #xbefa))
(define (hash-block-init-sha-256)
(vector #xe667 #x6a09
#xae85 #xbb67
#xf372 #x3c6e
#xf53a #xa54f
#x527f #x510e
#x688c #x9b05
#xd9ab #x1f83
#xcd19 #x5be0))
(define-macro (fn-W dst i body)
`(wref ,dst block ,i ,body))
(define-macro (fn-R dst i body)
`(wref T1 block ,(fx- i 15) ;; compute S0
(wrot T2 T1 25
(wrot T3 T1 14
(wxor T4 T2 T3
(wshr T5 T1 3
(wxor S0 T4 T5
(wref T6 block ,(fx- i 2) ;; compute S1
(wrot T7 T6 15
(wrot T8 T6 13
(wxor T9 T7 T8
(wshr T10 T6 10
(wxor S1 T9 T10
(wadd T11 S0 S1 ;; compute sum
(wref T12 block ,(fx- i 7)
(wadd T13 T11 T12
(wref T14 block ,(fx- i 16)
(wadd ,dst T13 T14
(begin (wset block ,i ,dst)
,body)))))))))))))))))))
(define-macro (fn-P a b c d e f g h x i k-hi16 k-lo16 body)
`(wrot T1 ,a 30 ;; compute S2
(wrot T2 ,a 19
(wxor T3 T1 T2
(wrot T4 ,a 10
(wxor S2 T3 T4
(wrot T5 ,e 26 ;; compute S3
(wrot T6 ,e 21
(wxor T7 T5 T6
(wrot T8 ,e 7
(wxor S3 T7 T8
(wior T9 ,a ,b ;; compute F0
(wand T10 ,c T9
(wand T11 ,a ,b
(wior F0 T10 T11
(wxor T12 ,f ,g ;; compute F1
(wand T13 ,e T12
(wxor F1 ,g T13
(,x T14 ,i ;; compute (fn-W i) or (fn-R i)
(wadd T15 T14 S3 ;; compute sum
(wadd T16 F1 T15
(wlet T17 ,k-lo16 ,k-hi16
(wadd T18 T16 T17
(wadd T19 ,h T18
(wadd T20 S2 F0
(wadd ,d T19 ,d
(wadd ,h T19 T20
,body)))))))))))))))))))))))))))
(define (digest-update-sha-256 digest)
(let* ((bd (digest-state digest))
(hash (block-digest-hash bd))
(block (block-digest-block bd)))
(define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-W 0 #x428A #x2F98
(fn-P H A B C D E F G fn-W 1 #x7137 #x4491
(fn-P G H A B C D E F fn-W 2 #xB5C0 #xFBCF
(fn-P F G H A B C D E fn-W 3 #xE9B5 #xDBA5
(fn-P E F G H A B C D fn-W 4 #x3956 #xC25B
(fn-P D E F G H A B C fn-W 5 #x59F1 #x11F1
(fn-P C D E F G H A B fn-W 6 #x923F #x82A4
(fn-P B C D E F G H A fn-W 7 #xAB1C #x5ED5
(stage2 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-W 8 #xD807 #xAA98
(fn-P H A B C D E F G fn-W 9 #x1283 #x5B01
(fn-P G H A B C D E F fn-W 10 #x2431 #x85BE
(fn-P F G H A B C D E fn-W 11 #x550C #x7DC3
(fn-P E F G H A B C D fn-W 12 #x72BE #x5D74
(fn-P D E F G H A B C fn-W 13 #x80DE #xB1FE
(fn-P C D E F G H A B fn-W 14 #x9BDC #x06A7
(fn-P B C D E F G H A fn-W 15 #xC19B #xF174
(stage3 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-R 16 #xE49B #x69C1
(fn-P H A B C D E F G fn-R 17 #xEFBE #x4786
(fn-P G H A B C D E F fn-R 18 #x0FC1 #x9DC6
(fn-P F G H A B C D E fn-R 19 #x240C #xA1CC
(fn-P E F G H A B C D fn-R 20 #x2DE9 #x2C6F
(fn-P D E F G H A B C fn-R 21 #x4A74 #x84AA
(fn-P C D E F G H A B fn-R 22 #x5CB0 #xA9DC
(fn-P B C D E F G H A fn-R 23 #x76F9 #x88DA
(stage4 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-R 24 #x983E #x5152
(fn-P H A B C D E F G fn-R 25 #xA831 #xC66D
(fn-P G H A B C D E F fn-R 26 #xB003 #x27C8
(fn-P F G H A B C D E fn-R 27 #xBF59 #x7FC7
(fn-P E F G H A B C D fn-R 28 #xC6E0 #x0BF3
(fn-P D E F G H A B C fn-R 29 #xD5A7 #x9147
(fn-P C D E F G H A B fn-R 30 #x06CA #x6351
(fn-P B C D E F G H A fn-R 31 #x1429 #x2967
(stage5 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-R 32 #x27B7 #x0A85
(fn-P H A B C D E F G fn-R 33 #x2E1B #x2138
(fn-P G H A B C D E F fn-R 34 #x4D2C #x6DFC
(fn-P F G H A B C D E fn-R 35 #x5338 #x0D13
(fn-P E F G H A B C D fn-R 36 #x650A #x7354
(fn-P D E F G H A B C fn-R 37 #x766A #x0ABB
(fn-P C D E F G H A B fn-R 38 #x81C2 #xC92E
(fn-P B C D E F G H A fn-R 39 #x9272 #x2C85
(stage6 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-R 40 #xA2BF #xE8A1
(fn-P H A B C D E F G fn-R 41 #xA81A #x664B
(fn-P G H A B C D E F fn-R 42 #xC24B #x8B70
(fn-P F G H A B C D E fn-R 43 #xC76C #x51A3
(fn-P E F G H A B C D fn-R 44 #xD192 #xE819
(fn-P D E F G H A B C fn-R 45 #xD699 #x0624
(fn-P C D E F G H A B fn-R 46 #xF40E #x3585
(fn-P B C D E F G H A fn-R 47 #x106A #xA070
(stage7 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-R 48 #x19A4 #xC116
(fn-P H A B C D E F G fn-R 49 #x1E37 #x6C08
(fn-P G H A B C D E F fn-R 50 #x2748 #x774C
(fn-P F G H A B C D E fn-R 51 #x34B0 #xBCB5
(fn-P E F G H A B C D fn-R 52 #x391C #x0CB3
(fn-P D E F G H A B C fn-R 53 #x4ED8 #xAA4A
(fn-P C D E F G H A B fn-R 54 #x5B9C #xCA4F
(fn-P B C D E F G H A fn-R 55 #x682E #x6FF3
(stage8 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(fn-P A B C D E F G H fn-R 56 #x748F #x82EE
(fn-P H A B C D E F G fn-R 57 #x78A5 #x636F
(fn-P G H A B C D E F fn-R 58 #x84C8 #x7814
(fn-P F G H A B C D E fn-R 59 #x8CC7 #x0208
(fn-P E F G H A B C D fn-R 60 #x90BE #xFFFA
(fn-P D E F G H A B C fn-R 61 #xA450 #x6CEB
(fn-P C D E F G H A B fn-R 62 #xBEF9 #xA3F7
(fn-P B C D E F G H A fn-R 63 #xC671 #x78F2
(stage9 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
(define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)
(wref OLDA hash 0 (wadd NEWA A OLDA (wset hash 0 NEWA)))
(wref OLDB hash 1 (wadd NEWB B OLDB (wset hash 1 NEWB)))
(wref OLDC hash 2 (wadd NEWC C OLDC (wset hash 2 NEWC)))
(wref OLDD hash 3 (wadd NEWD D OLDD (wset hash 3 NEWD)))
(wref OLDE hash 4 (wadd NEWE E OLDE (wset hash 4 NEWE)))
(wref OLDF hash 5 (wadd NEWF F OLDF (wset hash 5 NEWF)))
(wref OLDG hash 6 (wadd NEWG G OLDG (wset hash 6 NEWG)))
(wref OLDH hash 7 (wadd NEWH H OLDH (wset hash 7 NEWH))))
(wref A hash 0
(wref B hash 1
(wref C hash 2
(wref D hash 3
(wref E hash 4
(wref F hash 5
(wref G hash 6
(wref H hash 7
(stage1 A-L A-H B-L B-H C-L C-H D-L D-H
E-L E-H F-L F-H G-L G-H H-L H-H)))))))))))
(define (open-digest-sha-224)
(make-digest
end-block-digest
digest-update-block-digest
(make-block-digest
digest-update-sha-256
(hash-block-init-sha-224)
(make-vector 160 0)
0
0
#t
224)))
(define (open-digest-sha-256)
(make-digest
end-block-digest
digest-update-block-digest
(make-block-digest
digest-update-sha-256
(hash-block-init-sha-256)
(make-vector 160 0)
0
0
#t
256)))
;;;----------------------------------------------------------------------------
(define (open-digest algorithm)
(case algorithm
((crc32 CRC32)
(open-digest-crc32))
((md5 MD5)
(open-digest-md5))
((sha-1 SHA-1)
(open-digest-sha-1))
((sha-224 SHA-224)
(open-digest-sha-224))
((sha-256 SHA-256)
(open-digest-sha-256))
;; ((sha-384 SHA-384)
;; (open-digest-sha-384))
;; ((sha-512 SHA-512)
;; (open-digest-sha-512))
(else
(error "unknown hashing algorithm" algorithm))))
(define-macro (digest-default-result-type) ''hex)
(define (close-digest
digest
#!optional
(result-type (digest-default-result-type)))
((digest-end digest) digest result-type))
(define (digest-update-subu8vector digest u8vect start end)
((digest-update digest) digest u8vect start end))
(define zero-u8vector (make-u8vector 4 0))
(define (get-zero-u8vector) zero-u8vector)
(define (digest-update-u8 digest n) ;; assumes n is a fixnum
(digest-update-subu8vector
digest
(if (eqv? n 0)
(get-zero-u8vector)
(make-u8vector 1 (fxand n #xff)))
0
1))
(define (digest-update-u16-le digest n) ;; assumes n is a fixnum
(digest-update-subu8vector
digest
(if (eqv? n 0)
(get-zero-u8vector)
(let ((u8vect (make-u8vector 2)))
(u8vector-set!
u8vect
0
(fxand n #xff))
(u8vector-set!
u8vect
1
(fxand (fxarithmetic-shift-right n 8) #xff))
u8vect))
0
2))
(define (digest-update-u16-be digest n) ;; assumes n is a fixnum
(digest-update-subu8vector
digest
(if (eqv? n 0)
(get-zero-u8vector)
(let ((u8vect (make-u8vector 2)))
(u8vector-set!
u8vect
1
(fxand n #xff))
(u8vector-set!
u8vect
0
(fxand (fxarithmetic-shift-right n 8) #xff))
u8vect))
0
2))
(define (digest-update-u32-le digest n) ;; assumes n is a fixnum
(digest-update-subu8vector
digest
(if (eqv? n 0)
(get-zero-u8vector)
(let ((u8vect (make-u8vector 4)))
(u8vector-set!
u8vect
0
(fxand n #xff))
(u8vector-set!
u8vect
1
(fxand (fxarithmetic-shift-right n 8) #xff))
(u8vector-set!
u8vect
2
(fxand (fxarithmetic-shift-right n 16) #xff))
(u8vector-set!
u8vect
3
(fxand (fxarithmetic-shift-right n 24) #xff))
u8vect))
0
4))
(define (digest-update-u32-be digest n) ;; assumes n is a fixnum
(digest-update-subu8vector
digest
(if (eqv? n 0)
(get-zero-u8vector)
(let ((u8vect (make-u8vector 4)))
(u8vector-set!
u8vect
3
(fxand n #xff))
(u8vector-set!
u8vect
2
(fxand (fxarithmetic-shift-right n 8) #xff))
(u8vector-set!
u8vect
1
(fxand (fxarithmetic-shift-right n 16) #xff))
(u8vector-set!
u8vect
0
(fxand (fxarithmetic-shift-right n 24) #xff))
u8vect))
0
4))
(define (digest-string
str
algorithm
#!optional
(result-type (digest-default-result-type)))
(digest-substring
str
0
(string-length str)
algorithm
result-type))
(define (digest-substring
str
start
end
algorithm
#!optional
(result-type (digest-default-result-type)))
(let* ((len (fx- end start))
(u8vect (make-u8vector len)))
(let loop ((i 0))
(if (fx< i len)
(begin
(u8vector-set! u8vect i (char->integer (string-ref str i)))
(loop (fx+ i 1)))
(digest-subu8vector u8vect 0 len algorithm result-type)))))
(define (digest-u8vector
u8vect
algorithm
#!optional
(result-type (digest-default-result-type)))
(digest-subu8vector
u8vect
0
(u8vector-length u8vect)
algorithm
result-type))
(define (digest-subu8vector
u8vect
start
end
algorithm
#!optional
(result-type (digest-default-result-type)))
(let ((digest (open-digest algorithm)))
(digest-update-subu8vector digest u8vect start end)
(close-digest digest result-type)))
(define (digest-file
filename
algorithm
#!optional
(result-type (digest-default-result-type)))
(let ((digest (open-digest algorithm)))
(let* ((in (open-input-file filename))
(bufsize 1024)
(buf (make-u8vector bufsize)))
(let loop ()
(let ((n (read-subu8vector buf 0 bufsize in)))
(if (fx= n 0)
(begin
(close-input-port in)
(close-digest digest result-type))
(begin
(digest-update-subu8vector digest buf 0 n)
(loop))))))))
;;;----------------------------------------------------------------------------
;; Self tests.
#;
(begin
(define crc32-test-vectors
'(
("" 0 ""
"00000000")
("" 0 "a"
"e8b7be43")
("" 0 "abc"
"352441c2")
("" 0 "abcdefghijklmnopqrstuvwxyz"
"4c2750bd")
("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
"1fc2e6d2")
("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
"7ca94a72")
))
(define md5-test-vectors
'(
;; from RFC 1321:
("" 0 ""
"d41d8cd98f00b204e9800998ecf8427e")
("" 0 "a"
"0cc175b9c0f1b6a831c399e269772661")
("" 0 "abc"
"900150983cd24fb0d6963f7d28e17f72")
("" 0 "message digest"
"f96b697d7cb7938d525a2f31aaf161d0")
("" 0 "abcdefghijklmnopqrstuvwxyz"
"c3fcd3d76192e4007dfb496cca67e13b")
("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
"d174ab98d277d9f5a5611c2c9f419d9f")
("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
"57edf4a22be3c955ac49da2e2107b67a")
))
(define sha-1-test-vectors
'(
("" 0 ""
"da39a3ee5e6b4b0d3255bfef95601890afd80709")
;; from RFC 3174:
("" 0 "abc"
"a9993e364706816aba3e25717850c26c9cd0d89d")
("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
"84983e441c3bd26ebaae4aa1f95129e5e54670f1")
;; ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;; "34aa973cd4c4daa4f61eeb2bdbad27316534016f")
("0123456701234567012345670123456701234567012345670123456701234567" 10 ""
"dea356a2cddd90c7a7ecedc5ebb563934f460452")
))
(define sha-224-test-vectors
'(
;; from RFC 3874:
("" 0 "abc"
"23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7")
("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
"75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525")
;; ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;; "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67")
))
(define sha-256-test-vectors
'(
("" 0 ""
"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
;; from FIPS-180-2:
("" 0 "abc"
"ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")
("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
"248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1")
;; ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;; "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0")
))
(define (test-digest)
(define (t algorithm vectors)
(namespace ("" pp list->u8vector))
(for-each
(lambda (v)
(let ((str1 (car v))
(repeat (cadr v))
(str2 (caddr v))
(expect (cadddr v)))
(let ((md
(if (fx= repeat 0)
(digest-string str2 algorithm 'hex)
(let ((u8vect1
(list->u8vector
(map char->integer (string->list str1))))
(u8vect2
(list->u8vector
(map char->integer (string->list str2))))
(digest
(open-digest algorithm)))
(let loop ((i 0))
(if (fx< i repeat)
(begin
(digest-update-subu8vector
digest
u8vect1
0
(u8vector-length u8vect1))
(loop (fx+ i 1)))
(begin
(digest-update-subu8vector
digest
u8vect2
0
(u8vector-length u8vect2))
(close-digest digest 'hex))))))))
(if (not (string-ci=? md expect))
(pp (list '***error*** md expect))))))
vectors))
(t 'crc32 crc32-test-vectors)
(t 'md5 md5-test-vectors)
(t 'sha-1 sha-1-test-vectors)
(t 'sha-224 sha-224-test-vectors)
(t 'sha-256 sha-256-test-vectors)
)
(test-digest))
;;;============================================================================
Jump to Line
Something went wrong with that request. Please try again.