(declare
 (unit openssl)
 (uses lolevel srfi-13 srfi-34)
 (fixnum)
 (usual-integrations)

;(require-extension srfi-34)
; was macht srfi-18?
)

(module
 openssl
 (
  md2-digest
  md4-digest
  md5-digest
  sha-digest
  sha1-digest
  dss-digest
  dss1-digest
  ecdsa-digest
  sha224-digest
  sha256-digest
  sha384-digest
  sha512-digest
  ripemd160-digest
  md2-hmac
  md4-hmac
  md5-hmac
  sha-hmac
  sha1-hmac
  dss-hmac
  dss1-hmac
  ecdsa-hmac
  sha224-hmac
  sha256-hmac
  sha384-hmac
  sha512-hmac
  ripemd160-hmac
  ;;
  x509-read-file
  x509-read-string
  x509-subject
  x509-expiration-time
  x509-text
  )

(import scheme (except chicken with-exception-handler condition? promise?) foreign
	srfi-34 srfi-35 extras)

#>
#include <openssl/evp.h>
#include <openssl/hmac.h>
<#

;; initialization
(define (openssl-init)
  ;;((foreign-lambda void "OpenSSL_add_all_algorithms"))
  ;;((foreign-lambda void "OpenSSL_add_all_ciphers"))
  ((foreign-lambda void "OpenSSL_add_all_digests")))

(openssl-init)

(define-foreign-type EVP_MD_CTX* (nonnull-c-pointer "EVP_MD_CTX"))
(define-foreign-type EVP_MD*     (nonnull-c-pointer "EVP_MD"))
(define-foreign-type ENGINE*     (c-pointer "ENGINE"))

(define unpack! 
  (foreign-lambda*
   scheme-object ((scheme-object digest))
    "C_i_foreign_string_argumentp(digest); "
    "static char hex[] = \"0123456789abcdef\";

     C_char *in = C_c_string( digest ); 
     int i = C_header_size(digest) >> 1; 

     for( --i; i >= 0; i-- ) { 
       in[ 2 * i + 1 ] = hex[   in[i]        & 0x0f ] ; 
       in[ 2 * i     ] = hex[ ( in[i] >> 4 ) & 0x0f ] ; 
     } 
     return(digest);"))

;;; handling context
(define (EVP_MD_CTX_create)
  (let ((v ((foreign-lambda EVP_MD_CTX* "EVP_MD_CTX_create"))))
					;(printf "EVP_MD_CTX_create ~a\n" v)
    (and v (set-finalizer! v EVP_MD_CTX_destroy))
    v))

(define (EVP_MD_CTX_init ctx)
  ((foreign-lambda void "EVP_MD_CTX_init" EVP_MD_CTX*) ctx) ctx)

(define (EVP_MD_CTX_cleanup ctx)
  ((foreign-lambda void "EVP_MD_CTX_cleanup" EVP_MD_CTX*) ctx) #f)

(define (EVP_MD_CTX_destroy ctx)
  ;(printf "EVP_MD_CTX_destroy ~a\n" ctx)
  ((foreign-lambda void "EVP_MD_CTX_destroy" EVP_MD_CTX*) ctx) #f)

;;; handling digests
;; explicite named digest types
(define EVP_md-null (foreign-lambda EVP_MD* "EVP_md_null"))
(define EVP_md2 (foreign-lambda EVP_MD* "EVP_md2"))
(define EVP_md4 (foreign-lambda EVP_MD* "EVP_md4"))
(define EVP_md5 (foreign-lambda EVP_MD* "EVP_md5"))
(define EVP_sha (foreign-lambda EVP_MD* "EVP_sha"))
(define EVP_sha1 (foreign-lambda EVP_MD* "EVP_sha1"))
(define EVP_dss (foreign-lambda EVP_MD* "EVP_dss"))
(define EVP_dss1 (foreign-lambda EVP_MD* "EVP_dss1"))
(define EVP_ecdsa (foreign-lambda EVP_MD* "EVP_ecdsa"))
(define EVP_sha224 (foreign-lambda EVP_MD* "EVP_sha224"))
(define EVP_sha256 (foreign-lambda EVP_MD* "EVP_sha256"))
(define EVP_sha384 (foreign-lambda EVP_MD* "EVP_sha384"))
(define EVP_sha512 (foreign-lambda EVP_MD* "EVP_sha512"))
;(define EVP_mdc2 (foreign-lambda EVP_MD* "EVP_mdc2"))
(define EVP_ripemd160 (foreign-lambda EVP_MD* "EVP_ripemd160"))

;; get digest 
(define (EVP_get_digestbyname name)
 (or ((foreign-lambda EVP_MD* "EVP_get_digestbyname" c-string) name)
     (raise (sprintf 
	     "EVP_get_digestbyname: unknown message digest name ~A"
	     name))))

(define (EVP_get_digestbynid id)
  (EVP_get_digestbyname
   (or (OBJ_nid2sn id)
       (raise (sprintf 
	       "EVP_get_digestbynid: no valid message digest id ~A" id)))))

;; digest informations
(define OBJ_nid2sn (foreign-lambda c-string "OBJ_nid2sn" integer))
(define OBJ_nid2ln (foreign-lambda c-string "OBJ_nid2ln" integer))

(define (EVP_MD_type md)
  ((foreign-lambda* integer ((EVP_MD* md))
		    "return( EVP_MD_type( md ));") md))

(define (EVP_MD_name md)
  ((foreign-lambda* c-string ((EVP_MD* md))
		    "return( EVP_MD_name( md ));") md))

(define (EVP_MD_lname md) ; private
  ((foreign-lambda* c-string ((EVP_MD* md))
		    "return( OBJ_nid2ln( EVP_MD_type( md )));") md))

(define (EVP_MD_pkey_type md)
  ((foreign-lambda* integer ((EVP_MD* md))
		    "return( EVP_MD_pkey_type( md ));") md))

(define (EVP_MD_pkey_name md) ; private
  ((foreign-lambda* c-string ((EVP_MD* md))
		    "return( OBJ_nid2sn( EVP_MD_pkey_type( md )));") md))

(define (EVP_MD_pkey_lname md) ; private
  ((foreign-lambda* c-string ((EVP_MD* md))
		    "return( OBJ_nid2ln( EVP_MD_pkey_type( md )));") md))

(define (EVP_MD_size md)
  ((foreign-lambda* integer ((EVP_MD* md))
		    "return( EVP_MD_size( md ));") md))

(define (EVP_MD_block_size md)
  ((foreign-lambda* integer ((EVP_MD* md))
		    "return( EVP_MD_block_size( md ));") md))

(define (EVP_MD_CTX_md ctx)
  ((foreign-lambda* EVP_MD* ((EVP_MD_CTX* ctx))
		    "return( EVP_MD_CTX_md( ctx ));") ctx))

(define (EVP_MD_CTX_size ctx)
  ((foreign-lambda* integer ((EVP_MD_CTX* ctx))
		    "return( EVP_MD_CTX_size( ctx ));") ctx))

(define (EVP_MD_CTX_block_size ctx)
  ((foreign-lambda* integer ((EVP_MD_CTX* ctx))
		    "return( EVP_MD_CTX_block_size( ctx ));") ctx))

(define (EVP_MD_CTX_type ctx)
  ((foreign-lambda* integer ((EVP_MD_CTX* ctx))
		    "return( EVP_MD_CTX_type( ctx ));") ctx))

;; digest operations
(define (EVP_DigestInit ctx type . impl) ;; need EVP_MD_CTX_create or ~_init
  (if ((foreign-lambda*
	bool
	((EVP_MD_CTX* ctx) (EVP_MD* type) (ENGINE* impl))
	;; "C_i_foreign_pointer_argumentp(ctx); "
	"return( EVP_DigestInit_ex( ctx, type, impl));")
       ctx type (and (pair? impl) (car impl)))
      ctx
      (raise (sprintf "EVP_DigestInit failed for type ~A"
		      (EVP_MD_lname type)))))

(define (EVP_DigestUpdate ctx d cnt off)
  (if (or (fx> (fx+ off cnt) (string-length d))
	  (negative? off) (negative? cnt))
      (raise (sprintf 
	      "EVP_DigestUpdate: parameter out of range (~A..~A) [0..~A]"
	      off (fx+ off cnt) (string-length d))))
  (if ((foreign-lambda*
	scheme-object
	((EVP_MD_CTX* ctx) (scheme-object data) (integer cnt) (integer off))
	;; "C_i_foreign_pointer_argumentp(ctx); "
	"C_i_foreign_string_argumentp(data); "
        "return( EVP_DigestUpdate( ctx, C_c_string(data)+off, (size_t) cnt));")
       ctx d cnt off)
      ctx
      (raise (sprintf "EVP_DigestUpdate failed"))))

(define (EVP_DigestFinal ctx . packed)
  (let* ((packed (and (pair? packed) (car packed)))
	 (md (make-string (fx* (if packed 1 2) (EVP_MD_CTX_size ctx)))))
    (if (not ((foreign-lambda*
	       bool
	       ((EVP_MD_CTX* ctx) (scheme-object md))
	       "C_i_foreign_string_argumentp(md); "
	       "return( EVP_DigestFinal_ex( ctx, C_c_string(md), NULL));")
	      ctx md))
	(raise "EVP_DigestFinal failed"))
    (if packed md (unpack! md))))

(define (EVP_Digest data type . packed+impl)
  (let* ((packed (and (pair? packed+impl) (car packed+impl)))
	 (impl (and (pair? packed+impl) (pair? (cdr packed+impl))
		    (cadr packed+impl)))
	 (md (or ((foreign-lambda*
		   scheme-object
		   ((scheme-object data) (EVP_MD* type)
		    (scheme-object md) (ENGINE* impl))
		   "C_i_foreign_string_argumentp(data); "
		   "C_i_foreign_string_argumentp(md); "
		   "return( C_and( EVP_Digest(C_c_string(data),
                                                C_header_size(data),
                                                C_c_string(md),
                                                NULL, type, impl),
                                     md));")
		  data type
		  (make-string (* (if packed 1 2) (EVP_MD_size type)))
		  impl)
		 (raise "EVP_Digest failed"))))
    (if packed md (unpack! md))))

(define (EVP_MD_CTX_copy out in)
  (if ((foreign-lambda*
	bool
	((scheme-object out) (scheme-object in))
	"C_i_foreign_pointer_argumentp(out); "
	"C_i_foreign_pointer_argumentp(in); "
	"return( EVP_MD_CTX_copy((EVP_MD_CTX *)C_c_pointer_nn(out),
                                 (EVP_MD_CTX *)C_c_pointer_nn(in)));")
       out in)
      out
      (raise "EVP_MD_CTX_copy failed")))

;;; HMAC
;;; handling HMAC context

(define-foreign-type HMAC_CTX* (c-pointer "HMAC_CTX"))

(define (HMAC_size ctx)
  ((foreign-lambda* integer ((HMAC_CTX* ctx))
		    "return( HMAC_size( ctx ));") ctx))

(define (HMAC_CTX_create)
  (let ((v ((foreign-lambda* 
	     HMAC_CTX* ()
	     "HMAC_CTX *ctx=OPENSSL_malloc(sizeof *ctx); "
	     "HMAC_CTX_init(ctx); " "/* segfaults here if malloc fails */"
	     "return(ctx);"))))
    (set-finalizer! v HMAC_CTX_destroy)
    v))

(define (HMAC_CTX_init ctx)
  ((foreign-lambda void "HMAC_CTX_init" HMAC_CTX*) ctx) ctx)

(define (HMAC_CTX_cleanup ctx)
  ((foreign-lambda void "HMAC_CTX_cleanup" HMAC_CTX*) ctx) #f)

(define (HMAC_CTX_destroy ctx)
  ((foreign-lambda*
    void ((HMAC_CTX* ctx))
    "HMAC_CTX_cleanup(ctx); "
    "OPENSSL_free(ctx);") ctx) #f)

(define (HMAC_Init ctx key type . impl) ;; need HMAC_CTX_create or ~_init
  ((foreign-lambda
    void "HMAC_Init_ex" HMAC_CTX* c-string integer EVP_MD* ENGINE*)
   ctx key (string-length key) type (and (pair? impl) (car impl)))
  ctx)

(define (HMAC_Update ctx d cnt off)
  (if (or (fx> (fx+ off cnt) (string-length d))
	  (negative? off) (negative? cnt))
      (raise (sprintf 
	      "HMAC_Update: parameter out of range (~A..~A) [0..~A]"
	      off (fx+ off cnt) (string-length d))))
  ((foreign-lambda*
    void
    ((HMAC_CTX* ctx) (scheme-object data) (integer cnt) (integer off))
    "C_i_foreign_string_argumentp(data); "
    "HMAC_Update( ctx, C_c_string(data)+off, (size_t) cnt);")
   ctx d cnt off)
  ctx)

(define (HMAC_Final ctx . packed)
  (let* ((packed (and (pair? packed) (car packed)))
	 (md (make-string (* (if packed 1 2) (HMAC_size ctx)))))
    ((foreign-lambda*
      void ((HMAC_CTX* ctx) (scheme-object md))
      "C_i_foreign_string_argumentp(md); "
      "HMAC_Final( ctx, C_c_string(md), NULL);")
     ctx md)
    (if packed md (unpack! md))))

(define (HMAC data key type . packed)
  (let* ((packed (and (pair? packed) (car packed)))
	 (md (make-string (* (if packed 1 2) (EVP_MD_size type)))))
    ((foreign-lambda*
      void
      ((EVP_MD* type) (scheme-object key) (scheme-object d) (scheme-object md))
      "C_i_foreign_string_argumentp(key); "
      "C_i_foreign_string_argumentp(d); "
      "C_i_foreign_string_argumentp(md); "

      "HMAC( type, C_c_string(key), C_header_size(key),
                   C_c_string(d), C_header_size(d), C_c_string(md), NULL); ")
     type key data md)
    (if packed md (unpack! md))))

;;;
(define *string-digest-chunk-size* 512)
(define *port-digest-chunk-size* 4096)

(define (string-digest data type . packed+impl)
  (let ((cs *string-digest-chunk-size*)
	(packed (and (pair? packed+impl) (car packed+impl)))
	(impl (and (pair? packed+impl) (pair? (cdr packed+impl))
		   (cadr packed+impl))))
    (let loop ((ctx (EVP_DigestInit (EVP_MD_CTX_create) type impl))
	       (off 0) (rest (string-length data)))
      (if (< rest cs)
	  (EVP_DigestFinal (EVP_DigestUpdate ctx data rest off) packed)
	  (loop (EVP_DigestUpdate ctx data cs off) (+ off cs) (- rest cs))))))

(define (port-digest port type . packed+impl)
  (let ((cs *port-digest-chunk-size*)
	(packed (and (pair? packed+impl) (car packed+impl)))
	(impl (and (pair? packed+impl) (pair? (cdr packed+impl))
		   (cadr packed+impl))))
    (let loop ((ctx (EVP_DigestInit (EVP_MD_CTX_create) type impl))
	       (data (read-string cs port)))
      (let ((rest (string-length data)))
	(if (< rest cs)
	    (EVP_DigestFinal (EVP_DigestUpdate ctx data rest 0) packed)
	    (loop (EVP_DigestUpdate ctx data rest 0)
		  (read-string cs port)))))))

(define (string-hmac data key type . packed+impl)
 (let ((cs *string-digest-chunk-size*)
       (packed (and (pair? packed+impl) (car packed+impl)))
       (impl (and (pair? packed+impl) (pair? (cdr packed+impl))
		  (cadr packed+impl)))
       (rest (string-length data)))
   (let loop ((ctx (HMAC_Init (HMAC_CTX_create) key type impl))
	      (off 0) (rest (string-length data)))
     (if (< rest cs)
	 (HMAC_Final (HMAC_Update ctx data rest off) packed)
	 (loop (HMAC_Update ctx data cs off) (+ off cs) (- rest cs))))))

(define (port-hmac port key type . packed+impl)
  (let ((cs *port-digest-chunk-size*)
	(packed (and (pair? packed+impl) (car packed+impl)))
	(impl (and (pair? packed+impl) (pair? (cdr packed+impl))
		   (cadr packed+impl))))
    (let loop ((ctx (HMAC_Init (HMAC_CTX_create) key type impl))
	       (data (read-string cs port)))
      (let ((rest (string-length data)))
	(if (< rest cs)
	    (HMAC_Final (HMAC_Update ctx data rest 0) packed)
	    (loop (HMAC_Update ctx data rest 0)
		  (read-string cs port)))))))

#;(define-macro (define-digests . types)
  `(begin
     ,@(map
	(lambda (type)
	  (let* ((type (if (string? type) type (symbol->string type)))
		 (name (string->symbol (string-append  type "-digest")))
		 (EVP_ (string->symbol (string-append "EVP_" type))))
	    `(define ,name
	       (let ((type (,EVP_)))
		 (lambda (obj)
		   ((if (string? obj) string-digest port-digest) obj type))))))
	types)))

#;(define-digests
  md-null md2 md4 md5 sha sha1 dss dss1 ecdsa sha224 sha256 sha384 sha512 ripemd160)

(define
  md-null-digest
  (let
   ((type (EVP_md-null)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  md2-digest
  (let
   ((type (EVP_md2)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  md4-digest
  (let
   ((type (EVP_md4)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  md5-digest
  (let
   ((type (EVP_md5)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  sha-digest
  (let
   ((type (EVP_sha)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  sha1-digest
  (let
   ((type (EVP_sha1)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  dss-digest
  (let
   ((type (EVP_dss)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  dss1-digest
  (let
   ((type (EVP_dss1)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  ecdsa-digest
  (let
   ((type (EVP_ecdsa)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  sha224-digest
  (let
   ((type (EVP_sha224)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  sha256-digest
  (let
   ((type (EVP_sha256)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  sha384-digest
  (let
   ((type (EVP_sha384)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  sha512-digest
  (let
   ((type (EVP_sha512)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))
 (define
  ripemd160-digest
  (let
   ((type (EVP_ripemd160)))
   (lambda
    (obj)
    ((if (string? obj) string-digest port-digest) obj type))))

#;(define-macro (define-hmacs . types)
  `(begin
     ,@(map 
	(lambda (type)
	  (let* ((type (if (string? type) type (symbol->string type)))
		 (name (string->symbol (string-append  type "-hmac")))
		 (EVP_ (string->symbol (string-append "EVP_" type))))
	    `(define ,name
	       (let ((type (,EVP_)))
		 (lambda (obj key)
		   ((if (string? obj) string-hmac port-hmac) obj key type))))))
	types)))

#;(define-hmacs
  md-null md2 md4 md5 sha sha1 dss dss1 ecdsa sha224 sha256 sha384 sha512 ripemd160)

 (define
  md-null-hmac
  (let
   ((type (EVP_md-null)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  md2-hmac
  (let
   ((type (EVP_md2)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  md4-hmac
  (let
   ((type (EVP_md4)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  md5-hmac
  (let
   ((type (EVP_md5)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  sha-hmac
  (let
   ((type (EVP_sha)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  sha1-hmac
  (let
   ((type (EVP_sha1)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  dss-hmac
  (let
   ((type (EVP_dss)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  dss1-hmac
  (let
   ((type (EVP_dss1)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  ecdsa-hmac
  (let
   ((type (EVP_ecdsa)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  sha224-hmac
  (let
   ((type (EVP_sha224)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  sha256-hmac
  (let
   ((type (EVP_sha256)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  sha384-hmac
  (let
   ((type (EVP_sha384)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  sha512-hmac
  (let
   ((type (EVP_sha512)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))
 (define
  ripemd160-hmac
  (let
   ((type (EVP_ripemd160)))
   (lambda
    (obj key)
    ((if (string? obj) string-hmac port-hmac) obj key type))))


#>
#include <openssl/x509v3.h>
#include <openssl/pem.h>
#include <openssl/asn1.h>

/*
List:       openssl-users
Subject:    Re: time_t from  ASN1_TIME
From:       Jay Case <Jay.Case () worldnet ! att ! net>
Date:       2003-11-02 23:58:18

Messy hack, but here's what I arrived at. Please yell out if you smell 
anything too foul;

//==============================================================================
// Based on X509_cmp_time() for intitial buffer hacking.
//==============================================================================
*/
time_t
getTimeFromASN1(const ASN1_TIME * aTime)
{
	time_t lResult = 0;
	struct tm lTime;

	char lBuffer[24];
	char * pBuffer = lBuffer;

	size_t lTimeLength = aTime->length;
	char * pString = (char *)aTime->data;

	if (aTime->type == V_ASN1_UTCTIME)
	{
		if ((lTimeLength < 11) || (lTimeLength > 17))
                 {
                 	return 0;
                 }

		memcpy(pBuffer, pString, 10);
		pBuffer += 10;
		pString += 10;
	}
	else
	{
		if (lTimeLength < 13)
                 {
                 	return 0;
                 }

		memcpy(pBuffer, pString, 12);
		pBuffer += 12;
		pString += 12;
	}

	if ((*pString == 'Z') || (*pString == '-') || (*pString == '+'))
	{
		*(pBuffer++) = '0';
		*(pBuffer++) = '0';
	}
	else
	{
		*(pBuffer++) = *(pString++);
		*(pBuffer++) = *(pString++);
		// Skip any fractional seconds...
		if (*pString == '.')
		{
			pString++;
			while ((*pString >= '0') && (*pString <= '9'))
                         {
                         	pString++;
                         }
		}
	}

	*(pBuffer++) = 'Z';
	*(pBuffer++) = '\0';

	time_t lSecondsFromUCT;
	if (*pString == 'Z')
	{
		lSecondsFromUCT = 0;
	}
	else
	{
		if ((*pString != '+') && (pString[5] != '-'))
                 {
			return 0;
                 }

		lSecondsFromUCT = ((pString[1]-'0') * 10 + (pString[2]-'0')) * 60;
		lSecondsFromUCT += (pString[3]-'0') * 10 + (pString[4]-'0');
		if (*pString == '-')
		{
			lSecondsFromUCT = -lSecondsFromUCT;
		}
	}

	lTime.tm_sec  = ((lBuffer[10] - '0') * 10) + (lBuffer[11] - '0');
	lTime.tm_min  = ((lBuffer[8] - '0') * 10) + (lBuffer[9] - '0');
	lTime.tm_hour = ((lBuffer[6] - '0') * 10) + (lBuffer[7] - '0');
	lTime.tm_mday = ((lBuffer[4] - '0') * 10) + (lBuffer[5] - '0');
	lTime.tm_mon  = (((lBuffer[2] - '0') * 10) + (lBuffer[3] - '0')) - 1;
	lTime.tm_year = ((lBuffer[0] - '0') * 10) + (lBuffer[1] - '0');
         if (lTime.tm_year < 50)
         {
         	lTime.tm_year += 100; // RFC 2459
         }
	lTime.tm_wday = 0;
	lTime.tm_yday = 0;
	lTime.tm_isdst = 0;  // No DST adjustment requested

         lResult = mktime(&lTime);
         if ((time_t)-1 != lResult)
         {
         	if (0 != lTime.tm_isdst)
                 {
                 	lResult -= 3600;  // mktime may adjust for DST  (OS dependent)
                 }
         	lResult += lSecondsFromUCT;
         }
         else
         {
         	lResult = 0;
         }

	return lResult;
}



<#

(define-foreign-type X509*     (c-pointer "X509"))

(define (X509_free c)
  ((foreign-lambda void "X509_free" X509*) c) #f)

(define (x509-read-file fn)
  (let ((v ((foreign-lambda*
	     X509* ((c-string fn))
	     "X509 *c=NULL; FILE *f=fopen(fn, \"r\");\n"
	     "c=PEM_read_X509(f, NULL, NULL, NULL);"
	     "fclose(f);"
	     "return(c);")
	    fn)))
    (and v (set-finalizer! v X509_free))
    v))

(define (x509-read-string pem)
  (let ((v ((foreign-lambda*
	     X509* ((c-string pem) (integer n))
	     "X509 *c=NULL;"
	     "BIO *bio=BIO_new_mem_buf(pem, n);"
	     "c=PEM_read_bio_X509(bio, NULL, NULL, NULL);"
	     "BIO_free(bio);"
	     "return(c);")
	    pem (string-length pem))))
    (and v (set-finalizer! v X509_free))
    v))

(define (X509-subject x509)
  ((foreign-lambda*
	     c-string ((X509* x509))
	     "char buf[2025];"
	     "X509_NAME * name = X509_get_subject_name(x509);"
	     "X509_NAME_oneline(name, buf, sizeof(buf));"
	     ;; "X509_NAME_free(name);"
	     "return(buf);")
   x509))

(define (x509-subject x)
  (if (string? x) (set! x (x509-read-string x)))
  (and x (X509-subject x)))

(define (X509-expiration-time x509)
  ((foreign-lambda*
    long ((X509* x509))
    "ASN1_TIME *t = X509_get_notAfter(x509);"
    "return(getTimeFromASN1(t));")
   x509))

(define (x509-expiration-time x)
  (if (string? x) (set! x (x509-read-string x)))
  (and x (X509-expiration-time x)))

(define (X509-text x509)
  ((foreign-lambda*
    c-string ((X509* x509))
    "char buf[8192];"
    "BIO *bio=BIO_new(BIO_s_mem());"
    "BUF_MEM *p; size_t n;"
    "X509_print(bio, x509);"
    "BIO_get_mem_ptr(bio, &p);"
    "n = sizeof(buf)-1 < p->length ? sizeof(buf)-1 : p->length;"
    "memcpy(buf, p->data, n);"
    "buf[n]='\\0';"
    "BIO_free(bio);"
    "return(buf);")
   x509))

(define (x509-text x)
  (if (string? x) (set! x (x509-read-string x)))
  (and x (X509-text x)))

) ;; module openssl

(import (prefix openssl m:))
(define md5-digest m:md5-digest)
(define sha256-digest m:sha256-digest)

(define x509-read-file m:x509-read-file)
(define x509-read-string m:x509-read-string)
(define x509-subject m:x509-subject)
(define X509-text m:x509-text)
(define x509-expiration-time m:x509-expiration-time)

;; (define subtest
;;   (let ((count 0))
;;     (lambda (msg exp)
;;       (printf "Test ~A: ~A ~A\n" count msg (or (and exp "passed") "failed"))
;;       (set! count (+ count 1))
;;       exp)))

;; (define (test)
;;   (or (and 
;;        (subtest 
;; 	"unpack!"
;; 	(equal? "313233343536" (unpack! "123456......")))

;;        (subtest
;; 	"CTX handling"
;; 	(let ((ctx (EVP_MD_CTX_create)))
;; 	  (and (eq? (EVP_MD_CTX_init ctx) ctx)
;; 	       (eq? #f (EVP_MD_CTX_cleanup ctx))
;; 	       ;DANGER! (eq? #f (EVP_MD_CTX_destroy ctx))
;; 	       )))
;;       ;(subtest "(EVP_MD_CTX_cleanup #f)" (guard (ex (else #t)) (EVP_MD_CTX_cleanup #f)))
;;       ;(subtest "(EVP_MD_CTX_destroy #f)" (guard (ex (else #t)) (EVP_MD_CTX_destroy #f)))
;;        (subtest
;; 	"digest handling"
;; 	(and 
;; 	 ;;(subtest "md_null" (equal? (EVP_md_null) (EVP_get_digestbyname "md_null")))
;; 	 (subtest "md2" (equal? (EVP_md2) (EVP_get_digestbyname "md2")))
;; 	 (subtest "md4" (equal? (EVP_md4) (EVP_get_digestbyname "md4")))
;; 	 (subtest "md5" (equal? (EVP_md5) (EVP_get_digestbyname "md5")))
;; 	 (subtest "sha" (equal? (EVP_sha) (EVP_get_digestbyname "sha")))
;; 	 (subtest "sha1" (equal? (EVP_sha1) (EVP_get_digestbyname "sha1")))
;; 	 (subtest "dss" (equal? (EVP_dss) (EVP_get_digestbyname "DSA-SHA")))
;; 	 (subtest "dss1" (equal? (EVP_dss1) (EVP_get_digestbyname "dss1")))
;; 	 (subtest "ecdsa" (equal? (EVP_ecdsa) (EVP_get_digestbyname "ecdsa-with-SHA1")))
;; 	 (subtest "sha224" (equal? (EVP_sha224) (EVP_get_digestbyname "sha224")))
;; 	 (subtest "sha256" (equal? (EVP_sha256) (EVP_get_digestbyname "sha256")))
;; 	 (subtest "sha384" (equal? (EVP_sha384) (EVP_get_digestbyname "sha384")))
;; 	 (subtest "sha512" (equal? (EVP_sha512) (EVP_get_digestbyname "sha512")))
;; 	 (subtest "ripemd160" (equal? (EVP_ripemd160) (EVP_get_digestbyname "ripemd160")))

;; 	 (subtest "MD_name.." (equal? (EVP_MD_name (EVP_get_digestbyname "md2"))
;; 				      (OBJ_nid2sn (EVP_MD_type (EVP_md2)))))))
;;        (subtest
;; 	"digest operations"
;; 	(and
;; 	 (subtest
;; 	  "md5 line"
;; 	  (let ((msg "Hallo"))
;; 	    (equal?
;; 	     (EVP_DigestFinal
;; 	      (EVP_DigestUpdate 
;; 	       (EVP_DigestInit (EVP_MD_CTX_create) (EVP_md5))
;; 	       msg (string-length msg) 0))
;; 	     (EVP_Digest msg (EVP_get_digestbyname "md5")))))

;; 	 (subtest
;; 	  "string-digest 2*cs+99 sha512"
;; 	  (let ((msg (make-string (+ (* 2 *string-digest-chunk-size*) 99) #\a)))
;; 	    (equal? (string-digest msg (EVP_sha512))
;; 		    (EVP_Digest msg (EVP_get_digestbyname "sha512")))))

;; 	 (subtest
;; 	  "string-digest 1*cs sha256"
;; 	  (let ((msg (make-string *string-digest-chunk-size* #\b)))
;; 	    (equal? (string-digest msg (EVP_sha256))
;; 		    (EVP_Digest msg (EVP_get_digestbyname "sha256")))))

;; 	 (subtest
;; 	  "string-digest cs-1 md5"
;; 	  (let ((msg (make-string (- *string-digest-chunk-size* 1) #\c)))
;; 	    (equal? (string-digest msg (EVP_md5))
;; 		    (EVP_Digest msg (EVP_get_digestbyname "md5")))))

;; 	 (subtest
;; 	  "md5-digest -> fixed string"
;; 	  (equal? (md5-digest "a") "0cc175b9c0f1b6a831c399e269772661"))))

;;        (subtest
;; 	"HMAC CTX handling"
;; 	(let ((ctx (HMAC_CTX_create)))
;; 	  (and (eq? (HMAC_CTX_init ctx) ctx)
;; 	       (eq? #f (HMAC_CTX_cleanup ctx))
;; 	       ;;DANGER! (eq? #f (HMAC_CTX_destroy ctx))
;; 	       )))

;;        (subtest
;; 	"HMAC handling"
;; 	(let ((msg "Hallo"))
;; 	  (equal?
;; 	   (HMAC_Final
;; 	    (HMAC_Update
;; 	     (HMAC_Init (HMAC_CTX_create) "key" (EVP_md5))
;; 	     msg (string-length msg) 0))
;; 	   (HMAC msg "key" (EVP_md5)))))
;;        (subtest
;; 	"md5-hmac"
;; 	(let ((msg "Hallo"))
;; 	  (equal?
;; 	   (md5-hmac msg "key")
;; 	   (HMAC msg "key" (EVP_md5)))))
;;        (subtest
;; 	"string|port-digest"
;; 	(let ((msg (make-string (+ (* 2 *port-digest-chunk-size*) 99) #\a)))
;; 	  (and
;; 	   (equal? (md5-digest (open-input-string msg))
;; 		   (EVP_Digest msg (EVP_get_digestbyname "md5")))
;; 	   (equal? (md5-digest msg)
;; 		   (EVP_Digest msg (EVP_get_digestbyname "md5"))))))
;;        (subtest
;; 	"string|port-hmac"
;; 	(let ((msg (make-string (+ (* 2 *port-digest-chunk-size*) 99) #\a)))
;; 	  (and
;; 	   (equal? (md5-hmac (open-input-string msg) "key")
;; 		   (HMAC msg "key" (EVP_get_digestbyname "md5")))
;; 	   (equal? (md5-hmac msg "key")
;; 		   (HMAC msg "key" (EVP_get_digestbyname "md5"))))))
;;        )
;;       (error "test failed!")))

;; (for-each 
;;  (lambda (cmd) (if (equal? cmd "test") (test)))
;;  (command-line-arguments))