;;;; simple-sha1.scm


(declare
  (fixnum)
  #;(not safe))


(module simple-sha1 (sha1sum string->sha1sum)

(import scheme chicken.base chicken.fixnum chicken.file chicken.file.posix chicken.foreign)
(import chicken.memory memory-mapped-files)

(foreign-declare "#include \"sha1-base.c\"")
(foreign-declare "#include <unistd.h>")

;;

(define-foreign-variable context-size int "sizeof(SHA1_CTX)")

(define starts (foreign-lambda void "SHA1Init" c-pointer))
(define update (foreign-lambda void "SHA1Update" c-pointer c-pointer int))
(define finish (foreign-lambda void "SHA1Final" c-pointer scheme-pointer))

(define-constant digest-length 20)

(define (char->hexdigits c)
  (let ((int (char->integer c)))
    (if (fx>= int 16)
        (number->string int 16)
        (string-append "0" (number->string int 16)))))

(define (string->sha1sum str)
  (let* ((str-size (string-length str))
         (ctxt (allocate context-size))
         (digest (make-string digest-length)))
    (starts ctxt)
    (unless (zero? str-size)
      (update ctxt (location str) str-size))
    (finish ctxt digest)
    (free ctxt)
    (apply string-append (map char->hexdigits (string->list digest)))))

(cond-expand
  ((and windows (not cygwin))
   (begin
     (define read-into-buffer
       (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
	 "C_return(read(fd, buffer, size) == size);"))
     (define (mapped-pointer fname fd size k)
       (let ((buffer (allocate size)))
	 (unless (read-into-buffer fd buffer size)
	   (free buffer)
	   (error 'sha1sum "can not read file" fname))
	 (k buffer (cut free buffer))))))
  (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 (sha1sum fname)
  (and (file-exists? fname)
       (not (directory? fname))
       (let* ((fd (file-open fname open/rdonly))
	      (fsize (file-size fd))
	      (ctxt (allocate context-size))
	      (digest (make-string digest-length)))
	 (starts ctxt)
	 (unless (zero? fsize)
	   (mapped-pointer
	    fname fd fsize
	    (lambda (buffer cleanup)
	      (update ctxt buffer fsize)
	      (cleanup))))
	 (finish ctxt digest)
	 (free ctxt)
	 (file-close fd)
	 (apply string-append (map char->hexdigits (string->list digest))))))

)