(module (openssl digest)
  (
   digest-list
   digest-by-name
   digest-size
   digest-block-size
   digest-name
   max-digest-size
   digest-context-allocate!
   digest-context-free!
   digest-context-reset!
   digest-context-init!
   digest-context-update!
   digest-context-final!
   string-digest
   file-digest
   open-digest-port
   )

(import scheme)
(import (chicken base))
(import (chicken blob))
(import (chicken condition))
(import (chicken file posix))
(import (chicken foreign))
(import (chicken format))
(import (chicken gc))
(import (chicken io))
(import (chicken memory))
(import (chicken port))

#>
#include <openssl/err.h>
#include <openssl/evp.h>
<#

(define ERR_clear_error (foreign-lambda void "ERR_clear_error"))
(define ERR_get_error (foreign-lambda unsigned-long "ERR_get_error"))
(define ERR_lib_error_string (foreign-lambda c-string "ERR_lib_error_string" unsigned-long))
(define ERR_func_error_string (foreign-lambda c-string "ERR_func_error_string" unsigned-long))
(define ERR_reason_error_string (foreign-lambda c-string "ERR_reason_error_string" unsigned-long))

(define OBJ_NAME_ALIAS (foreign-value "OBJ_NAME_ALIAS" int))
(define-foreign-type OBJ_NAME* (const (c-pointer (struct "obj_name_st"))))
(define-foreign-type EVP_MD* (const c-pointer))
(define-foreign-type EVP_MD_CTX* c-pointer)
(define-foreign-type unsigned-int* (c-pointer unsigned-int))

(define evp-digests '())
(define-external (EVP_DigestList_callback (OBJ_NAME* obj) (c-pointer _arg)) c-pointer
  (let ((name ((foreign-lambda* c-string ((OBJ_NAME* obj)) "C_return(obj->name);") obj))
        (alias ((foreign-lambda* int ((OBJ_NAME* obj)) "C_return(obj->alias);") obj)))
    (when (not (= alias OBJ_NAME_ALIAS))
      (set! evp-digests (cons name evp-digests)))
    #f))

(define EVP_MD_CTX_new (foreign-lambda EVP_MD_CTX* "EVP_MD_CTX_new"))
(define EVP_MD_CTX_free (foreign-lambda void "EVP_MD_CTX_free" EVP_MD_CTX*))
(define EVP_MD_CTX_reset (foreign-lambda bool "EVP_MD_CTX_reset" EVP_MD_CTX*))
(define EVP_MD_CTX_set_flags (foreign-lambda void "EVP_MD_CTX_set_flags" EVP_MD_CTX* int))

(define EVP_DigestInit_ex (foreign-lambda bool "EVP_DigestInit_ex" EVP_MD_CTX* EVP_MD* c-pointer))
(define EVP_DigestUpdate (foreign-lambda bool "EVP_DigestUpdate" EVP_MD_CTX* (const blob) size_t))
(define EVP_DigestFinal_ex (foreign-lambda bool "EVP_DigestFinal_ex" EVP_MD_CTX* blob unsigned-int*))

(define EVP_get_digestbyname (foreign-lambda EVP_MD* "EVP_get_digestbyname" c-string))
(define EVP_MD_size (foreign-lambda int "EVP_MD_size" EVP_MD*))
(define EVP_MD_block_size (foreign-lambda int "EVP_MD_block_size" EVP_MD*))
(define EVP_MD_name (foreign-lambda c-string "EVP_MD_name" EVP_MD*))

(define EVP_MAX_MD_SIZE (foreign-value "EVP_MAX_MD_SIZE" int))
(define EVP_MD_CTX_FLAG_ONESHOT (foreign-value "EVP_MD_CTX_FLAG_ONESHOT" int))

(define (openssl-type-error loc expected #!rest args)
  (abort
   (condition `(exn message ,(format "expected ~a, got" expected)
                    location ,loc
                    arguments ,args)
              '(type))))

(define (openssl-error loc #!rest args)
  (let* ((err (ERR_get_error))
         (message (format "error: library=~a, function=~a, reason=~a"
                          (or (ERR_lib_error_string err) "<unknown>")
                          (or (ERR_func_error_string err) "<unknown>")
                          (or (ERR_reason_error_string err) "<unknown>"))))
    (abort
     (condition `(exn message ,message location ,loc arguments ,args)
                '(i/o)
                `(openssl status #f)))))

(define (digest-list)
  ;; HACK: without this, the digest list is empty
  (foreign-code "OPENSSL_init_crypto(OPENSSL_INIT_ADD_ALL_DIGESTS, NULL);")
  (set! evp-digests '())
  ((foreign-safe-lambda* void ()
     "OBJ_NAME_do_all_sorted(OBJ_NAME_TYPE_MD_METH, (void(*)(const OBJ_NAME*,void*))EVP_DigestList_callback, NULL);"))
  (reverse evp-digests))

(define (digest-by-name name)
  (EVP_get_digestbyname name))

(define (digest-size digest)
  (EVP_MD_size digest))

(define (digest-block-size digest)
  (EVP_MD_block_size digest))

(define (digest-name digest)
  (EVP_MD_name digest))

(define max-digest-size EVP_MAX_MD_SIZE)

(define-record digest-context ptr)

(define (digest-context-free! context)
  (and-let* ((ctx (digest-context-ptr context)))
    (EVP_MD_CTX_free ctx)
    (digest-context-ptr-set! context #f)))

(define (digest-context-allocate!)
  (ERR_clear_error)
  (let ((ctx (EVP_MD_CTX_new)))
    (when (not ctx)
      (openssl-error 'digest-context-allocate!))
    (set-finalizer! (make-digest-context ctx) digest-context-free!)))

(define (digest-context-unwrap! context)
  (let ((ctx (digest-context-ptr context)))
    (when (not ctx)
      (openssl-type-error 'digest-context-unwrap! "valid context pointer"))
    ctx))

(define (digest-context-reset! context)
  (let ((ctx (digest-context-unwrap! context)))
    (ERR_clear_error)
    (when (not (EVP_MD_CTX_reset ctx))
      (openssl-error 'digest-context-reset!))
    (void)))

(define (digest-context-init! context digest #!key (oneshot #f))
  (let ((ctx (digest-context-unwrap! context)))
    (ERR_clear_error)
    (when (not (EVP_DigestInit_ex ctx digest #f))
      (openssl-error 'digest-context-init! (list digest)))
    (when oneshot
      (EVP_MD_CTX_set_flags ctx EVP_MD_CTX_FLAG_ONESHOT))
    (void)))

(define (digest-context-update! context blob)
  (let ((ctx (digest-context-unwrap! context))
        (size (blob-size blob)))
    (ERR_clear_error)
    (when (not (EVP_DigestUpdate ctx blob size))
      (openssl-error 'digest-context-update (list blob size)))
    (void)))

(define (digest-context-final! context)
  (let ((ctx (digest-context-unwrap! context))
        (blob (make-blob max-digest-size)))
    (ERR_clear_error)
    (let-location ((size int))
      (when (not (EVP_DigestFinal_ex ctx blob (location size)))
        (openssl-error 'digest-context-final!))
      (let ((str (make-string size)))
        (move-memory! blob str size)
        str))))

(define (string-digest digest str)
  (let ((context (digest-context-allocate!)))
    (digest-context-init! context digest oneshot: #t)
    (digest-context-update! context (string->blob str))
    (let ((ret (digest-context-final! context)))
      (digest-context-free! context)
      ret)))

(define (file-digest digest path)
  (let* ((buf-size 4096)
         (buf (make-blob buf-size))
         (context (digest-context-allocate!))
         (in (file-open path open/rdonly)))
    (digest-context-init! context digest)
    (let loop ()
      (let ((count (cadr (file-read in buf-size buf))))
        (when (positive? count)
          (digest-context-update! context buf)
          (loop))))
    (file-close in)
    (let ((ret (digest-context-final! context)))
      (digest-context-free! context)
      ret)))

(define (open-digest-port digest out #!rest options)
  (let ((context (digest-context-allocate!)))
    (apply digest-context-init! context digest options)
    (make-output-port
     (lambda (str)
       (digest-context-update! context (string->blob str)))
     (lambda ()
       (display (digest-context-final! context) out))
     (lambda ()
       (flush-output out)))))

)