;;
;; simple-md5 - Scheme wrapper for Colin Plumb's Public Domain md5 implementation, without dependencies
;;
;; All code in this egg is in the Public Domain
(module simple-md5 (string->md5sum file-md5sum)

(import scheme (chicken base) (chicken blob) (chicken file) (chicken foreign) (chicken file posix)
        memory-mapped-files srfi-13)

(foreign-declare "#include \"md5-base.c\"")

(define digest-length (foreign-value "MD5_DIGEST_SIZE" unsigned-int))
(define context-size (foreign-value "sizeof(struct MD5Context)" unsigned-int))

(define init (foreign-lambda void MD5Init scheme-pointer))
(define update (foreign-lambda void MD5Update scheme-pointer scheme-pointer unsigned-int))
(define raw-update (foreign-lambda void MD5Update scheme-pointer c-pointer unsigned-int))
(define final (foreign-lambda void MD5Final scheme-pointer scheme-pointer))

(define (string->md5sum str)
  (let ((str-size (string-length str))
        (ctxt (make-blob context-size))
        (digest (make-string digest-length)))
    (init ctxt)
    (unless (zero? str-size)
      (update ctxt str str-size))
    (final ctxt digest)
    (string-concatenate
     (map (lambda (c)
            (string-pad (number->string (char->integer c) 16) 2 #\0))
          (string->list digest)))))

;; From simple-sha1
(cond-expand
  ((and windows (not cygwin))
   (begin
     (define read-into-buffer
       (foreign-lambda* bool ((int fd) (scheme-pointer buffer) (integer size))
	 "C_return(read(fd, buffer, size) == size);"))
     (define (mapped-pointer fname fd size k)
       (let ((buffer (make-blob size)))
	 (unless (read-into-buffer fd buffer size)
	   (error 'sha1sum "can not read file" fname))
	 (k (location buffer) void)))))
  (else
   (define (mapped-pointer fname fd size k)
     (let* ((mmap (map-file-to-memory #f size prot/read map/shared fd))
	    (ptr (memory-mapped-file-pointer mmap)))
       (k ptr (cut unmap-file-from-memory mmap))))))


(define (file-md5sum fname)
  (and (file-exists? fname)
       (not (directory? fname))
       (let* ((fd (file-open fname open/rdonly))
	      (fsize (file-size fd))
	      (ctxt (make-blob context-size))
	      (digest (make-string digest-length)))
	 (init ctxt)
	 (unless (zero? fsize)
	   (mapped-pointer
	    fname fd fsize
	    (lambda (buffer cleanup)
	      (raw-update ctxt buffer fsize)
	      (cleanup))))
	 (final ctxt digest)
	 (file-close fd)
	 (string-concatenate
	  (map (lambda (c)
		 (string-pad (number->string (char->integer c) 16) 2 #\0))
	       (string->list digest))))))
)