suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add file/sha1 and use it in openssl/sha1 when OpenSSL fails to load

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-13 15:18:04 -06:00
parent 9743fd9381
commit 94799247ee
6 changed files with 385 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/file/scribblings/file.scrbl
View File

@ -10,6 +10,7 @@
@include-section["zip.scrbl"]
@include-section["tar.scrbl"]
@include-section["md5.scrbl"]
@include-section["sha1.scrbl"]
@include-section["gif.scrbl"]
@(bibliography

1
collects/file/scribblings/md5.scrbl
View File

@ -1,7 +1,6 @@
#lang scribble/doc
@(require "common.ss"
scribble/eval
file/md5
(for-label file/md5))
@(define md5-eval (make-base-eval))

44
collects/file/scribblings/sha1.scrbl Normal file
View File

@ -0,0 +1,44 @@
#lang scribble/doc
@(require "common.ss"
scribble/eval
(for-label file/sha1))
@(define sha1-eval (make-base-eval))
@interaction-eval[#:eval sha1-eval (require file/sha1)]
@title[#:tag "sha1b"]{SHA1 Message Digest}
@defmodule[file/sha1]
See @racketmodname[openssl/sha1] for a faster implementation.
@defproc[(sha1 [in input-port]) string?]{
Returns a 40-character string that represents the SHA-1 hash (in
hexadecimal notation) of the content from @scheme[in], consuming all
of the input from @scheme[in] until an end-of-file.
The @scheme[sha1] function composes @scheme[bytes->hex-string] with
@racket[sha1-bytes].
@examples[
#:eval sha1-eval
(sha1 (open-input-bytes #"abc"))
]}
@defproc[(sha1-bytes [in input-port]) bytes?]{
Returns a 20-byte byte string that represents the SHA-1 hash of the
content from @scheme[in], consuming all of the input from @scheme[in]
until an end-of-file.
@examples[
#:eval sha1-eval
(sha1-bytes (open-input-bytes #"abc"))
]}
@defproc[(bytes->hex-string [bstr bytes?]) string?]{
Converts the given byte string to a string representation, where each
byte in @scheme[bstr] is converted to its two-digit hexadecimal
representation in the resulting string.}

310
collects/file/sha1.rkt Normal file
View File

@ -0,0 +1,310 @@
#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)))

4
collects/openssl/openssl.scrbl
View File

@ -344,7 +344,9 @@ collection for testing purposes where the peer identifies itself using
@defmodule[openssl/sha1]{The @schememodname[openssl/sha1] library
provides a Racket wrapper for the OpenSSL library's SHA-1 hashing
functions.}
functions. If the OpenSSL library cannot be opened, this library logs
a warning and falls back to the implementation in
@racketmodname[file/sha1].}
@defproc[(sha1 [in input-port]) string?]{

59
collects/openssl/sha1.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base
(require ffi/unsafe
racket/runtime-path
(for-syntax racket/base))
(for-syntax racket/base)
(prefix-in r: file/sha1))
(provide sha1
sha1-bytes
bytes->hex-string)
(rename-out [r:bytes->hex-string bytes->hex-string]))
(define-runtime-path libcrypto-so
(case (system-type)
@ -13,43 +14,37 @@
[else '(so "libcrypto")]))
(define libcrypto
(ffi-lib libcrypto-so '("" "0.9.8b" "0.9.8" "0.9.7")))
(with-handlers ([exn:fail? (lambda (exn)
(log-warning (format "warning: couldn't load OpenSSL library: ~a"
(if (exn? exn)
(exn-message exn)
exn)))
#f)])
(ffi-lib libcrypto-so '("" "0.9.8b" "0.9.8" "0.9.7"))))
(define _SHA_CTX-pointer _pointer)
(define SHA1_Init
(get-ffi-obj 'SHA1_Init libcrypto (_fun _SHA_CTX-pointer -> _int)))
(get-ffi-obj 'SHA1_Init libcrypto (_fun _SHA_CTX-pointer -> _int) (lambda () #f)))
(define SHA1_Update
(get-ffi-obj 'SHA1_Update libcrypto (_fun _SHA_CTX-pointer _pointer _long -> _int)))
(get-ffi-obj 'SHA1_Update libcrypto (_fun _SHA_CTX-pointer _pointer _long -> _int) (lambda () #f)))
(define SHA1_Final
(get-ffi-obj 'SHA1_Final libcrypto (_fun _pointer _SHA_CTX-pointer -> _int)))
(get-ffi-obj 'SHA1_Final libcrypto (_fun _pointer _SHA_CTX-pointer -> _int) (lambda () #f)))
(define (sha1-bytes in)
(let ([ctx (malloc 256)]
[tmp (make-bytes 4096)]
[result (make-bytes 20)])
(SHA1_Init ctx)
(let loop ()
(let ([n (read-bytes-avail! tmp in)])
(unless (eof-object? n)
(SHA1_Update ctx tmp n)
(loop))))
(SHA1_Final result ctx)
result))
(if SHA1_Init
(let ([ctx (malloc 256)]
[tmp (make-bytes 4096)]
[result (make-bytes 20)])
(SHA1_Init ctx)
(let loop ()
(let ([n (read-bytes-avail! tmp in)])
(unless (eof-object? n)
(SHA1_Update ctx tmp n)
(loop))))
(SHA1_Final result ctx)
result)
(r:sha1-bytes in)))
(define (sha1 in)
(bytes->hex-string (sha1-bytes 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)))
(r:bytes->hex-string (sha1-bytes in)))