#!/usr/bin/env scheme-script
;; -*- mode: scheme; coding: utf-8 -*- !#
;; Print the checksum/hash of a file
;; Copyright © 2009, 2010, 2011, 2012 Göran Weinholt <goran@weinholt.se>

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
#!r6rs

(import (weinholt compression adler-32)
        (weinholt crypto sha-1)
        (weinholt crypto sha-2)
        (weinholt crypto md5)
        (weinholt crypto crc)
        (only (srfi :13 strings) string-join string-pad)
        (rnrs))

(define (checksum-port/hash make-state update! finish! ->string)
  (lambda (port)
    (let ((buflen #x100000))
      (let ((state (make-state))
            (data (make-bytevector buflen)))
        (let lp ()
          (let ((bytes-read (get-bytevector-n! port data 0 buflen)))
            (unless (eof-object? bytes-read)
              (update! state data 0 bytes-read)
              (lp))))
        (finish! state)
        (->string state)))))

(define (checksum-port/crc name init finish update self-test width)
  (when (eq? 'failure (self-test))
    (display name)
    (display " self test failed!\n" (current-error-port))
    (exit 1))
  (lambda (port)
    (let ((buflen #x100000))
      (let ((data (make-bytevector buflen)))
        (let lp ((state (init)))
          (let ((bytes-read (get-bytevector-n! port data 0 buflen)))
            (if (eof-object? bytes-read)
                (string-pad (number->string (finish state) 16)
                            (/ (width) 4) #\0)
                (lp (update state data 0 bytes-read)))))))))

(define algorithms
  (let-syntax ((import-crc
                (lambda (x)
                  (define (symcat name suffix)
                    (datum->syntax name (string->symbol (string-append
                                                         (symbol->string (syntax->datum name))
                                                         suffix))))
                  (syntax-case x ()
                    ((_ name) #`(let ()
                                  (define-crc name)
                                  (cons (symbol->string 'name)
                                        (lambda ()
                                          (checksum-port/crc 'name
                                                             #,(symcat #'name "-init")
                                                             #,(symcat #'name "-finish")
                                                             #,(symcat #'name "-update")
                                                             #,(symcat #'name "-self-test")
                                                             #,(symcat #'name "-width"))))))))))
    `(("md5" . ,(lambda () (checksum-port/hash make-md5 md5-update! md5-finish! md5->string)))
      ("sha-1" . ,(lambda () (checksum-port/hash make-sha-1 sha-1-update! sha-1-finish! sha-1->string)))
      ("sha-224" . ,(lambda () (checksum-port/hash make-sha-224 sha-224-update! sha-224-finish! sha-224->string)))
      ("sha-256" . ,(lambda () (checksum-port/hash make-sha-256 sha-256-update! sha-256-finish! sha-256->string)))
      ("sha-384" . ,(lambda () (checksum-port/hash make-sha-384 sha-384-update! sha-384-finish! sha-384->string)))
      ("sha-512" . ,(lambda () (checksum-port/hash make-sha-512 sha-512-update! sha-512-finish! sha-512->string)))
      ("adler-32" . ,(lambda () (checksum-port/crc 'adler-32 adler-32-init adler-32-finish adler-32-update
                                                   adler-32-self-test adler-32-width)))
      ,(import-crc crc-32)
      ,(import-crc crc-16)
      ,(import-crc crc-16/ccitt)
      ,(import-crc crc-32c)
      ,(import-crc crc-24)
      ,(import-crc crc-64)
      ,(import-crc crc-64/ecma-182))))

(unless (> (length (command-line)) 1)
  (display (string-append
            "Usage: checksum.sps algorithm filename ...\n\
\n\
The algorithm can be one of: "
            (string-join (map car algorithms) ", ")
            "\n")
           (current-error-port))
  (exit 1))

(let ((csum (cond ((assoc (string-downcase (cadr (command-line)))
                          algorithms)
                   => (lambda (a) ((cdr a))))
                  (else
                   (display "No such algorithm has been defined: "
                            (current-error-port))
                   (display (cadr (command-line)) (current-error-port))
                   (newline (current-error-port))
                   (exit 1)))))
  (do ((files (cddr (command-line)) (cdr files)))
      ((null? files))
    (display (call-with-port (open-file-input-port (car files)) csum))
    (display "  ")
    (display (car files))
    (newline)))
