(module digest mzscheme
(require (lib "foreign.ss")
(all-except (lib "contract.ss") ->)
(rename (lib "contract.ss") c-> ->))
(unsafe!)
(define libcrypto
(case (system-type)
[(windows) (ffi-lib "libeay32")]
[else (ffi-lib "libcrypto")]))
(define hex (list->vector (string->list "0123456789abcdef")))
(provide/contract [bytes->hex-string (bytes? . c-> . string?)])
(define (bytes->hex-string bytes)
(let* ([len (* 2 (bytes-length bytes))]
[len/2 (quotient len 2)]
[s (make-string len)])
(do ([i 0 (add1 i)])
[(= i len/2) s]
(let* ([c (bytes-ref bytes i)]
[2i (* 2 i)]
[2i+1 (add1 2i)])
(let-values ([(q r) (quotient/remainder c 16)])
(string-set! s 2i (vector-ref hex q))
(string-set! s 2i+1 (vector-ref hex r)))))))
(define (hash->string pointer len)
(unless (<= 0 len 64)
(error 'hash->string
"the lengths of the supported message digests are between 0 and 64, got: ~a" len))
(let* ([len (* 2 len)]
[len/2 (quotient len 2)]
[s (make-string len)])
(do ([i 0 (add1 i)])
[(= i len/2) s]
(let* ([c (ptr-ref pointer _byte i)]
[2i (* 2 i)]
[2i+1 (add1 2i)])
(let-values ([(q r) (quotient/remainder c 16)])
(string-set! s 2i (vector-ref hex q))
(string-set! s 2i+1 (vector-ref hex r)))))))
(define EVP_MD_CTX_create
(get-ffi-obj 'EVP_MD_CTX_create libcrypto
(_fun -> _pointer)))
(define OpenSSL_add_all_digests
(get-ffi-obj 'OpenSSL_add_all_digests libcrypto
(_fun -> _void)))
(define OpenSSL_add_all_ciphers
(get-ffi-obj 'OpenSSL_add_all_ciphers libcrypto
(_fun -> _void)))
(OpenSSL_add_all_digests)
(define EVP_get_digestbyname
(get-ffi-obj 'EVP_get_digestbyname libcrypto
(_fun _string -> _pointer)))
(define EVP_MD_CTX_init
(get-ffi-obj 'EVP_MD_CTX_init libcrypto
(_fun _pointer -> _void)))
(define EVP_DigestInit_ex
(get-ffi-obj 'EVP_DigestInit_ex libcrypto
(_fun _pointer _pointer _pointer -> _int)))
(define EVP_DigestUpdate
(get-ffi-obj 'EVP_DigestUpdate libcrypto
(_fun _pointer _pointer _int -> _int)))
(define EVP_DigestFinal_ex
(get-ffi-obj 'EVP_DigestFinal_ex libcrypto
(_fun _pointer _pointer _pointer -> _pointer)))
(define EVP_MD_CTX_cleanup
(get-ffi-obj 'EVP_MD_CTX_cleanup libcrypto
(_fun _pointer -> _int)))
(define-struct context (c method md-name finalized?))
(define md2-method (EVP_get_digestbyname "md2"))
(define md4-method (EVP_get_digestbyname "md4"))
(define md5-method (EVP_get_digestbyname "md5"))
(define ripemd160-method (EVP_get_digestbyname "ripemd160"))
(define sha-method (EVP_get_digestbyname "sha"))
(define sha1-method (EVP_get_digestbyname "sha1"))
(define dss1-method (EVP_get_digestbyname "dss1"))
(define (md-name->method name)
(case name
[(md5) md5-method]
[(sha) sha-method]
[(sha1) sha1-method]
[(md2) md2-method]
[(md4) md4-method]
[(ripemd160) ripemd160-method]
[(dss1) dss1-method]
[else (error 'md-name->method "Unknown message digest name, got: ~a" name)]))
(define (md-name->output-size md-name)
(case md-name
[(md5 md2 md4) 16] [(sha sha1 ripemd160 dss1) 20] [else (error 'md-name->output-size "Unknown message digest name, got: ~a" md-name)]))
(define (make-md-context-from-method md-name method)
(let ([c-context (EVP_MD_CTX_create)]) (EVP_MD_CTX_init c-context)
(EVP_DigestInit_ex c-context method #f)
(make-context c-context method md-name #f)))
(provide/contract [make-digest-context (symbol? . c-> . context?)])
(define (make-digest-context md-name)
(make-md-context-from-method md-name (md-name->method md-name)))
(provide/contract [init-context (context? . c-> . void)])
(define (init-context context)
(let ([c-context (context-c context)])
(EVP_MD_CTX_init c-context)
(EVP_DigestInit_ex c-context (context-method context) #f)
(set-context-finalized?! context #f)
(void)))
(provide/contract [update-context (case-> (context? bytes? integer? . c-> . void)
(context? bytes? integer? integer? . c-> . void)
(context? bytes? . c-> . void))])
(define update-context
(case-lambda
[(context data len)
(EVP_DigestUpdate (context-c context) data len)
(void)]
[(context data offset len)
(EVP_DigestUpdate (context-c context) (ptr-add data offset) len)
(void)]
[(context data)
(EVP_DigestUpdate (context-c context) data (bytes-length data))
(void)]))
(provide/contract [final-context->bytes (context? . c-> . bytes?)])
(define (final-context->bytes context)
(unless (not (context-finalized? context))
(error 'final-context->bytes "A context can be finalized only once."))
(let* ([size (md-name->output-size (context-md-name context))]
[md (make-bytes size)]
[c-context (context-c context)])
(EVP_DigestFinal_ex c-context md #f)
(set-context-finalized?! context #t)
md))
(provide/contract [final-context->hex-string (context? . c-> . string?)])
(define (final-context->hex-string context)
(bytes->hex-string
(final-context->bytes context)))
(provide/contract [bytes-digest (bytes? symbol? . c-> . bytes?)])
(define (bytes-digest bytes md-name)
(let ([context (make-digest-context md-name)])
(update-context context bytes)
(final-context->bytes context)))
(provide/contract [digest (bytes? symbol? . c-> . string?)])
(define (digest bytes md-name)
(bytes->hex-string
(bytes-digest bytes md-name)))
(define-syntax define-message-digester
(syntax-rules ()
[(_ name bytes-name method-name)
(begin
(provide/contract
[name (case->
(bytes? . c-> . string?)
(bytes? integer? . c-> . string?)
(bytes? integer? integer? . c-> . string?))])
(define name
(case-lambda
[(bytes)
(bytes->hex-string (bytes-name bytes (bytes-length bytes)))]
[(bytes len)
(bytes->hex-string (bytes-name bytes len))]
[(bytes offset len)
(bytes->hex-string (bytes-name bytes offset len))]))
(provide/contract
[bytes-name (case->
(bytes? . c-> . bytes?)
(bytes? integer? . c-> . bytes?)
(bytes? integer? integer? . c-> . bytes?))])
(define bytes-name
(case-lambda
[(bytes)
(bytes-name bytes (bytes-length bytes))]
[(bytes len)
(when (bytes? bytes)
(unless (<= len (bytes-length bytes))
(error 'name "can't digest more bytes than the length of the bytes string, got ~a and ~a: "
bytes len)))
(let ([context (make-md-context-from-method 'name method-name)])
(update-context context bytes len)
(final-context->bytes context))]
[(bytes offset len)
(when (bytes? bytes)
(unless (<= (+ offset len) (bytes-length bytes))
(error 'name "can't digest more bytes than the length of the bytes string minus the offset, got ~a and ~a: "
bytes len)))
(let ([context (make-md-context-from-method 'name method-name)])
(update-context context (ptr-add bytes offset) len)
(final-context->bytes context))])))]))
(define-message-digester md2 md2-bytes md2-method)
(define-message-digester md4 md4-bytes md4-method)
(define-message-digester md5 md5-bytes md5-method)
(define-message-digester sha sha-bytes sha-method)
(define-message-digester sha1 sha1-bytes sha1-method)
(define-message-digester ripemd160 ripemd160-bytes ripemd160-method)
(define-message-digester dss1 dss1-bytes dss1-method)
(provide/contract [bytes-digest-port (port? symbol? . c-> . bytes?)])
(define (bytes-digest-port port md-name)
(let ([context (make-digest-context md-name)])
(let loop ()
(let ([block (read-bytes 4096 port)])
(cond
[(eof-object? block) (final-context->bytes context)]
[else (update-context context block)
(loop)])))))
(provide/contract [digest-port (port? symbol? . c-> . string?)])
(define (digest-port port md-name)
(bytes->hex-string
(bytes-digest-port port md-name)))
)