;;;; message-digest.scm
;;;; Kon Lovett, Jan '06

;; Issues
;;
;; - Use of 'sys namespace procedures.
;;   - ##sys#size used since returns byte-length for blob & string.
;;
;; - Uses string type as a byte-vector - a kludge.
;;
;; - Uses 'context-info' to determine whether active context is "own" allocation or
;; callers. Again, a kludge.
;;
;; - Passes u8vector to update phase as a blob.
;;
;; - Could use core-inline for n-bit packing but need to disambiguate scheme
;; types in the C code. May not be worth it.

(module message-digest

  (;export
    ; Utilities
    ;FIXME this doesn't belong here
    pack-u8 pack-u16 pack-u32 pack-u64 pack-integer
    ; Parameters
    message-digest-chunk-size
    message-digest-chunk-read-maker
    message-digest-chunk-converter
    ; Algorithm API
    make-message-digest-primitive
    message-digest-primitive? check-message-digest-primitive error-message-digest-primitive
    message-digest-primitive-name
    message-digest-primitive-context-info
    message-digest-primitive-digest-length
    message-digest-primitive-init
    message-digest-primitive-update
    message-digest-primitive-final
    ; MD API
    message-digest? check-message-digest error-message-digest
    message-digest-algorithm
    initialize-message-digest
    finalize-message-digest
    message-digest-update-object
    message-digest-update-bytevector
    message-digest-update-blob
    message-digest-update-string
    message-digest-update-substring
    message-digest-update-u8vector
    message-digest-update-subu8vector
    message-digest-update-char
    message-digest-update-char-u8
    message-digest-update-char-be
    message-digest-update-char-le
    message-digest-update-u8
    message-digest-update-u16
    message-digest-update-u16-be
    message-digest-update-u16-le
    message-digest-update-u32
    message-digest-update-u32-be
    message-digest-update-u32-le
    message-digest-update-u64
    message-digest-update-u64-be
    message-digest-update-u64-le
    message-digest-update-procedure
    message-digest-update-port
    message-digest-update-file
    ;
    message-digest-object
    message-digest-string
    message-digest-blob
    message-digest-u8vector
    message-digest-file
    ; DEPRECATED
    string->hex ;available from string-hexadecimal
    byte-string->hexadecimal
    make-binary-message-digest
    make-message-digest
    message-digest-primitive-apply)

  (import
    scheme
    chicken
    foreign
    (only lolevel allocate free)
    srfi-4
    (only srfi-13 substring/shared)
    (only miscmacros while*)
    variable-item
    (only string-hexadecimal string->hex)
    (only type-checks
      define-check+error-type
      check-integer check-positive-integer
      check-blob check-string check-char
      check-input-port check-procedure)
    (only srfi-4-checks check-u8vector)
    (only type-errors
      error-half-closed-interval
      make-error-type-message
      error-argument-type signal-type-error
      define-error-type))

  (require-library
    lolevel srfi-4 srfi-13
    miscmacros
    variable-item
    string-hexadecimal
    srfi-4-checks type-checks type-errors)

;;; Byte-string Utilities

(define byte-string->hexadecimal string->hex)

;;; Integer Packing Utilities

;;

#>
/* start is not a general offset. bytes length <= size */
static void
pack_uint64( uint8_t *bytes, uint64_t n, int size, int direction, int start )
{
  int end;

  if (size == 1) {                        /* 1 byte */

    bytes[0] = n;

  } else if (direction == -1) {  /* Big endian */

    end = start - 1;

    bytes[start += size - 1] = n & 0xff;  /* 2 bytes */
    bytes[--start] = (n >> 8) & 0xff;

    if ((--start) != end) {               /* 4 bytes */

      bytes[start] = (n >> 16) & 0xff;
      bytes[--start] = (n >> 24) & 0xff;

      if ((--start) != end) {             /* 8 bytes */

        bytes[start] = (n >> 32) & 0xff;
        bytes[--start] = (n >> 40) & 0xff;
        bytes[--start] = (n >> 48) & 0xff;
        bytes[--start] = (n >> 56) & 0xff;
      }
    }

  } else {                /* Little endian */

    end = start + size;

    bytes[start] = n & 0xff;              /* 2 bytes */
    bytes[++start] = (n >> 8) & 0xff;

    if ((++start) != end) {               /* 4 bytes */

      bytes[start] = (n >> 16) & 0xff;
      bytes[++start] = (n >> 24) & 0xff;

      if ((++start) != end) {             /* 8 bytes */

        bytes[start] = (n >> 32) & 0xff;
        bytes[++start] = (n >> 40) & 0xff;
        bytes[++start] = (n >> 48) & 0xff;
        bytes[++start] = (n >> 56) & 0xff;
      }
    }
  }
}
<#

;;

; All the below primitive pack routines must return the supplied buffer object.

;; Pack an 8 bit integer

(define-inline (pack-u8/u8vector! u8vec n i)
  (u8vector-set! u8vec i n)
  u8vec )

(define-inline (pack-u8/bytevector! bv n i)
  (##core#inline "C_setbyte" bv i n) ;(bytevector-set! bv i n)
  bv )

(define-inline (pack-u8/blob! blb n i)
  (pack-u8/bytevector! blb n i) )

(define-inline (pack-u8/string! str n i)
  (pack-u8/bytevector! str n i) )

; Pack a 16, 32, or 64 bit integer with endian order

(define-inline (pack-u64/u8vector! u8vec n size direction start)
  ((foreign-lambda void "pack_uint64" nonnull-u8vector integer64 int int int)
     u8vec n size direction start)
  u8vec )

(define-inline (pack-u64/bytevector! bv n size direction start)
  ((foreign-lambda void "pack_uint64" nonnull-scheme-pointer integer64 int int int)
    bv n size direction start)
  bv )

(define-inline (pack-u64/blob! blb n size direction start)
  (pack-u64/bytevector! blb n size direction start) )

(define-inline (pack-u64/string! str n size direction start)
  (pack-u64/bytevector! str n size direction start) )

;;

(define (byte-order? obj)
  (and (memq obj '(big-endian be big little-endian le little))
       #t) )

(define-check+error-type byte-order byte-order? "symbol in {big-endian little-endian be le}")

#; ;UNUSED
(define (direction->byte-order n)
  (if (negative? n) 'big-endian
    'little-endian ) )

(define-inline (byte-order->direction order)
  (case order
    ((big-endian be big)        -1 )
    ((little-endian le little)  1 ) ) )

(define-error-type byte-buffer "u8vector, blob, string or symbol in {u8vector blob string}" )

(define-inline (check-byte-size loc obj)
  (unless (memq obj '(1 2 4 8))
    (error-argument-type loc obj "integer in {1 2 4 8}" 'size) )
  obj )

(define-constant MAX-BV-LEN 16777215) ; 2^24-1 is the maximum length of a bytevector

(define-inline (check-byte-buffer-size loc dessiz actsiz)
  (unless (fx<= dessiz actsiz)
    ;FIXME this message is too strong
    (error-half-closed-interval loc actsiz dessiz MAX-BV-LEN "byte-buffer size+start") )
  actsiz )

(define (ensure-byte-buffer loc size bufsel start)
  (let ((need-size (fx+ start size)))
    ; Cases ordered by a guess of probability
    (cond
      ((symbol? bufsel)
        (case bufsel
          ((string)     (values 'string (##sys#make-string need-size)) )
          ((blob)       (values 'blob (##sys#make-blob need-size)) )
          ((u8vector)   (values 'u8vector (make-u8vector need-size)) )
          (else
            (error-byte-buffer loc bufsel) ) ) )
      ((string? bufsel)
        (check-byte-buffer-size loc need-size (##sys#size bufsel))
        (values 'string bufsel) )
      ((blob? bufsel)
        (check-byte-buffer-size loc need-size (##sys#size bufsel))
        (values 'blob bufsel) )
      ((u8vector? bufsel)
        (check-byte-buffer-size loc need-size (u8vector-length bufsel))
        (values 'u8vector bufsel) )
      (else
        (error-byte-buffer loc bufsel) ) ) ) )

;;

(define (pack-u8 n #!key (bufsel 'string) (start 0))
  (check-integer 'pack-u8 n)
  (let-values (((typ obj) (ensure-byte-buffer 'pack-u8 1 bufsel start)))
    (case typ
      ((string)   (pack-u8/string! obj n start) )
      ((blob)     (pack-u8/blob! obj n start) )
      ((u8vector) (pack-u8/u8vector! obj n start) ) )
    obj ) )

;;

(define (*pack-integer loc n bufsel start order size)
  (check-integer loc n)
  (check-byte-order loc order)
  (let-values (((typ obj) (ensure-byte-buffer loc size bufsel start)))
    (let ((direction (byte-order->direction order)))
      (case typ
        ((string)   (pack-u64/string! obj n size direction start) )
        ((blob)     (pack-u64/blob! obj n size direction start) )
        ((u8vector) (pack-u64/u8vector! obj n size direction start) ) ) )
    obj ) )

;;

(define (pack-u16 n #!key (bufsel 'string) (start 0) (order (machine-byte-order)))
  (*pack-integer 'pack-u16 n bufsel start order 2) )

;;

(define (pack-u32 n #!key (bufsel 'string) (start 0) (order (machine-byte-order)))
  (*pack-integer 'pack-u32 n bufsel start order 4) )

;;

(define (pack-u64 n #!key (bufsel 'string) (start 0) (order (machine-byte-order)))
  (*pack-integer 'pack-u64 n bufsel start order 8) )

;;

(define (pack-integer n #!key (bufsel 'string) (start 0) (order (machine-byte-order)) (size 4))
  (check-byte-size 'pack-integer size)
  (if (fx= 1 size) (pack-u8 n #:buffer bufsel #:start start)
    (*pack-integer 'pack-integer n bufsel start order size) ) )

;;

(define (positive-integer? obj)
  (and (integer? obj) (positive? obj)) )

;;; Update Phase Helpers

;;

(define (default-chunk-read-maker in #!optional (size (message-digest-chunk-size)))
  (let ((u8buf (make-u8vector size)))
    (lambda ()
      (let ((len (read-u8vector! size u8buf in)))
        (and (positive? len)
             (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
               (u8vector->blob/shared u8buf) ) ) ) ) ) )

;;

(define-constant DEFAULT-CHUNK-SIZE 1024)

;;

(define (packed-vector->blob obj)
  (cond
    ((u8vector? obj)        (u8vector->blob/shared obj))
    ((s8vector? obj)        (s8vector->blob/shared obj))
    ((u16vector? obj)       (u16vector->blob/shared obj))
    ((s16vector? obj)       (s16vector->blob/shared obj))
    ((u32vector? obj)       (u32vector->blob/shared obj))
    ((s32vector? obj)       (s32vector->blob/shared obj))
    ((f32vector? obj)       (f32vector->blob/shared obj))
    ((f64vector? obj)       (f64vector->blob/shared obj))
    (else                   #f ) ) )

(define-inline (string->u8vector bs) (blob->u8vector/shared (string->blob bs)))

;;

(define-inline (chunk-convert obj)
  (and-let* ((cnv (message-digest-chunk-converter))) (cnv obj)) )

(define-inline (get-chunk-reader in) ((message-digest-chunk-read-maker) in))

(define-inline (get-update md)
  (message-digest-primitive-update (message-digest-algorithm md)) )

;;

(define (*do-bytes-update loc ctx src updt)
  (cond
    ; simple bytes
    ((or (string? src) (blob? src))
      (updt ctx src (##sys#size src)) )
    ; more complicated bytes
    ((or (packed-vector->blob src)
         (chunk-convert src))
      => (cut *do-bytes-update loc ctx <> updt) )
    ; too complicated bytes
    (else
      (signal-type-error loc "indigestible object" src) ) ) )

(define-inline (do-procedure-update loc md proc)
  (let ((updt (get-update md))
        (ctx (message-digest-context md)) )
    (while* (proc) (*do-bytes-update loc ctx it updt) ) ) )

(define-inline (do-port-update loc md in)
  (do-procedure-update loc md (get-chunk-reader in)) )

(define-inline (do-bytes-update loc md src)
  (let ((updt (get-update md))
        (ctx (message-digest-context md)) )
    (*do-bytes-update loc ctx src updt) ) )

(define (do-object-update loc md src)
  (cond
    ((input-port? src)    (do-port-update loc md src) )
    ((procedure? src)     (do-procedure-update loc md src) )
    (else                 (do-bytes-update loc md src) ) ) )

(define (error-result-form loc obj)
  (error-argument-type loc obj "symbol in {string hex blob u8vector}" 'result-form) )

(define (get-result-buffer loc len rt)
  (case rt
    ((string byte-string
      hexstring hex
      u8vector)
      (##sys#make-string len) )
    ((blob)
      (##sys#make-blob len) )
    (else
      (error-result-form loc rt) ) ) )

(define (get-result-form loc res rt)
  (case rt
    ((string byte-string
      blob)                 res )
    ((hexstring hex)        (string->hex res) )
    ((u8vector)             (string->u8vector res) )
    (else
      (error-result-form loc rt) ) ) )

;;; Message DIgest "Parameters"

;;

(define-checked-variable message-digest-chunk-size
  DEFAULT-CHUNK-SIZE
  positive-integer)

;;

(define-checked-variable message-digest-chunk-read-maker
  default-chunk-read-maker
  procedure)

;;

(define-variable message-digest-chunk-converter #f
  (lambda (obj)
    (if (or (not obj) (procedure? obj)) obj
      (error-argument-type 'message-digest-chunk-converter
        obj "#f or procedure"))))

;;; Message Digest Algorithm API

;;

(define-inline (check-message-digest-arguments loc ctx-info digest-len init update final)
  (unless (or (procedure? ctx-info) (positive-integer? ctx-info))
    (error-argument-type loc ctx-info "positive-integer or procedure" 'context-info) )
  (check-positive-integer loc digest-len 'digest-length)
  (check-procedure loc init 'digest-initializer)
  (check-procedure loc update 'digest-updater)
  (check-procedure loc final 'digest-finalizer) )

;;

(define-record-type message-digest-primitive
  (*make-message-digest-primitive ctxi digest-len init update final name)
  message-digest-primitive?
  (ctxi message-digest-primitive-context-info)
  (digest-len message-digest-primitive-digest-length)
  (init message-digest-primitive-init)
  (update message-digest-primitive-update)
  (final message-digest-primitive-final)
  (name message-digest-primitive-name) )

(define-check+error-type message-digest-primitive)

(define (make-message-digest-primitive ctx-info digest-len init update final
                                       #!optional (name (gensym "mdp")))
  (check-message-digest-arguments 'make-message-digest-primitive
    ctx-info digest-len init update final)
  (*make-message-digest-primitive
    ctx-info
    digest-len
    init update final
    name) )

;;; Message Digest API

;;

(define-record-type message-digest
  (*make-message-digest mdp ctx buf)
  message-digest?
  (mdp message-digest-algorithm)
  (ctx message-digest-context)
  (buf message-digest-buffer message-digest-buffer-set!) )

(define-check+error-type message-digest)

;;

(define-inline (get-context/message-digest-primitive mdp)
  (let ((ctx-info (message-digest-primitive-context-info mdp)))
    (if (procedure? ctx-info) (ctx-info)
        (set-finalizer! (allocate ctx-info) free) ) ) )

(define-inline (get-buffer/message-digest md size)
  (let ((buf (message-digest-buffer md)))
    (if (and buf (fx<= size (##sys#size buf))) buf
      (let ((buf (##sys#make-blob size)))
        (message-digest-buffer-set! md buf)
        buf ) ) ) )

(define-inline (*u64->blob! blb n order size)
  (if (fx= 1 size) (pack-u8/blob! blb n 0)
    (pack-u64/blob! blb n size (byte-order->direction order) 0) ) )

;;

(define-inline (*message-digest-update-string md str)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    ((message-digest-primitive-update mdp) ctx str (##sys#size str)) ) )

(define-inline (*message-digest-update-blob md blb)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    ((message-digest-primitive-update mdp) ctx blb (##sys#size blb)) ) )

(define-inline (*message-digest-update-u64 loc md n order size)
  (check-message-digest loc md)
  (check-integer loc n)
  (check-byte-order loc order)
  (*message-digest-update-blob md
    (*u64->blob! (get-buffer/message-digest md size) n order size)) )

;;

(define (initialize-message-digest mdp)
  (check-message-digest-primitive 'initialize-message-digest mdp)
  (let ((ctx (get-context/message-digest-primitive mdp)))
    ((message-digest-primitive-init mdp) ctx)
    (*make-message-digest mdp ctx #f) ) )

;;

(define (finalize-message-digest md #!optional (result-type 'hex))
  (check-message-digest 'finalize-message-digest md)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    (let ((res
          (get-result-buffer 'finalize-message-digest
            (message-digest-primitive-digest-length mdp) result-type)))
      ((message-digest-primitive-final mdp) ctx res)
      (get-result-form 'finalize-message-digest res result-type) ) ) )

;;

; string or blob only but it doesn't verify
(define (message-digest-update-bytevector md bv #!optional (len (##sys#size bv)))
  (check-message-digest 'message-digest-update-bytevector md)
  (let ((mdp (message-digest-algorithm md))
        (ctx (message-digest-context md)) )
    ((message-digest-primitive-update mdp) ctx bv len) ) )

;;

(define (message-digest-update-object md obj)
  (check-message-digest 'message-digest-update-object md)
  (do-object-update 'message-digest-update-object md obj) )

;;

(define (message-digest-update-blob md blb)
  (check-message-digest 'message-digest-update-blob md)
  (check-blob 'message-digest-update-blob blb)
  (*message-digest-update-blob md blb) )

;;

(define (message-digest-update-string md str)
  (check-message-digest 'message-digest-update-string md)
  (check-string 'message-digest-update-string str)
  (*message-digest-update-string md str) )

;;

(define (message-digest-update-substring md str start end)
  (check-message-digest 'message-digest-update-substring md)
  (check-string 'message-digest-update-substring str)
  (*message-digest-update-string md (substring/shared str start end)) )

;;

(define (message-digest-update-u8vector md u8vec)
  (check-message-digest 'message-digest-update-u8vector md)
  (check-u8vector 'message-digest-update-u8vector u8vec)
  (*message-digest-update-blob md (u8vector->blob/shared u8vec)) )

;;

(define (message-digest-update-subu8vector md u8vec start end)
  (check-message-digest 'message-digest-update-u8vector md)
  (check-u8vector 'message-digest-update-u8vector u8vec)
  (*message-digest-update-blob md (u8vector->blob/shared (subu8vector u8vec start end))) )

;;

#; ;Useful interface?
(define (message-digest-update-packed-vector md pkdvec)
  (check-message-digest 'message-digest-update-packed-vector md)
  (let ((blb (packed-vector->blob pkdvec)))
    (if blb (*message-digest-update-blob md blb)
        (error-argument-type 'message-digest-update-packed-vector pkdvec 'srfi-4-vector) ) ) )

;;

(define (message-digest-update-char-u8 md ch)
  (check-message-digest 'message-digest-update-char-u8 md)
  (check-char 'message-digest-update-char-u8 ch)
  ;FIXME this has too much overhead
  (*message-digest-update-blob md
    (pack-u8/blob!
      (get-buffer/message-digest md 1)
      (char->integer ch)
      0)) )

(define (message-digest-update-char md ch #!optional (order (machine-byte-order)))
  (check-char 'message-digest-update-char ch)
  (*message-digest-update-u64 'message-digest-update-char md (char->integer ch) order 4) )

(define (message-digest-update-char-be md ch)
  (check-char 'message-digest-update-char ch)
  (*message-digest-update-u64 'message-digest-update-char-be md (char->integer ch) 'be 4) )

(define (message-digest-update-char-le md ch)
  (check-char 'message-digest-update-char ch)
  (*message-digest-update-u64 'message-digest-update-char-le md (char->integer ch) 'le 4) )

;;

(define (message-digest-update-u8 md n)
  (check-message-digest 'message-digest-update-u8 md)
  (check-integer 'message-digest-update-u8 n)
  ;FIXME this has too much overhead
  (*message-digest-update-blob md (pack-u8/blob! (get-buffer/message-digest md 1) n 0)) )

(define (message-digest-update-u16 md n #!optional (order (machine-byte-order)))
  (*message-digest-update-u64 'message-digest-update-u16 md n order 2) )

(define (message-digest-update-u16-be md n)
  (*message-digest-update-u64 'message-digest-update-u16-be md n 'be 2) )

(define (message-digest-update-u16-le md n)
  (*message-digest-update-u64 'message-digest-update-u16-le md n 'le 2) )

(define (message-digest-update-u32 md n #!optional (order (machine-byte-order)))
  (*message-digest-update-u64 'message-digest-update-u32 md n order 4) )

(define (message-digest-update-u32-be md n)
  (*message-digest-update-u64 'message-digest-update-u32-be md n 'be 4) )

(define (message-digest-update-u32-le md n)
  (*message-digest-update-u64 'message-digest-update-u32-le md n 'le 4) )

(define (message-digest-update-u64 md n #!optional (order (machine-byte-order)))
  (*message-digest-update-u64 'message-digest-update-u64 md n order 8) )

(define (message-digest-update-u64-be md n)
  (*message-digest-update-u64 'message-digest-update-u64-be md n 'be 8) )

(define (message-digest-update-u64-le md n)
  (*message-digest-update-u64 'message-digest-update-u64-le md n 'le 8) )

;;

(define (message-digest-update-procedure md proc)
  (check-message-digest 'message-digest-update-procedure md)
  (check-procedure 'message-digest-update-procedure proc)
  (do-procedure-update 'message-digest-update-procedure md proc) )

;;

(define (message-digest-update-port md in)
  (check-message-digest 'message-digest-update-port md)
  (check-input-port 'message-digest-update-port in)
  (do-port-update 'message-digest-update-port md in) )

(define (message-digest-update-file md flnm)
  (check-message-digest 'message-digest-update-file md)
  (check-string 'message-digest-update-file flnm)
  (let ((in (open-input-file flnm)))
    (handle-exceptions exn
        (begin (close-input-port in) (abort exn))
      (do-port-update 'message-digest-update-file md in) )
    (close-input-port in) ) )

;;; Till completion API

(define (message-digest-object mdp obj #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-object md obj)
    (finalize-message-digest md result-type) ) )

(define (message-digest-string mdp str #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-string md str)
    (finalize-message-digest md result-type) ) )

(define (message-digest-blob mdp blb #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-blob md blb)
    (finalize-message-digest md result-type) ) )

(define (message-digest-u8vector mdp u8vec #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-u8vector md u8vec)
    (finalize-message-digest md result-type) ) )

(define (message-digest-file mdp flnm #!optional (result-type 'hex))
  (let ((md (initialize-message-digest mdp)))
    (message-digest-update-file md flnm)
    (finalize-message-digest md result-type) ) )

;;; Old API

;;

(define (message-digest-primitive-apply mdp src . args) ;DEPRECATED
  (message-digest-object mdp src 'string) )

;;

(define (make-binary-message-digest src ctx-info digest-len init update final
                                    #!optional (name 'make-binary-message-digest)) ;DEPRECATED
  (message-digest-object
    (make-message-digest-primitive ctx-info digest-len init update final name)
    src
    'string) )

;;

(define (make-message-digest src ctx-info digest-len init update final
                             #!optional (name 'make-message-digest)) ;DEPRECATED
  (message-digest-object
    (make-message-digest-primitive ctx-info digest-len init update final name)
    src
    'hex) )

) ;module message-digest