311 lines
9.4 KiB
Racket
311 lines
9.4 KiB
Racket
#lang racket/base
|
|
|
|
#|
|
|
Originally:
|
|
|
|
Copyright (c) 2006 Eric Knauel
|
|
All rights reserved.
|
|
|
|
Redistribution and use in source and binary forms, with or without
|
|
modification, are permitted provided that the following conditions
|
|
are met:
|
|
1. Redistributions of source code must retain the above copyright
|
|
notice, this list of conditions and the following disclaimer.
|
|
2. Redistributions in binary form must reproduce the above copyright
|
|
notice, this list of conditions and the following disclaimer in the
|
|
documentation and/or other materials provided with the distribution.
|
|
3. The name of the authors may not be used to endorse or promote products
|
|
derived from this software without specific prior written permission.
|
|
|
|
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
|
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
|
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
|
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
|
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
|
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|#
|
|
|
|
(provide sha1
|
|
sha1-bytes
|
|
bytes->hex-string)
|
|
|
|
(define 32-mask #xFFFFFFFF)
|
|
|
|
(define (mod2+ a b)
|
|
(bitwise-and (+ a b) 32-mask))
|
|
|
|
(define (mod5+ a b c d e)
|
|
(bitwise-and (+ a b c d e) 32-mask))
|
|
|
|
;;; make a mask with COUNT 1 bits shifted START bits left
|
|
(define (make-extract-mask start count)
|
|
(arithmetic-shift (sub1 (arithmetic-shift 1 count)) start))
|
|
|
|
;;; rotate I COUNT bits to the left. Assumes length of 32 bits
|
|
(define (circular-shift-left i count)
|
|
(bitwise-ior
|
|
(arithmetic-shift (bitwise-and i (sub1 (arithmetic-shift 1 (- 32 count))))
|
|
count)
|
|
(arithmetic-shift i (- count 32))))
|
|
|
|
(define (calc-blocks-needed bits)
|
|
(if (<= bits 448)
|
|
1
|
|
(let* ((full-blocks (+ 1 (quotient bits 512)))
|
|
(rest (- (* full-blocks 512) bits)))
|
|
(if (< rest 64)
|
|
(+ 1 full-blocks)
|
|
full-blocks))))
|
|
|
|
;;; convert NUM-BYTES from BV (starting at START) into an integer
|
|
(define (bytes->block bv start num-bytes)
|
|
(let lp ((i 0) (block 0))
|
|
(if (= i num-bytes)
|
|
block
|
|
(lp (+ i 1)
|
|
(bitwise-ior
|
|
block
|
|
(arithmetic-shift (bytes-ref bv (+ start i))
|
|
(* 8 (- num-bytes (+ i 1)))))))))
|
|
|
|
;;; enough space for 64 bit length info?
|
|
(define (enough-space-for-length-info? last-block-len)
|
|
(<= last-block-len 56))
|
|
|
|
;;; add padding to BLOCK
|
|
(define (pad-block block unused-bits)
|
|
(bitwise-ior
|
|
(arithmetic-shift block unused-bits)
|
|
(arithmetic-shift #b1 (- unused-bits 1))))
|
|
|
|
(define (prepare-message! blocks unused-bits total-message-len)
|
|
(let* ((len (vector-length blocks))
|
|
(spare-block-index (- len 1))
|
|
(last-block-index (- len 2))
|
|
(last-block (vector-ref blocks last-block-index)))
|
|
(cond
|
|
((>= unused-bits (+ 64 1))
|
|
;; there is enough space to store the message length in the last
|
|
;; block
|
|
(vector-set! blocks
|
|
last-block-index
|
|
;(+ (pad-block last-block 512) total-message-len))
|
|
(+ (pad-block last-block unused-bits) total-message-len))
|
|
last-block-index)
|
|
((zero? unused-bits)
|
|
;; we need the spare block. There is no space to pad the last
|
|
;; block.
|
|
(vector-set! blocks
|
|
spare-block-index
|
|
;(+ (pad-block 0 512) total-message-len))
|
|
(+ (pad-block 0 unused-bits) total-message-len))
|
|
spare-block-index)
|
|
(else
|
|
;; we need the spare block. First pad the last-block to 512 bits
|
|
(vector-set! blocks
|
|
last-block-index
|
|
;(pad-block last-block 512))
|
|
(pad-block last-block unused-bits))
|
|
;; Now write the length into the spare block
|
|
(vector-set! blocks spare-block-index total-message-len)
|
|
spare-block-index))))
|
|
|
|
;;; generate a vector with masks that decompose a 512-bit block into
|
|
;;; 16 32-bit words (stored in a vector)
|
|
(define (make-split-block-vector)
|
|
(let ((vec (make-vector 16 0)))
|
|
(do ((i 0 (+ i 32))
|
|
(j 0 (+ j 1)))
|
|
((>= i 512) vec)
|
|
(vector-set! vec
|
|
j
|
|
(make-extract-mask i 32)))))
|
|
|
|
(define split-block-masks
|
|
(make-split-block-vector))
|
|
|
|
;;; decompose a 512-bit block into 16 32-bit words (stored in a
|
|
;;; vector)
|
|
(define (split-block block)
|
|
(let ((vec (make-vector 16 0)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i 16) vec)
|
|
(vector-set!
|
|
vec (- 15 i)
|
|
(arithmetic-shift
|
|
(bitwise-and (vector-ref split-block-masks i)
|
|
block)
|
|
(- (* i 32)))))))
|
|
|
|
;;; extend a vector with 16 32-bit words into a vector of 80 32-bit
|
|
;;; words
|
|
(define (extend-word-blocks word-block)
|
|
(let ((vec (make-vector 80 0)))
|
|
|
|
(do ((i 0 (+ i 1)))
|
|
((> i 15) (values))
|
|
(vector-set! vec i (vector-ref word-block i)))
|
|
|
|
(do ((i 16 (+ i 1)))
|
|
((> i 79) vec)
|
|
(vector-set!
|
|
vec i
|
|
(circular-shift-left
|
|
(bitwise-xor (vector-ref vec (- i 3))
|
|
(bitwise-xor (vector-ref vec (- i 8))
|
|
(bitwise-xor (vector-ref vec (- i 14))
|
|
(vector-ref vec (- i 16)))))
|
|
1)))))
|
|
|
|
;;; the nonlinear functions used by SHA1
|
|
(define (nonlinear-sha1-function i x y z)
|
|
(cond
|
|
((<= i 19)
|
|
(bitwise-xor (bitwise-and x y)
|
|
(bitwise-and (bitwise-not x) z)))
|
|
((<= i 39)
|
|
(bitwise-xor (bitwise-xor x y) z))
|
|
((<= i 59)
|
|
(bitwise-xor
|
|
(bitwise-xor (bitwise-and x y)
|
|
(bitwise-and x z))
|
|
(bitwise-and y z)))
|
|
(else
|
|
(bitwise-xor (bitwise-xor x y) z))))
|
|
|
|
;;; the SHA1 "constants"
|
|
(define (sha1-constant i)
|
|
(cond
|
|
((<= i 19) #x5a827999)
|
|
((<= i 39) #x6ed9eba1)
|
|
((<= i 59) #x8f1bbcdc)
|
|
(else #xca62c1d6)))
|
|
|
|
;;; append five 32 bits to a 160 bit hash number
|
|
(define (append-hash h0 h1 h2 h3 h4)
|
|
(bitwise-ior
|
|
(bitwise-ior
|
|
(bitwise-ior
|
|
(bitwise-ior h4 (arithmetic-shift h3 32))
|
|
(arithmetic-shift h2 64))
|
|
(arithmetic-shift h1 96))
|
|
(arithmetic-shift h0 128)))
|
|
|
|
;;; SHA1 main loop
|
|
(define (sha1-loop extended-words h0 h1 h2 h3 h4)
|
|
(let lp ((i 0) (a h0) (b h1) (c h2) (d h3) (e h4))
|
|
(if (= i 80)
|
|
(values a b c d e)
|
|
(lp (+ i 1)
|
|
(mod5+ (circular-shift-left a 5)
|
|
(nonlinear-sha1-function i b c d)
|
|
e
|
|
(vector-ref extended-words i)
|
|
(sha1-constant i))
|
|
a
|
|
(circular-shift-left b 30)
|
|
c
|
|
d))))
|
|
|
|
(define (calculate-sha1 blocks last-index)
|
|
(let lp ((index 0)
|
|
(h0 #x67452301) (h1 #xefcdab89) (h2 #x98badcfe)
|
|
(h3 #x10325476) (h4 #xc3d2e1f0))
|
|
(if (> index last-index)
|
|
(append-hash h0 h1 h2 h3 h4)
|
|
(let* ((block (vector-ref blocks index))
|
|
(word-blocks (split-block block))
|
|
(extended-words (extend-word-blocks word-blocks)))
|
|
(let-values ([(a b c d e)
|
|
(sha1-loop extended-words h0 h1 h2 h3 h4)])
|
|
(let ((h0 (mod2+ h0 a))
|
|
(h1 (mod2+ h1 b))
|
|
(h2 (mod2+ h2 c))
|
|
(h3 (mod2+ h3 d))
|
|
(h4 (mod2+ h4 e)))
|
|
(lp (+ index 1) h0 h1 h2 h3 h4)))))))
|
|
|
|
;;; returns a vector of blocks (a block is a 512 bit integer) and the
|
|
;;; number of unused bits in the last block.
|
|
(define (byte-string->blocks bv)
|
|
(let* ((bytes (bytes-length bv))
|
|
(vec (make-vector (+ 1 (+ 1 (quotient bytes (quotient 512 8)))) 0))
|
|
(bits 0))
|
|
;; the last element is a spare element---just needed if the
|
|
;; message length doesn't fit into the last message block.
|
|
(do ((i 0 (+ i 64))
|
|
(j 0 (+ j 1)))
|
|
((> (+ i 64) bytes)
|
|
(vector-set! vec j (bytes->block bv i (- bytes i)))
|
|
(values vec
|
|
(* 8 (- 64 (- bytes i)))
|
|
(+ bits (* 8 (- bytes i)))))
|
|
(set! bits (+ bits 512))
|
|
(vector-set! vec j (bytes->block bv i 64)))))
|
|
|
|
(define (sha1-hash-string str)
|
|
(sha1-hash-bytes (string->bytes/utf-8 str)))
|
|
|
|
(define (sha1-hash-bytes bv)
|
|
(let-values ([(blocks unused-bits total-length)
|
|
(byte-string->blocks bv)])
|
|
(let ((last-index (prepare-message! blocks unused-bits total-length)))
|
|
(calculate-sha1 blocks last-index))))
|
|
|
|
(define (make-hash-as-bytes-mask)
|
|
(let* ((len (quotient 160 8))
|
|
(vec (make-vector len 0)))
|
|
(do ((i 0 (+ i 8))
|
|
(j 0 (+ j 1)))
|
|
((>= i 160) vec)
|
|
(vector-set! vec j (make-extract-mask i 8)))))
|
|
|
|
(define hash-as-bytes-masks
|
|
(make-hash-as-bytes-mask))
|
|
|
|
(define (hash-value->bytes int)
|
|
(let* ((len (vector-length hash-as-bytes-masks))
|
|
(bv (make-bytes len 0)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i len) bv)
|
|
(bytes-set!
|
|
bv (- (- len 1) i)
|
|
(arithmetic-shift
|
|
(bitwise-and (vector-ref hash-as-bytes-masks i)
|
|
int)
|
|
(- (* i 8)))))))
|
|
|
|
(define (sha1-input in)
|
|
(let ([p (open-output-bytes)]
|
|
[bstr (make-bytes 4096)])
|
|
(let loop ()
|
|
(let ([c (read-bytes! bstr in)])
|
|
(unless (eof-object? c)
|
|
(write-bytes bstr p 0 c)
|
|
(loop))))
|
|
(sha1-hash-bytes (get-output-bytes p))))
|
|
|
|
(define (sha1 in)
|
|
(format "~x" (sha1-input in)))
|
|
|
|
(define (sha1-bytes in)
|
|
(hash-value->bytes (sha1-input in)))
|
|
|
|
(define (bytes->hex-string bstr)
|
|
(let* ([len (bytes-length bstr)]
|
|
[bstr2 (make-bytes (* len 2))]
|
|
[digit
|
|
(lambda (v)
|
|
(if (v . < . 10)
|
|
(+ v (char->integer #\0))
|
|
(+ v (- (char->integer #\a) 10))))])
|
|
(for ([i (in-range len)])
|
|
(let ([c (bytes-ref bstr i)])
|
|
(bytes-set! bstr2 (* 2 i) (digit (arithmetic-shift c -4)))
|
|
(bytes-set! bstr2 (+ (* 2 i) 1) (digit (bitwise-and c #xF)))))
|
|
(bytes->string/latin-1 bstr2)))
|