;; mzcrypto: crypto library for mzscheme
;; Copyright (C) 2007 Dimitris Vyzovitis <[email protected]>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
;; USA

(module libcrypto mzscheme
  (require-for-syntax "stx-util.ss")
  (require (lib "foreign.ss"))
  (unsafe!)

  (provide (all-defined))

  (define libcrypto 
    (case (system-type)
      ((windows) (ffi-lib "libeay32"))
      (else (ffi-lib "libcrypto"))))

  (define libssl 
    (case (system-type)
      ((windows) (ffi-lib "ssleay32"))
      (else (ffi-lib "libssl"))))

  (define *silent* #t)
  
  (define (make-failure-thunk sym)
    (lambda () 
      (unless *silent*
        (fprintf (current-error-port) 
                 "warning: unavailable foreign function: ~a~n" sym))
      (lambda x 
        (error sym "unavailable foreign function"))))

  (define-syntax (ffi-lambda stx)
    (define (make lib sym sig)
      (let ((fsym (->string (->datum sym))))
        #`(get-ffi-obj #,fsym #,lib #,sig (make-failure-thunk '#,sym))))
    (syntax-case stx ()
      ((_ sym sig)
       (make (->stx stx 'libcrypto) #'sym #'sig))
      ((_ lib sym sig)
       (make #'lib #'sym #'sig))))

  (define-syntax lambda/ffi
    (syntax-rules (: ->)
      ((_ lib (f args ...))
       (ffi-lambda lib f (_fun args ... -> _void)))
      ((_ lib (f args ...) -> type)
       (ffi-lambda lib f (_fun args ... -> type)))
      ((_ lib (f args ...) -> type : guard)
       (ffi-lambda lib f (_fun args ... -> (r : type) -> (guard 'f r))))
      ((_ (f args ...) rest ...)
       (lambda/ffi libcrypto (f args ...) rest ...))))
  
  (define-syntax define/ffi
    (syntax-rules ()
      ((_ (f args ...) rest ...)
       (define/ffi libcrypto (f args ...) rest ...))
      ((_ lib (f args ...) rest ...)
       (define f (lambda/ffi lib (f args ...) rest ...)))))

  ;; new/free pairs
  (define-syntax (define/alloc stx)
    (define (make lib sym)
      (let ((fsym (->datum sym)))
        (with-syntax
            ((new (->stx stx (make-symbol fsym "_new")))
             (free (->stx stx (make-symbol fsym "_free"))))
          #`(begin
              (define new
                (ffi-lambda #,lib new
                  (_fun -> (r : _pointer)
                        -> (if r r (error 'new "libcrypto: out of memory")))))
              (define free
                (ffi-lambda #,lib free 
                  (_fun _pointer -> _void)))))))

    (syntax-case stx()
      ((_ sym) 
       (make (->stx stx 'libcrypto) #'sym))
      ((_ lib sym) 
       (make #'lib #'sym))))

  ;; dynamic extent finalizer
  (define-syntax with-fini
    (syntax-rules ()
      ((_ fini body ...)
       (dynamic-wind
         void
         (lambda () body ...)
         (lambda () fini)))))
  
  (define-syntax let/fini
    (syntax-rules ()
      ((_ () body ...) (begin body ...))
      ((_ ((var exp) . rest) body ...)
       (let ((var exp))
         (let/fini rest body ...)))
      ((_ ((var exp fini) . rest) body ...)
       (let ((var exp))
         (with-fini (fini var)
           (let/fini rest body ...))))))

  ;; error finalizers
  (define-syntax with-error-fini
    (syntax-rules ()
      ((_ fini body ...)
       (with-handlers*
           (((lambda e #t) 
             (lambda (e) fini (raise e))))
         body ...))))

  (define-syntax let/error-fini
    (syntax-rules ()
      ((_ () body ...) (begin body ...))
      ((_ ((var exp) . rest) body ...)
       (let ((var exp))
         (let/error-fini rest body ...)))
      ((_ ((var exp fini) . rest) body ...)
       (let ((var exp))
         (with-error-fini (fini var)
           (let/error-fini rest body ...))))))

  (define-syntax push!
    (syntax-rules ()
      ((_ var obj) (set! var (cons-immutable obj var)))))

  (define call/values call-with-values)
  
  ;; initialization
  (let ()
    (define/ffi libcrypto (ERR_load_crypto_strings))
    (define/ffi libssl (OpenSSL_add_all_ciphers))
    (define/ffi libssl (OpenSSL_add_all_digests))
    
    (ERR_load_crypto_strings)
    (OpenSSL_add_all_ciphers)
    (OpenSSL_add_all_digests))
)