#!r6rs
(import (rnrs)
        (rnrs r5rs (6)) ; quotient
        (rnrs mutable-strings (6)) 
        (rnrs io ports (6))
        (mzlib foreign))

(unsafe!)

(define (add1 n) (+ n 1))

(define (quotient/remainder n d)
  (values (quotient n d)
          (remainder n d)))

(define (read-bytes n port)
  (get-bytevector-n port n))


;;; digest.ss  --  Jens Axel Søgaard

;;;
;;; PURPOSE
;;;

; This provides bindings for the message digest functions in libcrypto.
; The bindings use the high level interface as descibed in the
; libcryopto documentation:
;     <http://www.openssl.org/docs/crypto/EVP_DigestInit.html#>

; Incremental generation of the message digests are supported.

;;;
;;; SUPPORTED MESSAGE DIGEST METHODS
;;;

;   md2, md4, md5, sha, sha1, ripemd160

;;;
;;; HISTORY
;;;

; 2007-feb-03
;   - version 1.0 released
;        bytes->hex-string
;        make-digest-context, init-context, update-context
;        final-context->bytes, final-context->hex-string
;        bytes-digest, digest, bytes-digest-port digest-port

; 2007-feb-18
;   - version 1.1 released
;        added offsets and lengths to update-context
;        and the various named digest functions such as
;        md5, md5-bytes, etc.

; 2007-mar-10
;   - version 1.2 released
;       * applied patch from Dimitris Vyzovitis which
;         fixes bugs in the *-bytes version.
;       * added test suite

; 2008-july-27
;   - version 1.3 (not released)
;       * r6rs version (sans mzlib/foreign)


; open the shared library
(define libcrypto
  (case ' macosx ; (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 (bytevector->hex-string bytes)
  (let* ([len (* 2 (bytevector-length bytes))]
         [len/2 (quotient len 2)]
         [s (make-string len)])
    (do ([i 0 (add1 i)])
      [(= i len/2) s]
      (let* ([c    (bytevector-u8-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)))))))

; hash->string : pointer integer -> string
;   convert the bytevector pointed by the c-pointer pointer into a string.
(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)))))))

;;;
;;; INCREMENTAL
;;;

(define EVP_MD_CTX_create
  ; allocates, initializes and returns a digest context.
  ; EVP_MD_CTX *EVP_MD_CTX_create(void);
  (get-ffi-obj 'EVP_MD_CTX_create libcrypto
               (_fun -> _pointer))) ; *EVP_MD_CTX

(define OpenSSL_add_all_digests
  ; register all digest names for getbyname functions
  (get-ffi-obj 'OpenSSL_add_all_digests libcrypto
               (_fun -> _void)))

(define OpenSSL_add_all_ciphers
  ; register all cipher names for getbyname functions
  (get-ffi-obj 'OpenSSL_add_all_ciphers libcrypto
               (_fun -> _void)))

(OpenSSL_add_all_digests) ; must be called in order to use get-digestbyname
; (OpenSSL_add_all_ciphers) ; not needed in this digest only module

(define EVP_get_digestbyname
  ; return an EVP_MD structure when passed a digest name
  ; !!! The digest table must be initialized using, for example,
  ; !!! OpenSSL_add_all_digests() for this function to work.
  ; const EVP_MD *EVP_get_digestbyname(const char *name);
  (get-ffi-obj 'EVP_get_digestbyname libcrypto
               (_fun _string -> _pointer)))

(define EVP_MD_CTX_init
  ; initializes digest context ctx.
  ; void EVP_MD_CTX_init(EVP_MD_CTX *ctx);
  (get-ffi-obj 'EVP_MD_CTX_init libcrypto
               (_fun _pointer -> _void)))

(define EVP_DigestInit_ex
  ; sets up digest context ctx to use a digest type from ENGINE impl.
  ; ctx must be initialized before calling this function.
  ; type will typically be supplied by a functionsuch as EVP_sha1().
  ; If impl is NULL then the default implementation of digest type is used.
  
  ; int EVP_DigestInit_ex(EVP_MD_CTX *ctx, const EVP_MD *type, ENGINE *impl);
  (get-ffi-obj 'EVP_DigestInit_ex libcrypto
               (_fun _pointer _pointer _pointer -> _int)))

(define EVP_DigestUpdate
  ; hashes cnt bytevector of data at d into the digest context ctx.
  ; This function can be called several times on the same ctx to hash additional data.
  ; int EVP_DigestUpdate(EVP_MD_CTX *ctx, const void *d, size_t cnt);
  (get-ffi-obj 'EVP_DigestUpdate libcrypto
               (_fun _pointer _pointer _int ;!!! TODO: is size_t always an int ?
                     -> _int)))

(define EVP_DigestFinal_ex
  ; retrieves the digest value from ctx and places it in md.
  ; If the s parameter is not NULL then the number of bytevector of data written
  ; (i.e. the length of the digest) will be written to the integer at s,
  ; at most EVP_MAX_MD_SIZE bytevector will be written.
  ; After calling EVP_DigestFinal_ex() no additional calls to EVP_DigestUpdate()
  ; can be made, but EVP_DigestInit_ex() can be called to initialize a new digest operation.
  
  ; int EVP_DigestFinal_ex(EVP_MD_CTX *ctx, unsigned char *md, unsigned int *s);
  (get-ffi-obj 'EVP_DigestFinal_ex libcrypto
               (_fun _pointer _pointer _pointer -> _pointer)))

(define EVP_MD_CTX_cleanup
  ; cleans up digest context ctx, it should be called after a digest context is no longer needed.
  
  ; int EVP_MD_CTX_cleanup(EVP_MD_CTX *ctx);
  (get-ffi-obj 'EVP_MD_CTX_cleanup libcrypto
               (_fun _pointer -> _int)))

; EVP_md2(), EVP_md5(), EVP_sha(), EVP_sha1(), EVP_mdc2() and EVP_ripemd160()
; return EVP_MD structures for the MD2, MD5, SHA, SHA1, MDC2 and RIPEMD160 digest algorithms respectively.
; The associated signature algorithm is RSA in each case.
;(define EVP_md5
;  (get-ffi-obj 'EVP_md5 libcrypto
;               (_fun -> _pointer)))

; Example in C:
;   EVP_MD_CTX_init(&mdctx);
;   EVP_DigestInit_ex(&mdctx, md, NULL);
;   EVP_DigestUpdate(&mdctx, mess1, strlen(mess1));
;   EVP_DigestUpdate(&mdctx, mess2, strlen(mess2));
;   EVP_DigestFinal_ex(&mdctx, md_value, &md_len);
;   EVP_MD_CTX_cleanup(&mdctx);

;;(define-struct context (c method md-name finalized?))
(define (make-context c method md-name finalized?)
  (vector 'context c method md-name finalized?))
(define (context-c c) (vector-ref c 1))
(define (context-method c) (vector c 2))
(define (context-md-name c) (vector-ref c 3))
(define (context-finalized? c) (vector-ref c 4))
(define (set-context-finalized?! c v) (vector-set! c 4 v))

; A context if final-context->hex-string or final-context->bytevector
; have been called upon it. This is only allowed once.

; the supported message digest methods
(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"))
; dss1 is the same as sha1, but dss1 must be must be used with EVP_sha1 - included only for completeness
(define dss1-method      (EVP_get_digestbyname "dss1"))


; md-name->method : symbol -> pointer
;   return pointer to a EVP_MD structure representing a
;   specific message digest method.
(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)
  ; number of bytevector in output
  (case md-name
    [(md5 md2 md4)             16]  ; 128 bits
    [(sha sha1 ripemd160 dss1) 20]  ; 160 bits
    [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)])  ; TODO: deallocation!
    (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)))

;(provide/contract [update-context (case-> (context? bytevector? integer? . c-> . void)
;                                 (context? bytevector? integer? integer? . c-> . void)
;                                          (context? bytevector? . c-> . void))])
(define update-context 
  (case-lambda 
    [(context data len)
     (EVP_DigestUpdate (context-c context) data len)]
    [(context data offset len)
     (EVP_DigestUpdate (context-c context) (ptr-add data offset) len)]
    [(context data)
     (EVP_DigestUpdate (context-c context) data (bytevector-length data))]))

;(provide/contract [final-context->bytevector (context? . c-> . bytevector?)])
(define (final-context->bytevector context)
  (unless (not (context-finalized? context))
    (error 'final-context->bytevector "A context can be finalized only once."))
  (let* ([size (md-name->output-size (context-md-name context))]
         [md (make-bytevector 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)
  (bytevector->hex-string
   (final-context->bytevector context)))

;(provide/contract [bytevector-digest (bytevector? symbol? . c-> . bytevector?)])
(define (bytevector-digest bytevector md-name)
  (let ([context (make-digest-context md-name)])
    (update-context context bytevector)
    (final-context->bytevector context)))

;(provide/contract [digest (bytevector? symbol? . c-> . string?)])
(define (digest bytevector md-name)
  (bytevector->hex-string
   (bytevector-digest bytevector md-name)))

;;;
;;; INDIVIDUAL MESSAGE DIGESTS
;;;

(define-syntax define-message-digester 
  (syntax-rules ()
    [(_ name bytevector-name method-name)
     (begin
       ;(provide/contract 
       ; [name (case-> 
       ;        (bytevector? . c-> . string?)
       ;        (bytevector? integer? . c-> . string?)
       ;        (bytevector? integer? integer? . c-> . string?))])
       (define name
         (case-lambda 
           [(bytevector)
            (bytevector->hex-string (bytevector-name bytevector
                                                     (bytevector-length bytevector)))]
           [(bytevector len)
            (bytevector->hex-string (bytevector-name bytevector len))]
           [(bytevector offset len)
            (bytevector->hex-string (bytevector-name bytevector offset len))]))
       
       ;(provide/contract 
       ; [bytevector-name (case-> 
       ;              (bytevector? . c-> . bytevector?)
       ;              (bytevector? integer? . c-> . bytevector?)
       ;              (bytevector? integer? integer? . c-> . bytevector?))])
       (define bytevector-name
         (case-lambda 
           [(bytevector)
            (bytevector-name bytevector (bytevector-length bytevector))]
           [(bytevector len)
            (when (bytevector? bytevector)
              (unless (<= len (bytevector-length bytevector))
                (error 'name "can't digest more bytevector than the length of the bytevector string, got ~a and ~a: "
                       bytevector len)))
            (let ([context (make-md-context-from-method 'name method-name)])
              (update-context context bytevector len)
              (final-context->bytevector context))]
           [(bytevector offset len)
            (when (bytevector? bytevector)
              (unless (<= (+ offset len) (bytevector-length bytevector))
                (error 'name "can't digest more bytevector than the length of the bytevector string minus the offset, got ~a and ~a: "
                       bytevector len)))
            (let ([context (make-md-context-from-method 'name method-name)])
              (update-context context (ptr-add bytevector offset) len)
              (final-context->bytevector context))])))]))

(define-message-digester md2        md2-bytevector        md2-method)
(define-message-digester md4        md4-bytevector        md4-method)
(define-message-digester md5        md5-bytevector        md5-method)
(define-message-digester sha        sha-bytevector        sha-method)
(define-message-digester sha1       sha1-bytevector       sha1-method)
(define-message-digester ripemd160  ripemd160-bytevector  ripemd160-method)
(define-message-digester dss1       dss1-bytevector       dss1-method)

; (provide/contract [bytevector-digest-port (port? symbol? . c-> . bytevector?)])
(define (bytevector-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->bytevector context)]
          [else                (update-context context block)
                               (loop)])))))

; (provide/contract [digest-port (port? symbol? . c-> . string?)])
(define (digest-port port md-name)
  (bytevector->hex-string
   (bytevector-digest-port port md-name)))

