;; 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 error mzscheme
  (require (lib "foreign.ss")
           (only (lib "etc.ss") opt-lambda)
           (lib "and-let.ss" "srfi" "2"))
  (require "libcrypto.ss")
  
 (provide (all-defined))
  
 (define/ffi (ERR_get_error) -> _ulong)
 (define/ffi (ERR_peek_last_error) -> _ulong)
 (define/ffi (ERR_lib_error_string _ulong) -> _string)
 (define/ffi (ERR_func_error_string _ulong) -> _string)
 (define/ffi (ERR_reason_error_string _ulong) -> _string)

 (define (format-error e info)
   (let ((errstr 
          (and-let*
              ((le (ERR_lib_error_string e))
               (fe (ERR_func_error_string e))
               (re (ERR_reason_error_string e)))
            (format "~a [~a:~a:~a]"
                    (ERR_reason_error_string e)
                    (ERR_lib_error_string e) 
                    (ERR_func_error_string e) 
                    e))))
     (format "libcrypto error: ~a ~a"
             (if errstr errstr "?")
             (if info info ""))))

  (define raise-crypto-error
    (opt-lambda (where (info #f))
      (error where (format-error (ERR_get_error) info))))
  
  (define (check-error where r)
    (unless (> r 0)
      (raise-crypto-error where)))
  
  (define (pointer/error where r)
    (if r r (raise-crypto-error where "(null pointer)")))
  
  (define (int/error where r)
    (if (> r 0) r (raise-crypto-error where)))

  (define (int/error* where r)
    (if (< r 0) (raise-crypto-error where) r))
  
  (define (bool/error where r)
    (case r
      ((1) #t)
      ((0) #f)
      (else (raise-crypto-error where))))
  
  (define check-input-range 
    (case-lambda
      ((where bs maxlen)
       (unless (<= (bytes-length bs) maxlen)
         (error where "bad input range")))
      ((where bs start end)
       (unless (and (<= 0 start) (< start end) (<= end (bytes-length bs)))
         (error where "bad input range")))
      ((where bs start end maxlen)
       (unless (and (<= 0 start) (< start end) (<= end (bytes-length bs))
                    (<= (- end start) maxlen))
         (error where "bad input range")))))
  
  (define check-output-range 
    (case-lambda 
      ((where bs minlen)
       (when (immutable? bs)
         (error where "expects mutable bytes"))
       (unless (>= (bytes-length bs) minlen)
         (error where "bad output range")))
      ((where bs start end)
       (when (immutable? bs)
         (error where "expects mutable bytes"))
       (unless (and (<= 0 start) (< start end) (<= end (bytes-length bs)))
         (error where "bad output range")))
      ((where bs start end minlen)
       (when (immutable? bs)
         (error where "expects mutable bytes"))
       (unless (and (<= 0 start) (< start end) (<= end (bytes-length bs))
                    (>= (- end start) minlen))
         (error where "bad output range")))))
)