# along with this file; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-DISTCHECK_CONFIGURE_FLAGS = --enable-gtk-doc
+DISTCHECK_CONFIGURE_FLAGS = --enable-gtk-doc --with-guile-site-dir
SUBDIRS = lgl gl includes lib libextra src doc tests po
opt_profiler_mode=$enableval)
AC_MSG_RESULT($opt_profiler_mode)
+opt_guile_bindings=yes
+AC_MSG_CHECKING([whether building Guile bindings])
+AC_ARG_ENABLE(guile,
+ AS_HELP_STRING([--enable-guile], [build GNU Guile bindings]),
+opt_guile_bindings=$enableval)
+AC_MSG_RESULT($opt_guile_bindings)
+
+AC_ARG_WITH([--with-guile-site-dir],
+ [AS_HELP_STRING([--with-guile-site-dir],
+ [use the given directory as the Guile site (use with care)])])
+
AC_MSG_RESULT([***
*** Checking for compilation programs...
])
***]])
fi
+AM_CONDITIONAL(HAVE_GUILE, test "x$opt_guile_bindings" = "xyes")
+
+if test "x$opt_guile_bindings" = "xyes"; then
+ GUILE_PROGS
+ GUILE_FLAGS
+ AC_PATH_PROG([guile_snarf], [guile-snarf], [not-found])
+ if test "x$guile_snarf" = "xnot-found"; then
+ AC_MSG_ERROR([`guile-snarf' not found. Please install Guile 1.8.x or later.])
+ fi
+
+ case "x$with_guile_site_dir" in
+ x|xno)
+ # Use the default $(GUILE_SITE).
+ GUILE_SITE_DIR
+ ;;
+ xyes)
+ # Automatically derive $(GUILE_SITE) from $(pkgdatadir). This
+ # hack is used to allow `distcheck' to work (see
+ # `DISTCHECK_CONFIGURE_FLAGS' in the top-level `Makefile.am').
+ GUILE_SITE="${datadir}/guile/site"
+ AC_SUBST(GUILE_SITE)
+ ;;
+ *)
+ # Use the user-specified directory as $(GUILE_SITE).
+ GUILE_SITE="$with_guile_site_dir"
+ AC_SUBST(GUILE_SITE)
+ ;;
+ esac
+fi
+
+
AC_MSG_RESULT([***
*** Detecting compiler options...
])
src/Makefile src/x509/Makefile src/srp/Makefile src/openpgp/Makefile \
src/cfg/Makefile src/cfg/platon/Makefile src/cfg/platon/str/Makefile \
lib/libgnutls-config libextra/libgnutls-extra-config \
- lib/gnutls.pc libextra/gnutls-extra.pc])
+ lib/gnutls.pc libextra/gnutls-extra.pc
+ guile/Makefile guile/modules/Makefile
+ guile/src/Makefile guile/tests/Makefile])
+
+AC_CONFIG_FILES([guile/pre-inst-guile], [chmod +x guile/pre-inst-guile])
+
AC_OUTPUT
--- /dev/null
+# GNUTLS -- Guile bindings for GnuTLS.
+# Copyright (C) 2007 Free Software Foundation
+#
+# GNUTLS 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.
+#
+# GNUTLS 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 GNUTLS; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+SUBDIRS = modules src tests
--- /dev/null
+# GNUTLS -- Guile bindings for GnuTLS.
+# Copyright (C) 2007 Free Software Foundation
+#
+# GNUTLS 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.
+#
+# GNUTLS 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 GNUTLS; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+guilemoduledir = $(GUILE_SITE)
+
+nobase_dist_guilemodule_DATA = gnutls.scm gnutls/extra.scm
+
+documentation_modules = system/documentation/README \
+ system/documentation/c-snarf.scm \
+ system/documentation/output.scm
+
+EXTRA_DIST = gnutls/build/enums.scm gnutls/build/smobs.scm \
+ gnutls/build/utils.scm gnutls/build/priorities.scm \
+ $(documentation_modules)
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>
+
+(define-module (gnutls)
+ ;; Note: The export list must be manually kept in sync with the build
+ ;; system.
+ :export (;; versioning
+ gnutls-version
+
+ ;; sessions
+ session?
+ make-session bye handshake rehandshake
+ alert-get alert-send
+ session-cipher session-kx session-mac session-protocol
+ session-compression-method session-certificate-type
+ session-authentication-type session-server-authentication-type
+ session-client-authentication-type
+ session-peer-certificate-chain session-our-certificate-chain
+ set-session-transport-fd! set-session-transport-port!
+ set-session-credentials! set-server-session-certificate-request!
+
+ ;; anonymous credentials
+ anonymous-client-credentials? anonymous-server-credentials?
+ make-anonymous-client-credentials make-anonymous-server-credentials
+ set-anonymous-server-dh-parameters!
+
+ ;; certificate credentials
+ certificate-credentials? make-certificate-credentials
+ set-certificate-credentials-dh-parameters!
+ set-certificate-credentials-rsa-export-parameters!
+ set-certificate-credentials-x509-key-files!
+ set-certificate-credentials-x509-trust-file!
+ set-certificate-credentials-x509-crl-file!
+ set-certificate-credentials-x509-key-data!
+ set-certificate-credentials-x509-trust-data!
+ set-certificate-credentials-x509-crl-data!
+ set-certificate-credentials-x509-keys!
+ set-certificate-credentials-verify-limits!
+ set-certificate-credentials-verify-flags!
+ peer-certificate-status
+
+ ;; SRP credentials
+ srp-client-credentials? srp-server-credentials?
+ make-srp-client-credentials make-srp-server-credentials
+ set-srp-client-credentials!
+ set-srp-server-credentials-files!
+ server-session-srp-username
+ srp-base64-encode srp-base64-decode
+
+ ;; PSK credentials
+ psk-client-credentials? psk-server-credentials?
+ make-psk-client-credentials make-psk-server-credentials
+ set-psk-client-credentials!
+ set-psk-server-credentials-file!
+ server-session-psk-username
+
+ ;; priority functions
+ set-session-cipher-priority! set-session-mac-priority!
+ set-session-compression-method-priority!
+ set-session-kx-priority! set-session-protocol-priority!
+ set-session-certificate-type-priority!
+ set-session-default-priority! set-session-default-export-priority!
+
+ ;; DH
+ set-session-dh-prime-bits!
+ make-dh-parameters dh-parameters?
+ pkcs3-import-dh-parameters pkcs3-export-dh-parameters
+
+ ;; RSA
+ make-rsa-parameters rsa-parameters?
+ pkcs1-import-rsa-parameters pkcs1-export-rsa-parameters
+
+ ;; X.509
+ x509-certificate? x509-private-key?
+ import-x509-certificate x509-certificate-matches-hostname?
+ x509-certificate-dn x509-certificate-dn-oid
+ x509-certificate-issuer-dn x509-certificate-issuer-dn-oid
+ x509-certificate-signature-algorithm x509-certificate-version
+ x509-certificate-key-id x509-certificate-authority-key-id
+ x509-certificate-subject-key-id
+ x509-certificate-subject-alternative-name
+ x509-certificate-public-key-algorithm x509-certificate-key-usage
+ import-x509-private-key pkcs8-import-x509-private-key
+
+ ;; record layer
+ record-send record-receive!
+ session-record-port
+
+ ;; debugging
+ set-log-procedure! set-log-level!
+
+ ;; enum->string functions
+ cipher->string kx->string params->string credentials->string
+ mac->string digest->string compression-method->string
+ connection-end->string alert-level->string
+ alert-description->string handshake-description->string
+ certificate-status->string close-request->string
+ protocol->string certificate-type->string
+ x509-certificate-format->string
+ x509-subject-alternative-name->string pk-algorithm->string
+ sign-algorithm->string psk-key-format->string key-usage->string
+ certificate-verify->string error->string
+ cipher-suite->string
+
+ ;; enum values
+ cipher/null
+ cipher/arcfour cipher/arcfour-128
+ cipher/3des-cbc
+ cipher/aes-128-cbc cipher/rijndael-cbc cipher/rijndael-128-cbc
+ cipher/aes-256-cbc cipher/rijndael-256-cbc
+ cipher/arcfour-40
+ cipher/rc2-40-cbc
+ cipher/des-cbc
+ kx/rsa
+ kx/dhe-dss
+ kx/dhe-rsa
+ kx/anon-dh
+ kx/srp
+ kx/rsa-export
+ kx/srp-rsa
+ kx/srp-dss
+ kx/psk
+ kx/dhe-dss
+ params/rsa-export
+ params/dh
+ credentials/certificate
+ credentials/anon
+ credentials/anonymous
+ credentials/srp
+ credentials/psk
+ credentials/ia
+ mac/unknown
+ mac/null
+ mac/md5
+ mac/sha1
+ mac/rmd160
+ mac/md2
+ digest/null
+ digest/md5
+ digest/sha1
+ digest/rmd160
+ digest/md2
+ compression-method/null
+ compression-method/deflate
+ compression-method/lzo
+ connection-end/server
+ connection-end/client
+ alert-level/warning
+ alert-level/fatal
+ alert-description/close-notify
+ alert-description/unexpected-message
+ alert-description/bad-record-mac
+ alert-description/decryption-failed
+ alert-description/record-overflow
+ alert-description/decompression-failure
+ alert-description/handshake-failure
+ alert-description/ssl3-no-certificate
+ alert-description/bad-certificate
+ alert-description/unsupported-certificate
+ alert-description/certificate-revoked
+ alert-description/certificate-expired
+ alert-description/certificate-unknown
+ alert-description/illegal-parameter
+ alert-description/unknown-ca
+ alert-description/access-denied
+ alert-description/decode-error
+ alert-description/decrypt-error
+ alert-description/export-restriction
+ alert-description/protocol-version
+ alert-description/insufficient-security
+ alert-description/internal-error
+ alert-description/user-canceled
+ alert-description/no-renegotiation
+ alert-description/unsupported-extension
+ alert-description/certificate-unobtainable
+ alert-description/unrecognized-name
+ alert-description/unknown-srp-username
+ alert-description/missing-srp-username
+ alert-description/inner-application-failure
+ alert-description/inner-application-verification
+ handshake-description/hello-request
+ handshake-description/client-hello
+ handshake-description/server-hello
+ handshake-description/certificate-pkt
+ handshake-description/server-key-exchange
+ handshake-description/certificate-request
+ handshake-description/server-hello-done
+ handshake-description/certificate-verify
+ handshake-description/client-key-exchange
+ handshake-description/finished
+ certificate-status/invalid
+ certificate-status/revoked
+ certificate-status/signer-not-found
+ certificate-status/signer-not-ca
+ certificate-status/insecure-algorithm
+ certificate-request/ignore
+ certificate-request/request
+ certificate-request/require
+ close-request/rdwr
+ close-request/wr
+ protocol/ssl-3
+ protocol/tls-1.0
+ protocol/tls-1.1
+ protocol/version-unknown
+ certificate-type/x509
+ certificate-type/openpgp
+ x509-certificate-format/der
+ x509-certificate-format/pem
+ x509-subject-alternative-name/dnsname
+ x509-subject-alternative-name/rfc822name
+ x509-subject-alternative-name/uri
+ x509-subject-alternative-name/ipaddress
+ pk-algorithm/rsa
+ pk-algorithm/dsa
+ pk-algorithm/unknown
+ sign-algorithm/unknown
+ sign-algorithm/rsa-sha1
+ sign-algorithm/dsa-sha1
+ sign-algorithm/rsa-md5
+ sign-algorithm/rsa-md2
+ sign-algorithm/rsa-rmd160
+ psk-key-format/raw
+ psk-key-format/hex
+ key-usage/digital-signature
+ key-usage/non-repudiation
+ key-usage/key-encipherment
+ key-usage/data-encipherment
+ key-usage/key-agreement
+ key-usage/key-cert-sign
+ key-usage/crl-sign
+ key-usage/encipher-only
+ key-usage/decipher-only
+ certificate-verify/disable-ca-sign
+ certificate-verify/allow-x509-v1-ca-crt
+ certificate-verify/allow-x509-v1-ca-certificate
+ certificate-verify/do-not-allow-same
+ certificate-verify/allow-any-x509-v1-ca-crt
+ certificate-verify/allow-any-x509-v1-ca-certificate
+ certificate-verify/allow-sign-rsa-md2
+ certificate-verify/allow-sign-rsa-md5
+
+ error/success
+ error/unknown-compression-algorithm
+ error/unknown-cipher-type
+ error/large-packet
+ error/unsupported-version-packet
+ error/unexpected-packet-length
+ error/invalid-session
+ error/fatal-alert-received
+ error/unexpected-packet
+ error/warning-alert-received
+ error/error-in-finished-packet
+ error/unexpected-handshake-packet
+ error/unknown-cipher-suite
+ error/unwanted-algorithm
+ error/mpi-scan-failed
+ error/decryption-failed
+ error/memory-error
+ error/decompression-failed
+ error/compression-failed
+ error/again
+ error/expired
+ error/db-error
+ error/srp-pwd-error
+ error/insufficient-credentials
+ error/insuficient-credentials
+ error/insufficient-cred
+ error/insuficient-cred
+ error/hash-failed
+ error/base64-decoding-error
+ error/mpi-print-failed
+ error/rehandshake
+ error/got-application-data
+ error/record-limit-reached
+ error/encryption-failed
+ error/pk-encryption-failed
+ error/pk-decryption-failed
+ error/pk-sign-failed
+ error/x509-unsupported-critical-extension
+ error/key-usage-violation
+ error/no-certificate-found
+ error/invalid-request
+ error/short-memory-buffer
+ error/interrupted
+ error/push-error
+ error/pull-error
+ error/received-illegal-parameter
+ error/requested-data-not-available
+ error/pkcs1-wrong-pad
+ error/received-illegal-extension
+ error/internal-error
+ error/dh-prime-unacceptable
+ error/file-error
+ error/too-many-empty-packets
+ error/unknown-pk-algorithm
+ error/init-libextra
+ error/library-version-mismatch
+ error/no-temporary-rsa-params
+ error/lzo-init-failed
+ error/no-compression-algorithms
+ error/no-cipher-suites
+ error/openpgp-getkey-failed
+ error/pk-sig-verify-failed
+ error/illegal-srp-username
+ error/srp-pwd-parsing-error
+ error/no-temporary-dh-params
+ error/asn1-element-not-found
+ error/asn1-identifier-not-found
+ error/asn1-der-error
+ error/asn1-value-not-found
+ error/asn1-generic-error
+ error/asn1-value-not-valid
+ error/asn1-tag-error
+ error/asn1-tag-implicit
+ error/asn1-type-any-error
+ error/asn1-syntax-error
+ error/asn1-der-overflow
+ error/openpgp-trustdb-version-unsupported
+ error/openpgp-uid-revoked
+ error/certificate-error
+ error/x509-certificate-error
+ error/certificate-key-mismatch
+ error/unsupported-certificate-type
+ error/x509-unknown-san
+ error/openpgp-fingerprint-unsupported
+ error/x509-unsupported-attribute
+ error/unknown-hash-algorithm
+ error/unknown-pkcs-content-type
+ error/unknown-pkcs-bag-type
+ error/invalid-password
+ error/mac-verify-failed
+ error/constraint-error
+ error/warning-ia-iphf-received
+ error/warning-ia-fphf-received
+ error/ia-verify-failed
+ error/base64-encoding-error
+ error/incompatible-gcrypt-library
+ error/incompatible-crypto-library
+ error/incompatible-libtasn1-library
+ error/openpgp-keyring-error
+ error/x509-unsupported-oid
+ error/random-failed
+ error/unimplemented-feature))
+
+(load-extension "libguile-gnutls-v-0" "scm_init_gnutls")
+
+;; Renaming.
+(define protocol/ssl-3 protocol/ssl3)
+(define protocol/tls-1.0 protocol/tls1-0)
+(define protocol/tls-1.1 protocol/tls1-1)
+
+;; Aliases.
+(define credentials/anonymous credentials/anon)
+(define cipher/rijndael-256-cbc cipher/aes-256-cbc)
+(define cipher/rijndael-128-cbc cipher/aes-128-cbc)
+(define cipher/rijndael-cbc cipher/aes-128-cbc)
+(define cipher/arcfour-128 cipher/arcfour)
+(define certificate-verify/allow-any-x509-v1-ca-certificate
+ certificate-verify/allow-any-x509-v1-ca-crt)
+(define certificate-verify/allow-x509-v1-ca-certificate
+ certificate-verify/allow-x509-v1-ca-crt)
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 3394732c-d9fa-48dd-a093-9fba3a325b8b
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>
+
+(define-module (gnutls build enums)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-9)
+ :use-module (gnutls build utils)
+
+ :export (make-enum-type enum-type-subsystem enum-type-value-alist
+ enum-type-c-type enum-type-get-name-function
+ enum-type-automatic-get-name-function
+ enum-type-smob-name
+ enum-type-to-c-function enum-type-from-c-function
+
+ output-enum-smob-definitions output-enum-definitions
+ output-enum-declarations
+ output-enum-definition-function output-c->enum-converter
+ output-enum->c-converter
+
+ %cipher-enum %mac-enum %compression-method-enum %kx-enum
+ %protocol-enum %certificate-type-enum
+
+ %gnutls-enums %gnutls-extra-enums))
+
+;;;
+;;; This module helps with the creation of bindings for the C enumerate
+;;; types. It aims at providing strong typing (i.e., one cannot use an
+;;; enumerate value of the wrong type) along with authenticity checks (i.e.,
+;;; values of a given enumerate type cannot be forged---for instance, one
+;;; cannot use some random integer as an enumerate value). Additionally,
+;;; Scheme enums representing the same C enum value should be `eq?'.
+;;;
+;;; To that end, Scheme->C conversions are optimized (a simple
+;;; `SCM_SMOB_DATA'), since that is the most common usage pattern.
+;;; Conversely, C->Scheme conversions take time proportional to the number of
+;;; value in the enum type.
+;;;
+
+\f
+;;;
+;;; Enumeration tools.
+;;;
+
+(define-record-type <enum-type>
+ (%make-enum-type subsystem c-type enum-map get-name value-prefix)
+ enum-type?
+ (subsystem enum-type-subsystem)
+ (enum-map enum-type-value-alist)
+ (c-type enum-type-c-type)
+ (get-name enum-type-get-name-function)
+ (value-prefix enum-type-value-prefix))
+
+
+(define (make-enum-type subsystem c-type values get-name . value-prefix)
+ ;; Return a new enumeration type.
+ (let ((value-prefix (if (null? value-prefix)
+ #f
+ (car value-prefix))))
+ (%make-enum-type subsystem c-type
+ (make-enum-map subsystem values value-prefix)
+ get-name value-prefix)))
+
+
+(define (make-enum-map subsystem values value-prefix)
+ ;; Return an alist mapping C enum values (strings) to Scheme symbols.
+ (define (value-symbol->string value)
+ (string-upcase (scheme-symbol->c-name value)))
+
+ (define (make-c-name value)
+ (case value-prefix
+ ((#f)
+ ;; automatically derive the C value name.
+ (string-append "GNUTLS_" (string-upcase (symbol->string subsystem))
+ "_" (value-symbol->string value)))
+ (else
+ (string-append value-prefix (value-symbol->string value)))))
+
+ (map (lambda (value)
+ (cons (make-c-name value) value))
+ values))
+
+(define (enum-type-smob-name enum)
+ ;; Return the C name of the smob type for ENUM.
+ (string-append "scm_tc16_gnutls_"
+ (scheme-symbol->c-name (enum-type-subsystem enum))
+ "_enum"))
+
+(define (enum-type-smob-list enum)
+ ;; Return the name of the C variable holding a list of value (SMOBs) for
+ ;; ENUM. This list is used when converting from C to Scheme.
+ (string-append "scm_gnutls_"
+ (scheme-symbol->c-name (enum-type-subsystem enum))
+ "_enum_values"))
+
+(define (enum-type-to-c-function enum)
+ ;; Return the name of the C `scm_to_' function for ENUM.
+ (string-append "scm_to_gnutls_"
+ (scheme-symbol->c-name (enum-type-subsystem enum))))
+
+(define (enum-type-from-c-function enum)
+ ;; Return the name of the C `scm_from_' function for ENUM.
+ (string-append "scm_from_gnutls_"
+ (scheme-symbol->c-name (enum-type-subsystem enum))))
+
+(define (enum-type-automatic-get-name-function enum)
+ ;; Return the name of an automatically-generated C function that returns a
+ ;; string describing the given enum value of type ENUM.
+ (string-append "scm_gnutls_"
+ (scheme-symbol->c-name (enum-type-subsystem enum))
+ "_to_c_string"))
+
+\f
+;;;
+;;; C code generation.
+;;;
+
+(define (output-enum-smob-definitions enum port)
+ (let ((smob (enum-type-smob-name enum))
+ (get-name (enum-type-get-name-function enum)))
+ (format port "SCM_GLOBAL_SMOB (~a, \"~a\", 0);~%"
+ smob (enum-type-subsystem enum))
+ (format port "SCM ~a = SCM_EOL;~%"
+ (enum-type-smob-list enum))
+
+ (if (not (string? get-name))
+ ;; Generate a "get name" function.
+ (output-enum-get-name-function enum port))
+
+ ;; Generate the printer and `->string' function.
+ (let ((get-name (or get-name
+ (enum-type-automatic-get-name-function enum))))
+ (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
+ ;; SMOB printer.
+ (format port "SCM_SMOB_PRINT (~a, ~a_print, obj, port, pstate)~%{~%"
+ smob subsystem)
+ (format port " scm_puts (\"#<gnutls-~a-enum \", port);~%"
+ (enum-type-subsystem enum))
+ (format port " scm_puts (~a (~a (obj, 1, \"~a_print\")), port);~%"
+ get-name (enum-type-to-c-function enum) subsystem)
+ (format port " scm_puts (\">\", port);~%")
+ (format port " return 1;~%")
+ (format port "}~%")
+
+ ;; Enum-to-string.
+ (format port "SCM_DEFINE (scm_gnutls_~a_to_string, \"~a->string\", "
+ subsystem (enum-type-subsystem enum))
+ (format port "1, 0, 0,~%")
+ (format port " (SCM enumval),~%")
+ (format port " \"Return a string describing ")
+ (format port "@var{enumval}, a @code{~a} value.\")~%"
+ (enum-type-subsystem enum))
+ (format port "#define FUNC_NAME s_scm_gnutls_~a_to_string~%"
+ subsystem)
+ (format port "{~%")
+ (format port " ~a c_enum;~%"
+ (enum-type-c-type enum))
+ (format port " const char *c_string;~%")
+ (format port " c_enum = ~a (enumval, 1, FUNC_NAME);~%"
+ (enum-type-to-c-function enum))
+ (format port " c_string = ~a (c_enum);~%"
+ get-name)
+ (format port " return (scm_from_locale_string (c_string));~%")
+ (format port "}~%")
+ (format port "#undef FUNC_NAME~%")))))
+
+(define (output-enum-definitions enum port)
+ ;; Output to PORT the Guile C code that defines the values of ENUM-ALIST.
+ (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
+ (format port " enum_values = SCM_EOL;~%")
+ (for-each (lambda (c+scheme)
+ (format port " SCM_NEWSMOB (enum_smob, ~a, "
+ (enum-type-smob-name enum))
+ (format port "(scm_t_bits) ~a);~%"
+ (car c+scheme))
+ (format port " enum_values = scm_cons (enum_smob, ")
+ (format port "enum_values);~%")
+ (format port " scm_c_define (\"~a\", enum_smob);~%"
+ (symbol-append (enum-type-subsystem enum) '/
+ (cdr c+scheme))))
+ (enum-type-value-alist enum))
+ (format port " ~a = scm_permanent_object (enum_values);~%"
+ (enum-type-smob-list enum))))
+
+(define (output-enum-declarations enum port)
+ ;; Issue header file declarations needed for the inline functions that
+ ;; handle ENUM values.
+ (format port "SCM_API scm_t_bits ~a;~%"
+ (enum-type-smob-name enum))
+ (format port "SCM_API SCM ~a;~%"
+ (enum-type-smob-list enum)))
+
+(define (output-enum-definition-function enums port)
+ ;; Output a C function that does all the `scm_c_define ()' for the enums
+ ;; listed in ENUMS.
+ (format port "static inline void~%scm_gnutls_define_enums (void)~%{~%")
+ (format port " SCM enum_values, enum_smob;~%")
+ (for-each (lambda (enum)
+ (output-enum-definitions enum port))
+ enums)
+ (format port "}~%"))
+
+(define (output-c->enum-converter enum port)
+ ;; Output a C->Scheme converted for ENUM. This works by walking the list
+ ;; of available enum values (SMOBs) for ENUM and then returning the
+ ;; matching SMOB, so that users can then compare enums using `eq?'. While
+ ;; this may look inefficient, this shouldn't be a problem since (i)
+ ;; conversion in that direction is rarely needed and (ii) the number of
+ ;; values per enum is expected to be small.
+ (format port "static inline SCM~%~a (~a c_obj)~%{~%"
+ (enum-type-from-c-function enum)
+ (enum-type-c-type enum))
+ (format port " SCM pair, result = SCM_BOOL_F;~%")
+ (format port " for (pair = ~a; scm_is_pair (pair); "
+ (enum-type-smob-list enum))
+ (format port "pair = SCM_CDR (pair))~%")
+ (format port " {~%")
+ (format port " SCM enum_smob;~%")
+ (format port " enum_smob = SCM_CAR (pair);~%")
+ (format port " if ((~a) SCM_SMOB_DATA (enum_smob) == c_obj)~%"
+ (enum-type-c-type enum))
+ (format port " {~%")
+ (format port " result = enum_smob;~%")
+ (format port " break;~%")
+ (format port " }~%")
+ (format port " }~%")
+ (format port " return result;~%")
+ (format port "}~%"))
+
+(define (output-enum->c-converter enum port)
+ (let* ((c-type-name (enum-type-c-type enum))
+ (subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
+
+ (format port
+ "static inline ~a~%~a (SCM obj, unsigned pos, const char *func)~%"
+ c-type-name (enum-type-to-c-function enum))
+ (format port "#define FUNC_NAME func~%")
+ (format port "{~%")
+ (format port " SCM_VALIDATE_SMOB (pos, obj, ~a);~%"
+ (string-append "gnutls_" subsystem "_enum"))
+ (format port " return ((~a) SCM_SMOB_DATA (obj));~%"
+ c-type-name)
+ (format port "}~%")
+ (format port "#undef FUNC_NAME~%")))
+
+(define (output-enum-get-name-function enum port)
+ ;; Output a C function that, when passed a C ENUM value, returns a C string
+ ;; representing that value.
+ (let ((function (enum-type-automatic-get-name-function enum)))
+ (format port
+ "static const char *~%~a (~a c_obj)~%"
+ function (enum-type-c-type enum))
+ (format port "{~%")
+ (format port " static const struct ")
+ (format port "{ ~a value; const char *name; } "
+ (enum-type-c-type enum))
+ (format port "table[] =~%")
+ (format port " {~%")
+ (for-each (lambda (c+scheme)
+ (format port " { ~a, \"~a\" },~%"
+ (car c+scheme) (cdr c+scheme)))
+ (enum-type-value-alist enum))
+ (format port " };~%")
+ (format port " unsigned i;~%")
+ (format port " const char *name = NULL;~%")
+ (format port " for (i = 0; i < ~a; i++)~%"
+ (length (enum-type-value-alist enum)))
+ (format port " {~%")
+ (format port " if (table[i].value == c_obj)~%")
+ (format port " {~%")
+ (format port " name = table[i].name;~%")
+ (format port " break;~%")
+ (format port " }~%")
+ (format port " }~%")
+ (format port " return (name);~%")
+ (format port "}~%")))
+
+\f
+;;;
+;;; Actual enumerations.
+;;;
+
+(define %cipher-enum
+ (make-enum-type 'cipher "gnutls_cipher_algorithm_t"
+ '(null arcfour 3des-cbc aes-128-cbc aes-256-cbc
+ arcfour-40 rc2-40-cbc des-cbc)
+ "gnutls_cipher_get_name"))
+
+(define %kx-enum
+ (make-enum-type 'kx "gnutls_kx_algorithm_t"
+ '(rsa dhe-dss dhe-rsa anon-dh srp rsa-export
+ srp-rsa srp-dss psk dhe-dss)
+ "gnutls_kx_get_name"))
+
+(define %params-enum
+ (make-enum-type 'params "gnutls_params_type_t"
+ '(rsa-export dh)
+ #f))
+
+(define %credentials-enum
+ (make-enum-type 'credentials "gnutls_credentials_type_t"
+ '(certificate anon srp psk ia)
+ #f
+ "GNUTLS_CRD_"))
+
+(define %mac-enum
+ (make-enum-type 'mac "gnutls_mac_algorithm_t"
+ '(unknown null md5 sha1 rmd160 md2)
+ "gnutls_mac_get_name"))
+
+(define %digest-enum
+ (make-enum-type 'digest "gnutls_digest_algorithm_t"
+ '(null md5 sha1 rmd160 md2)
+ #f
+ "GNUTLS_DIG_"))
+
+(define %compression-method-enum
+ (make-enum-type 'compression-method "gnutls_compression_method_t"
+ '(null deflate lzo)
+ "gnutls_compression_get_name"
+ "GNUTLS_COMP_"))
+
+(define %connection-end-enum
+ (make-enum-type 'connection-end "gnutls_connection_end_t"
+ '(server client)
+ #f
+ "GNUTLS_"))
+
+(define %alert-level-enum
+ (make-enum-type 'alert-level "gnutls_alert_level_t"
+ '(warning fatal)
+ #f
+ "GNUTLS_AL_"))
+
+(define %alert-description-enum
+ (make-enum-type 'alert-description "gnutls_alert_description_t"
+ '(close-notify unexpected-message bad-record-mac
+decryption-failed record-overflow decompression-failure handshake-failure
+ssl3-no-certificate bad-certificate unsupported-certificate
+certificate-revoked certificate-expired certificate-unknown illegal-parameter
+unknown-ca access-denied decode-error decrypt-error export-restriction
+protocol-version insufficient-security internal-error user-canceled
+no-renegotiation unsupported-extension certificate-unobtainable
+unrecognized-name unknown-srp-username missing-srp-username
+inner-application-failure inner-application-verification)
+ #f
+ "GNUTLS_A_"))
+
+(define %handshake-description-enum
+ (make-enum-type 'handshake-description "gnutls_handshake_description_t"
+ '(hello-request client-hello server-hello certificate-pkt
+ server-key-exchange certificate-request server-hello-done
+ certificate-verify client-key-exchange finished)
+ #f
+ "GNUTLS_HANDSHAKE_"))
+
+(define %certificate-status-enum
+ (make-enum-type 'certificate-status "gnutls_certificate_status_t"
+ '(invalid revoked signer-not-found signer-not-ca
+ insecure-algorithm)
+ #f
+ "GNUTLS_CERT_"))
+
+(define %certificate-request-enum
+ (make-enum-type 'certificate-request "gnutls_certificate_request_t"
+ '(ignore request require)
+ #f
+ "GNUTLS_CERT_"))
+
+;; XXX: Broken naming convention.
+; (define %openpgp-key-status-enum
+; (make-enum-type 'openpgp-key-status "gnutls_openpgp_key_status_t"
+; '(key fingerprint)
+; #f
+; "GNUTLS_OPENPGP_"))
+
+(define %close-request-enum
+ (make-enum-type 'close-request "gnutls_close_request_t"
+ '(rdwr wr) ;; FIXME: Check the meaning and rename
+ #f
+ "GNUTLS_SHUT_"))
+
+(define %protocol-enum
+ (make-enum-type 'protocol "gnutls_protocol_t"
+ '(ssl3 tls1-0 tls1-1 version-unknown)
+ #f
+ "GNUTLS_"))
+
+(define %certificate-type-enum
+ (make-enum-type 'certificate-type "gnutls_certificate_type_t"
+ '(x509 openpgp)
+ "gnutls_certificate_type_get_name"
+ "GNUTLS_CRT_"))
+
+(define %x509-certificate-format-enum
+ (make-enum-type 'x509-certificate-format "gnutls_x509_crt_fmt_t"
+ '(der pem)
+ #f
+ "GNUTLS_X509_FMT_"))
+
+(define %x509-subject-alternative-name-enum
+ (make-enum-type 'x509-subject-alternative-name
+ "gnutls_x509_subject_alt_name_t"
+ '(dnsname rfc822name uri ipaddress)
+ #f
+ "GNUTLS_SAN_"))
+
+(define %pk-algorithm-enum
+ (make-enum-type 'pk-algorithm "gnutls_pk_algorithm_t"
+ '(unknown rsa dsa)
+ "gnutls_pk_algorithm_get_name"
+ "GNUTLS_PK_"))
+
+(define %sign-algorithm-enum
+ (make-enum-type 'sign-algorithm "gnutls_sign_algorithm_t"
+ '(unknown rsa-sha1 dsa-sha1 rsa-md5 rsa-md2
+ rsa-rmd160)
+ "gnutls_sign_algorithm_get_name"
+ "GNUTLS_SIGN_"))
+
+(define %psk-key-format-enum
+ (make-enum-type 'psk-key-format "gnutls_psk_key_flags"
+ '(raw hex)
+ #f
+ "GNUTLS_PSK_KEY_"))
+
+(define %key-usage-enum
+ ;; Not actually an enum on the C side.
+ (make-enum-type 'key-usage "int"
+ '(digital-signature non-repudiation key-encipherment
+ data-encipherment key-agreement key-cert-sign
+ crl-sign encipher-only decipher-only)
+ #f
+ "GNUTLS_KEY_"))
+
+(define %certificate-verify-enum
+ (make-enum-type 'certificate-verify "gnutls_certificate_verify_flags"
+ '(disable-ca-sign allow-x509-v1-ca-crt
+ do-not-allow-same allow-any-x509-v1-ca-crt
+ allow-sign-rsa-md2 allow-sign-rsa-md5)
+ #f
+ "GNUTLS_VERIFY_"))
+
+(define %error-enum
+ (make-enum-type 'error "int"
+ '(
+success
+unknown-compression-algorithm
+unknown-cipher-type
+large-packet
+unsupported-version-packet
+unexpected-packet-length
+invalid-session
+fatal-alert-received
+unexpected-packet
+warning-alert-received
+error-in-finished-packet
+unexpected-handshake-packet
+unknown-cipher-suite
+unwanted-algorithm
+mpi-scan-failed
+decryption-failed
+memory-error
+decompression-failed
+compression-failed
+again
+expired
+db-error
+srp-pwd-error
+insufficient-credentials
+insuficient-credentials
+insufficient-cred
+insuficient-cred
+hash-failed
+base64-decoding-error
+mpi-print-failed
+rehandshake
+got-application-data
+record-limit-reached
+encryption-failed
+pk-encryption-failed
+pk-decryption-failed
+pk-sign-failed
+x509-unsupported-critical-extension
+key-usage-violation
+no-certificate-found
+invalid-request
+short-memory-buffer
+interrupted
+push-error
+pull-error
+received-illegal-parameter
+requested-data-not-available
+pkcs1-wrong-pad
+received-illegal-extension
+internal-error
+dh-prime-unacceptable
+file-error
+too-many-empty-packets
+unknown-pk-algorithm
+init-libextra
+library-version-mismatch
+no-temporary-rsa-params
+lzo-init-failed
+no-compression-algorithms
+no-cipher-suites
+openpgp-getkey-failed
+pk-sig-verify-failed
+illegal-srp-username
+srp-pwd-parsing-error
+no-temporary-dh-params
+asn1-element-not-found
+asn1-identifier-not-found
+asn1-der-error
+asn1-value-not-found
+asn1-generic-error
+asn1-value-not-valid
+asn1-tag-error
+asn1-tag-implicit
+asn1-type-any-error
+asn1-syntax-error
+asn1-der-overflow
+openpgp-trustdb-version-unsupported
+openpgp-uid-revoked
+certificate-error
+x509-certificate-error
+certificate-key-mismatch
+unsupported-certificate-type
+x509-unknown-san
+openpgp-fingerprint-unsupported
+x509-unsupported-attribute
+unknown-hash-algorithm
+unknown-pkcs-content-type
+unknown-pkcs-bag-type
+invalid-password
+mac-verify-failed
+constraint-error
+warning-ia-iphf-received
+warning-ia-fphf-received
+ia-verify-failed
+base64-encoding-error
+incompatible-gcrypt-library
+incompatible-crypto-library
+incompatible-libtasn1-library
+openpgp-keyring-error
+x509-unsupported-oid
+random-failed
+unimplemented-feature)
+ "gnutls_strerror"
+ "GNUTLS_E_"))
+
+
+(define %openpgp-key-format-enum
+ (make-enum-type 'openpgp-key-format "gnutls_openpgp_key_fmt"
+ '(raw base64)
+ #f
+ "GNUTLS_OPENPGP_FMT_"))
+
+
+(define %gnutls-enums
+ ;; All enums.
+ (list %cipher-enum %kx-enum %params-enum %credentials-enum %mac-enum
+ %digest-enum %compression-method-enum %connection-end-enum
+ %alert-level-enum %alert-description-enum %handshake-description-enum
+ %certificate-status-enum %certificate-request-enum
+ %close-request-enum %protocol-enum %certificate-type-enum
+ %x509-certificate-format-enum %x509-subject-alternative-name-enum
+ %pk-algorithm-enum %sign-algorithm-enum
+ %psk-key-format-enum %key-usage-enum %certificate-verify-enum
+ %error-enum))
+
+(define %gnutls-extra-enums
+ ;; All enums for GnuTLS-extra (GPL).
+ (list %openpgp-key-format-enum))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 9e3eb6bb-61a5-4e85-861f-1914ab9677b0
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>
+
+(define-module (gnutls build priorities)
+ :use-module (srfi srfi-9)
+ :use-module (gnutls build utils)
+ :use-module (gnutls build enums)
+ :export (output-session-set-priority-function %gnutls-priorities))
+
+;;;
+;;; Helpers to generate the `gnutls_XXX_set_priority ()' wrappers.
+;;;
+
+
+\f
+;;;
+;;; Priority functions.
+;;;
+
+(define-record-type <session-priority>
+ (make-session-priority enum-type c-setter)
+ session-priority?
+ (enum-type session-priority-enum-type)
+ (c-setter session-priority-c-setter)
+ (c-getter session-priority-c-getter))
+
+\f
+;;;
+;;; C code generation.
+;;;
+
+(define (output-session-set-priority-function priority port)
+ (let* ((enum (session-priority-enum-type priority))
+ (setter (session-priority-c-setter priority))
+ (c-name (scheme-symbol->c-name (enum-type-subsystem enum))))
+ (format port "SCM_DEFINE (scm_gnutls_set_session_~a_priority_x,~%"
+ c-name)
+ (format port " \"set-session-~a-priority!\", 2, 0, 0,~%"
+ (enum-type-subsystem enum))
+ (format port " (SCM session, SCM items),~%")
+ (format port " \"Use @var{items} (a list) as the list of \"~%")
+ (format port " \"preferred ~a for @var{session}.\")~%"
+ (enum-type-subsystem enum))
+ (format port "#define FUNC_NAME s_scm_gnutls_set_session_~a_priority_x~%"
+ c-name)
+ (format port "{~%")
+ (format port " gnutls_session_t c_session;~%")
+ (format port " ~a *c_items;~%"
+ (enum-type-c-type enum))
+ (format port " long int c_len, i;~%")
+ (format port " c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);~%")
+ (format port " SCM_VALIDATE_LIST_COPYLEN (2, items, c_len);~%")
+ (format port " c_items = (~a *) alloca (sizeof (* c_items) * c_len);~%"
+ (enum-type-c-type enum))
+ (format port " for (i = 0; i < c_len; i++, items = SCM_CDR (items))~%")
+ (format port " c_items[i] = ~a (SCM_CAR (items), 2, FUNC_NAME);~%"
+ (enum-type-to-c-function enum))
+ (format port " c_items[c_len] = (~a) 0;~%"
+ (enum-type-c-type enum))
+ (format port " ~a (c_session, (int *) c_items);~%"
+ setter)
+ (format port " return SCM_UNSPECIFIED;~%")
+ (format port "}~%")
+ (format port "#undef FUNC_NAME~%")))
+
+\f
+;;;
+;;; Actual priority functions.
+;;;
+
+(define %gnutls-priorities
+ (map make-session-priority
+ (list %cipher-enum %mac-enum %compression-method-enum %kx-enum
+ %protocol-enum %certificate-type-enum)
+ (list "gnutls_cipher_set_priority" "gnutls_mac_set_priority"
+ "gnutls_compression_set_priority" "gnutls_kx_set_priority"
+ "gnutls_protocol_set_priority"
+ "gnutls_certificate_type_set_priority")))
+
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: a9cdcc92-6dcf-4d63-afec-6dc16334e379
--- /dev/null
+;;; Help produce Guile wrappers for GnuTLS types.
+;;;
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>
+
+(define-module (gnutls build smobs)
+ :use-module (srfi srfi-9)
+ :use-module (srfi srfi-13)
+ :use-module (gnutls build utils)
+ :export (make-smob-type smob-type-tag smob-free-function
+ smob-type-predicate-scheme-name
+ smob-type-from-c-function smob-type-to-c-function
+
+ output-smob-type-definition output-smob-type-declaration
+ output-smob-type-predicate
+ output-c->smob-converter output-smob->c-converter
+
+ %gnutls-smobs %gnutls-extra-smobs))
+
+\f
+;;;
+;;; SMOB types.
+;;;
+
+(define-record-type <smob-type>
+ (%make-smob-type c-name scm-name free-function)
+ smob-type?
+ (c-name smob-type-c-name)
+ (scm-name smob-type-scheme-name)
+ (free-function smob-type-free-function))
+
+(define (make-smob-type c-name scm-name . free-function)
+ (%make-smob-type c-name scm-name
+ (if (null? free-function)
+ (string-append "gnutls_"
+ (scheme-symbol->c-name scm-name)
+ "_deinit")
+ (car free-function))))
+
+(define (smob-type-tag type)
+ ;; Return the name of the C variable holding the type tag for TYPE.
+ (string-append "scm_tc16_gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+
+(define (smob-type-predicate-scheme-name type)
+ ;; Return a string denoting the Scheme name of TYPE's type predicate.
+ (string-append (symbol->string (smob-type-scheme-name type)) "?"))
+
+(define (smob-type-to-c-function type)
+ ;; Return the name of the C `scm_to_' function for SMOB.
+ (string-append "scm_to_gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+
+(define (smob-type-from-c-function type)
+ ;; Return the name of the C `scm_from_' function for SMOB.
+ (string-append "scm_from_gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+
+\f
+;;;
+;;; C code generation.
+;;;
+
+(define (output-smob-type-definition type port)
+ (format port "SCM_GLOBAL_SMOB (~a, \"~a\", 0);~%"
+ (smob-type-tag type)
+ (smob-type-scheme-name type))
+
+ (format port "SCM_SMOB_FREE (~a, ~a_free, obj)~%{~%"
+ (smob-type-tag type)
+ (scheme-symbol->c-name (smob-type-scheme-name type)))
+ (format port " ~a c_obj;~%"
+ (smob-type-c-name type))
+ (format port " c_obj = (~a) SCM_SMOB_DATA (obj);~%"
+ (smob-type-c-name type))
+ (format port " ~a (c_obj);~%"
+ (smob-type-free-function type))
+ (format port " return 0;~%")
+ (format port "}~%"))
+
+(define (output-smob-type-declaration type port)
+ ;; Issue a header file declaration for the SMOB type tag of TYPE.
+ (format port "SCM_API scm_t_bits ~a;~%"
+ (smob-type-tag type)))
+
+(define (output-smob-type-predicate type port)
+ (define (texi-doc-string)
+ (string-append "Return true if @var{obj} is of type @code{"
+ (symbol->string (smob-type-scheme-name type))
+ "}."))
+
+ (let ((c-name (string-append "scm_gnutls_"
+ (string-map (lambda (chr)
+ (if (char=? chr #\-)
+ #\_
+ chr))
+ (symbol->string
+ (smob-type-scheme-name type)))
+ "_p")))
+ (format port "SCM_DEFINE (~a, \"~a\", 1, 0, 0,~%"
+ c-name (smob-type-predicate-scheme-name type))
+ (format port " (SCM obj),~%")
+ (format port " \"~a\")~%"
+ (texi-doc-string))
+ (format port "#define FUNC_NAME s_~a~%"
+ c-name)
+ (format port "{~%")
+ (format port " return (scm_from_bool (SCM_SMOB_PREDICATE (~a, obj)));~%"
+ (smob-type-tag type))
+ (format port "}~%#undef FUNC_NAME~%")))
+
+(define (output-c->smob-converter type port)
+ (format port "static inline SCM~%~a (~a c_obj)~%{~%"
+ (smob-type-from-c-function type)
+ (smob-type-c-name type))
+ (format port " SCM_RETURN_NEWSMOB (~a, (scm_t_bits) c_obj);~%"
+ (smob-type-tag type))
+ (format port "}~%"))
+
+(define (output-smob->c-converter type port)
+ (format port "static inline ~a~%~a (SCM obj, "
+ (smob-type-c-name type)
+ (smob-type-to-c-function type))
+ (format port "unsigned pos, const char *func)~%")
+ (format port "#define FUNC_NAME func~%")
+ (format port "{~%")
+ (format port " SCM_VALIDATE_SMOB (pos, obj, ~a);~%"
+ (string-append "gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+ (format port " return ((~a) SCM_SMOB_DATA (obj));~%"
+ (smob-type-c-name type))
+ (format port "}~%")
+ (format port "#undef FUNC_NAME~%"))
+
+\f
+;;;
+;;; Actual SMOB types.
+;;;
+
+(define %session-smob
+ (make-smob-type "gnutls_session_t" 'session
+ "gnutls_deinit"))
+
+(define %anonymous-client-credentials-smob
+ (make-smob-type "gnutls_anon_client_credentials_t" 'anonymous-client-credentials
+ "gnutls_anon_free_client_credentials"))
+
+(define %anonymous-server-credentials-smob
+ (make-smob-type "gnutls_anon_server_credentials_t" 'anonymous-server-credentials
+ "gnutls_anon_free_server_credentials"))
+
+(define %dh-parameters-smob
+ (make-smob-type "gnutls_dh_params_t" 'dh-parameters
+ "gnutls_dh_params_deinit"))
+
+(define %rsa-parameters-smob
+ (make-smob-type "gnutls_rsa_params_t" 'rsa-parameters
+ "gnutls_rsa_params_deinit"))
+
+(define %certificate-credentials-smob
+ (make-smob-type "gnutls_certificate_credentials_t" 'certificate-credentials
+ "gnutls_certificate_free_credentials"))
+
+(define %srp-server-credentials-smob
+ (make-smob-type "gnutls_srp_server_credentials_t" 'srp-server-credentials
+ "gnutls_srp_free_server_credentials"))
+
+(define %srp-client-credentials-smob
+ (make-smob-type "gnutls_srp_client_credentials_t" 'srp-client-credentials
+ "gnutls_srp_free_client_credentials"))
+
+(define %psk-server-credentials-smob
+ (make-smob-type "gnutls_psk_server_credentials_t" 'psk-server-credentials
+ "gnutls_psk_free_server_credentials"))
+
+(define %psk-client-credentials-smob
+ (make-smob-type "gnutls_psk_client_credentials_t" 'psk-client-credentials
+ "gnutls_psk_free_client_credentials"))
+
+(define %x509-certificate-smob
+ (make-smob-type "gnutls_x509_crt_t" 'x509-certificate
+ "gnutls_x509_crt_deinit"))
+
+(define %x509-private-key-smob
+ (make-smob-type "gnutls_x509_privkey_t" 'x509-private-key
+ "gnutls_x509_privkey_deinit"))
+
+(define %openpgp-public-key-smob
+ (make-smob-type "gnutls_openpgp_key_t" 'openpgp-public-key
+ "gnutls_openpgp_key_deinit"))
+
+(define %openpgp-private-key-smob
+ (make-smob-type "gnutls_openpgp_privkey_t" 'openpgp-private-key
+ "gnutls_openpgp_privkey_deinit"))
+
+(define %openpgp-keyring-smob
+ (make-smob-type "gnutls_openpgp_keyring_t" 'openpgp-keyring
+ "gnutls_openpgp_keyring_deinit"))
+
+
+(define %gnutls-smobs
+ ;; All SMOB types.
+ (list %session-smob %anonymous-client-credentials-smob
+ %anonymous-server-credentials-smob %dh-parameters-smob
+ %rsa-parameters-smob
+ %certificate-credentials-smob
+ %srp-server-credentials-smob %srp-client-credentials-smob
+ %psk-server-credentials-smob %psk-client-credentials-smob
+ %x509-certificate-smob %x509-private-key-smob))
+
+(define %gnutls-extra-smobs
+ ;; All SMOB types for GnuTLS-extra (GPL).
+ (list %openpgp-public-key-smob %openpgp-private-key-smob
+ %openpgp-keyring-smob))
+
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 26bf79ef-6dee-45f2-9e9d-2d209c518278
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>
+
+(define-module (gnutls build utils)
+ :use-module (srfi srfi-13)
+ :export (scheme-symbol->c-name))
+
+;;;
+;;; Common utilities for the binding generation code.
+;;;
+
+\f
+;;;
+;;; Utilities.
+;;;
+
+(define (scheme-symbol->c-name sym)
+ ;; Turn SYM, a symbol denoting a Scheme name, into a string denoting a C
+ ;; name.
+ (string-map (lambda (chr)
+ (if (eq? chr #\-) #\_ chr))
+ (symbol->string sym)))
+
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 56919ee1-7cce-46b9-b90f-ae6fbcfe4159
--- /dev/null
+;;; GNUTLS-EXTRA --- Guile bindings for GnuTLS-EXTRA.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS-EXTRA is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNUTLS-EXTRA 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNUTLS-EXTRA; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>
+
+(define-module (gnutls extra)
+
+;;; Important note: As written above, this part of the code is ditributed
+;;; under the GPL, not the LGPL.
+
+ :use-module (gnutls)
+
+ :export (;; OpenPGP keys
+ openpgp-public-key? openpgp-private-key?
+ import-openpgp-public-key import-openpgp-private-key
+ openpgp-public-key-id openpgp-public-key-id!
+ openpgp-public-key-fingerprint openpgp-public-key-fingerprint!
+ openpgp-public-key-name openpgp-public-key-names
+ openpgp-public-key-algorithm openpgp-public-key-version
+ openpgp-public-key-usage
+
+ ;; OpenPGP keyrings
+ openpgp-keyring? import-openpgp-keyring
+ openpgp-keyring-contains-key-id?
+
+ ;; certificate credentials
+ set-certificate-credentials-openpgp-keys!
+
+ ;; enum->string functions
+ openpgp-key-format->string
+
+ ;; enum values
+ openpgp-key-format/raw
+ openpgp-key-format/base64))
+
+
+(load-extension "libguile-gnutls-extra-v-0" "scm_init_gnutls_extra")
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 2eb7693e-a221-41d3-8a14-a57426e9e670
--- /dev/null
+C Documentation Snarfing Modules
+--------------------------------
+
+This modules provide allow the extraction of Texinfo documentation
+strings from C files---this is usually referred to as ``doc snarfing''
+in Guile terms.
+
+They were stolen from Guile-Reader 0.3:
+
+ http://www.nongnu.org/guile-reader/
+
+It was only slightly modified.
+
+
+Ludovic Courtès <ludo@chbouib.org>.
--- /dev/null
+;;; c-snarf.scm -- Parsing documentation "snarffed" from C files.
+;;;
+;;; Copyright 2006 Free Software Foundation
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (system documentation c-snarf)
+ :use-module (ice-9 popen)
+ :use-module (ice-9 rdelim)
+
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-14)
+ :use-module (srfi srfi-39)
+
+ :export (run-cpp-and-extract-snarfing
+ parse-snarfing
+ parse-snarfed-line snarf-line?))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides tools to parse and otherwise manipulate
+;;; documentation "snarffed" from C files, i.e., information obtained by
+;;; running the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS} flag.
+;;;
+;;; Code:
+
+
+\f
+;;;
+;;; High-level API.
+;;;
+
+(define (run-cpp-and-extract-snarfing file cpp cflags)
+ (let ((pipe (apply open-pipe* OPEN_READ cpp file cflags)))
+ (parse-snarfing pipe)))
+
+\f
+;;;
+;;; Parsing magic-snarffed CPP output.
+;;;
+
+(define (snarf-line? line)
+ "Return true if @var{line} (a string) can be considered a line produced by
+the @code{snarf.h} snarfing macros."
+ (and (>= (string-length line) 4)
+ (string=? (substring line 0 4) "^^ {")))
+
+(define (parse-c-argument-list arg-string)
+ "Parse @var{arg-string} (a string representing a ANSI C argument list,
+e.g., @var{(const SCM first, SCM second_arg)}) and return a list of strings
+denoting the argument names."
+ (define %c-symbol-char-set
+ (char-set-adjoin char-set:letter+digit #\_))
+
+ (let loop ((args (string-tokenize (string-trim-both arg-string #\space)
+ %c-symbol-char-set))
+ (type? #t)
+ (result '()))
+ (if (null? args)
+ (reverse! result)
+ (let ((the-arg (car args)))
+ (cond ((and type? (string=? the-arg "const"))
+ (loop (cdr args) type? result))
+ ((and type? (string=? the-arg "SCM"))
+ (loop (cdr args) (not type?) result))
+ (type? ;; any other type, e.g., `void'
+ (loop (cdr args) (not type?) result))
+ (else
+ (loop (cdr args) (not type?) (cons the-arg result))))))))
+
+(define (parse-documentation-item item)
+ "Parse @var{item} (a string), a single function string produced by the C
+preprocessor. The result is an alist whose keys represent specific aspects
+of a procedure's documentation: @code{c-name}, @code{scheme-name},
+ @code{documentation} (a Texinfo documentation string), etc."
+
+ (define (read-strings)
+ ;; Read several subsequent strings and return their concatenation.
+ (let loop ((str (read))
+ (result '()))
+ (if (or (eof-object? str)
+ (not (string? str)))
+ (string-concatenate (reverse! result))
+ (loop (read) (cons str result)))))
+
+ ;;(format (current-error-port) "doc-item: ~a~%" item)
+ (let* ((item (string-trim-both item #\space))
+ (space (string-index item #\space)))
+ (if (not space)
+ (error "invalid documentation item" item)
+ (let ((kind (substring item 0 space))
+ (rest (substring item space (string-length item))))
+ (cond ((string=? kind "cname")
+ (cons 'c-name (string-trim-both rest #\space)))
+ ((string=? kind "fname")
+ (cons 'scheme-name
+ (with-input-from-string rest read-strings)))
+ ((string=? kind "type")
+ (cons 'type (with-input-from-string rest read)))
+ ((string=? kind "location")
+ (cons 'location
+ (with-input-from-string rest
+ (lambda ()
+ (let loop ((str (read))
+ (result '()))
+ (if (eof-object? str)
+ (reverse! result)
+ (loop (read) (cons str result))))))))
+ ((string=? kind "arglist")
+ (cons 'arguments
+ (parse-c-argument-list rest)))
+ ((string=? kind "argsig")
+ (cons 'signature
+ (with-input-from-string rest
+ (lambda ()
+ (let ((req (read)) (opt (read)) (rst? (read)))
+ (list (cons 'required req)
+ (cons 'optional opt)
+ (cons 'rest? (= 1 rst?))))))))
+ (else
+ ;; docstring (may consist of several C strings which we
+ ;; assume to be equivalent to Scheme strings)
+ (cons 'documentation
+ (with-input-from-string item read-strings))))))))
+
+(define (parse-snarfed-line line)
+ "Parse @var{line}, a string that contains documentation returned for a
+single function by the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS}
+option. @var{line} is assumed to obey the @code{snarf-line?} predicate."
+ (define (caret-split str)
+ (let loop ((str str)
+ (result '()))
+ (if (string=? str "")
+ (reverse! result)
+ (let ((caret (string-index str #\^))
+ (len (string-length str)))
+ (if caret
+ (if (and (> (- len caret) 0)
+ (eq? (string-ref str (+ caret 1)) #\^))
+ (loop (substring str (+ 2 caret) len)
+ (cons (string-take str (- caret 1)) result))
+ (error "single caret not allowed" str))
+ (loop "" (cons str result)))))))
+
+ (let ((items (caret-split (substring line 4
+ (- (string-length line) 4)))))
+ (map parse-documentation-item items)))
+
+
+(define (parse-snarfing port)
+ "Read C preprocessor (where the @code{SCM_MAGIC_SNARF_DOCS} macro is
+defined) output from @var{port} a return a list of alist, each of which
+contains information about a specific function described in the C
+preprocessor output."
+ (let loop ((line (read-line port))
+ (result '()))
+ ;;(format (current-error-port) "line: ~a~%" line)
+ (if (eof-object? line)
+ result
+ (cond ((snarf-line? line)
+ (loop (read-line port)
+ (cons (parse-snarfed-line line) result)))
+ (else
+ (loop (read-line port) result))))))
+
+
+;;; c-snarf.scm ends here
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: dcba2446-ee43-46d8-a47e-e6e12f121988
--- /dev/null
+;;; output.scm -- Output documentation "snarffed" from C files in Texi/GDF.
+;;;
+;;; Copyright 2006, 2007 Free Software Foundation
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (system documentation output)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-39)
+ :autoload (system documentation c-snarf) (run-cpp-and-extract-snarfing)
+
+ :export (schemify-name scheme-procedure-texi-line
+ procedure-gdf-string procedure-texi-documentation
+ output-procedure-texi-documentation-from-c-file
+ *document-c-functions?*))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides support function to issue Texinfo or GDF (Guile
+;;; Documentation Format) documentation from "snarffed" C files.
+;;;
+;;; Code:
+
+\f
+;;;
+;;; Utility.
+;;;
+
+(define (schemify-name str)
+ "Turn @var{str}, a C variable or function name, into a more ``Schemey''
+form, e.g., one with dashed instead of underscores, etc."
+ (string-map (lambda (chr)
+ (if (eq? chr #\_)
+ #\-
+ chr))
+ (if (string-suffix? "_p" str)
+ (string-append (substring str 0
+ (- (string-length str) 2))
+ "?")
+ str)))
+
+\f
+;;;
+;;; Issuing Texinfo and GDF-formatted doc (i.e., `guile-procedures.texi').
+;;; GDF = Guile Documentation Format
+;;;
+
+(define *document-c-functions?*
+ ;; Whether to mention C function names along with Scheme procedure names.
+ (make-parameter #t))
+
+(define (scheme-procedure-texi-line proc-name args
+ required-args optional-args
+ rest-arg?)
+ "Return a Texinfo string describing the Scheme procedure named
+@var{proc-name}, whose arguments are listed in @var{args} (a list of strings)
+and whose signature is defined by @var{required-args}, @var{optional-args}
+and @var{rest-arg?}."
+ (string-append "@deffn {Scheme Procedure} " proc-name " "
+ (string-join (take args required-args) " ")
+ (string-join (take (drop args required-args)
+ (+ optional-args
+ (if rest-arg? 1 0)))
+ " [" 'prefix)
+ (if rest-arg? "...]" "")
+ (make-string optional-args #\])))
+
+(define (procedure-gdf-string proc-doc)
+ "Issue a Texinfo/GDF docstring corresponding to @var{proc-doc}, a
+documentation alist as returned by @code{parse-snarfed-line}. To produce
+actual GDF-formatted doc, the resulting string must be processed by
+@code{makeinfo}."
+ (let* ((proc-name (assq-ref proc-doc 'scheme-name))
+ (args (assq-ref proc-doc 'arguments))
+ (signature (assq-ref proc-doc 'signature))
+ (required-args (assq-ref signature 'required))
+ (optional-args (assq-ref signature 'optional))
+ (rest-arg? (assq-ref signature 'rest?))
+ (location (assq-ref proc-doc 'location))
+ (file-name (car location))
+ (line (cadr location))
+ (documentation (assq-ref proc-doc 'documentation)))
+ (string-append "\f" ;; form feed
+ proc-name (string #\newline)
+ (format #f "@c snarfed from ~a:~a~%"
+ file-name line)
+
+ (scheme-procedure-texi-line proc-name
+ (map schemify-name args)
+ required-args optional-args
+ rest-arg?)
+
+ (string #\newline)
+ documentation (string #\newline)
+ "@end deffn" (string #\newline))))
+
+(define (procedure-texi-documentation proc-doc)
+ "Issue a Texinfo docstring corresponding to @var{proc-doc}, a documentation
+alist as returned by @var{parse-snarfed-line}. The resulting Texinfo string
+is meant for use in a manual since it also documents the corresponding C
+function."
+ (let* ((proc-name (assq-ref proc-doc 'scheme-name))
+ (c-name (assq-ref proc-doc 'c-name))
+ (args (assq-ref proc-doc 'arguments))
+ (signature (assq-ref proc-doc 'signature))
+ (required-args (assq-ref signature 'required))
+ (optional-args (assq-ref signature 'optional))
+ (rest-arg? (assq-ref signature 'rest?))
+ (location (assq-ref proc-doc 'location))
+ (file-name (car location))
+ (line (cadr location))
+ (documentation (assq-ref proc-doc 'documentation)))
+ (string-append (string #\newline)
+ (format #f "@c snarfed from ~a:~a~%"
+ file-name line)
+
+ ;; document the Scheme procedure
+ (scheme-procedure-texi-line proc-name
+ (map schemify-name args)
+ required-args optional-args
+ rest-arg?)
+ (string #\newline)
+
+ (if (*document-c-functions?*)
+ (string-append
+ ;; document the C function
+ "@deffnx {C Function} " c-name " ("
+ (if (null? args)
+ "void"
+ (string-join (map (lambda (arg)
+ (string-append "SCM " arg))
+ args)
+ ", "))
+ ")" (string #\newline))
+ "")
+
+ documentation (string #\newline)
+ "@end deffn" (string #\newline))))
+
+\f
+;;;
+;;; Very high-level interface.
+;;;
+
+(define (output-procedure-texi-documentation-from-c-file c-file cpp cflags
+ port)
+ (for-each (lambda (texi-string)
+ (display texi-string port))
+ (map procedure-texi-documentation
+ (run-cpp-and-extract-snarfing cpp c-file cflags))))
+
+
+;;; output.scm ends here
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 20ca493a-6f1a-4d7f-9d24-ccce0d32df49
--- /dev/null
+#!/bin/sh
+
+# Copyright (C) 2007 Free Software Foundation
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+# Sets up the execution environment needed to run the test programs
+# and produce the documentation.
+
+
+GUILE_LOAD_PATH="@abs_top_srcdir@/guile/modules:$GUILE_LOAD_PATH"
+export GUILE_LOAD_PATH
+
+exec @abs_top_builddir@/libtool --mode=execute \
+ -dlopen "@abs_top_builddir@/guile/src/libguile-gnutls-v-0.la" \
+ -dlopen "@abs_top_builddir@/guile/src/libguile-gnutls-extra-v-0.la" \
+ @GUILE@ "$@"
--- /dev/null
+# GNUTLS -- Guile bindings for GnuTLS.
+# Copyright (C) 2007 Free Software Foundation
+#
+# GNUTLS 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.
+#
+# GNUTLS 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 GNUTLS; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+GUILE_FOR_BUILD = $(GUILE) -L $(top_srcdir)/modules
+
+noinst_HEADERS = errors.h utils.h
+
+EXTRA_DIST = \
+ make-enum-map.scm make-smob-types.scm \
+ make-enum-header.scm make-smob-header.scm \
+ make-session-priorities.scm
+
+BUILT_SOURCES = enum-map.i.c smob-types.i.c enums.h smobs.h \
+ priorities.i.c \
+ extra-smobs.h extra-enums.h \
+ extra-enum-map.i.c extra-smob-types.i.c \
+ core.c.x errors.c.x extra.c.x
+
+CLEANFILES = $(BUILT_SOURCES)
+
+lib_LTLIBRARIES = libguile-gnutls-v-0.la libguile-gnutls-extra-v-0.la
+
+GNULIB_LDFLAGS = -L$(top_builddir)/lgl -llgnu
+GNULIB_CFLAGS = -I$(top_builddir)/lgl -I$(top_srcdir)/lgl
+
+libguile_gnutls_v_0_la_SOURCES = core.c errors.c utils.c
+libguile_gnutls_v_0_la_CFLAGS = \
+ $(GNULIB_CFLAGS) $(GUILE_CFLAGS) $(LIBGNUTLS_CFLAGS)
+libguile_gnutls_v_0_la_LDFLAGS = \
+ $(GNULIB_LDFLAGS) $(GUILE_LDFLAGS) $(LIBGNUTLS_LIBS)
+
+libguile_gnutls_extra_v_0_la_SOURCES = extra.c
+libguile_gnutls_extra_v_0_la_CFLAGS = \
+ $(GNULIB_CFLAGS) $(GUILE_CFLAGS) \
+ $(LIBGNUTLS_CFLAGS) $(LIBGNUTLS_EXTRA_CFLAGS)
+libguile_gnutls_extra_v_0_la_LDFLAGS = \
+ $(GNULIB_LDFLAGS) $(GUILE_LDFLAGS) \
+ $(LIBGNUTLS_LIBS) $(LIBGNUTLS_EXTRA_LIBS) \
+ -L$(builddir) -lguile-gnutls-v-0
+
+AM_CPPFLAGS = -I$(builddir)
+
+
+enums.h: $(srcdir)/make-enum-header.scm
+ $(GUILE_FOR_BUILD) $^ > $@
+
+enum-map.i.c: $(srcdir)/make-enum-map.scm
+ $(GUILE_FOR_BUILD) $^ > $@
+
+smobs.h: $(srcdir)/make-smob-header.scm
+ $(GUILE_FOR_BUILD) $^ > $@
+
+smob-types.i.c: $(srcdir)/make-smob-types.scm
+ $(GUILE_FOR_BUILD) $^ > $@
+
+priorities.i.c: $(srcdir)/make-session-priorities.scm
+ $(GUILE_FOR_BUILD) $^ > $@
+
+
+# GnuTLS-extra
+
+extra-enums.h: $(srcdir)/make-enum-header.scm
+ $(GUILE_FOR_BUILD) $^ extra > $@
+
+extra-enum-map.i.c: $(srcdir)/make-enum-map.scm
+ $(GUILE_FOR_BUILD) $^ extra > $@
+
+extra-smobs.h: $(srcdir)/make-smob-header.scm
+ $(GUILE_FOR_BUILD) $^ extra > $@
+
+extra-smob-types.i.c: $(srcdir)/make-smob-types.scm
+ $(GUILE_FOR_BUILD) $^ extra > $@
+
+
+# C file snarfing.
+
+snarfcppopts = $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \
+ $(CFLAGS) $(AM_CFLAGS)
+
+SUFFIXES = .x
+%.c.x: %.c
+ $(guile_snarf) -o $@ $< $(snarfcppopts)
--- /dev/null
+/* GNUTLS --- Guile bindings for GnuTLS.
+ Copyright (C) 2007 Free Software Foundation
+
+ GNUTLS 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.
+
+ GNUTLS 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 GNUTLS; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
+
+/* Written by Ludovic Courtès <ludo@chbouib.org>. */
+
+#include <stdio.h>
+#include <string.h>
+#include <gnutls/gnutls.h>
+#include <libguile.h>
+
+#include <alloca.h>
+
+#include "enums.h"
+#include "smobs.h"
+#include "errors.h"
+#include "utils.h"
+
+
+\f
+/* SMOB and enums type definitions. */
+#include "enum-map.i.c"
+#include "smob-types.i.c"
+
+const char scm_gnutls_array_error_message[] =
+ "cannot handle non-contiguous array: ~A";
+
+
+/* Data that are attached to `gnutls_session_t' objects.
+
+ We need to keep several pieces of information along with each session:
+
+ - A boolean indicating whether its underlying transport is a file
+ descriptor or Scheme port. This is used to decide whether to leave
+ "Guile mode" when invoking `gnutls_record_recv ()'.
+
+ - The record port attached to the session (returned by
+ `session-record-port'). This is so that several calls to
+ `session-record-port' return the same port.
+
+ Currently, this information is maintained into a pair. The whole pair is
+ marked by the session mark procedure. */
+
+#define SCM_GNUTLS_MAKE_SESSION_DATA() \
+ scm_cons (SCM_BOOL_F, SCM_BOOL_F);
+#define SCM_GNUTLS_SET_SESSION_DATA(c_session, data) \
+ gnutls_session_set_ptr (c_session, (void *) SCM_UNPACK (data))
+#define SCM_GNUTLS_SESSION_DATA(c_session) \
+ SCM_PACK ((scm_t_bits) gnutls_session_get_ptr (c_session))
+
+#define SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD(c_session, c_is_fd) \
+ SCM_SETCAR (SCM_GNUTLS_SESSION_DATA (c_session), \
+ scm_from_bool (c_is_fd))
+#define SCM_GNUTLS_SET_SESSION_RECORD_PORT(c_session, port) \
+ SCM_SETCDR (SCM_GNUTLS_SESSION_DATA (c_session), port);
+
+#define SCM_GNUTLS_SESSION_TRANSPORT_IS_FD(c_session) \
+ scm_to_bool (SCM_CAR (SCM_GNUTLS_SESSION_DATA (c_session)))
+#define SCM_GNUTLS_SESSION_RECORD_PORT(c_session) \
+ SCM_CDR (SCM_GNUTLS_SESSION_DATA (c_session))
+
+
+\f
+/* Bindings. */
+
+/* Mark the data associated with SESSION. */
+SCM_SMOB_MARK (scm_tc16_gnutls_session, mark_session, session)
+{
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, "mark_session");
+
+ return (SCM_GNUTLS_SESSION_DATA (c_session));
+}
+
+SCM_DEFINE (scm_gnutls_version, "gnutls-version", 0, 0, 0,
+ (void),
+ "Return a string denoting the version number of the underlying "
+ "GnuTLS library, e.g., @code{\"1.7.2\"}.")
+#define FUNC_NAME s_scm_gnutls_version
+{
+ return (scm_from_locale_string (gnutls_check_version (NULL)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_make_session, "make-session", 1, 0, 0,
+ (SCM end),
+ "Return a new session for connection end @var{end}, either "
+ "@code{connection-end/server} or @code{connection-end/client}.")
+#define FUNC_NAME s_scm_gnutls_make_session
+{
+ int err;
+ gnutls_session_t c_session;
+ gnutls_connection_end_t c_end;
+ SCM session_data;
+
+ c_end = scm_to_gnutls_connection_end (end, 1, FUNC_NAME);
+
+ session_data = SCM_GNUTLS_MAKE_SESSION_DATA ();
+ err = gnutls_init (&c_session, c_end);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ SCM_GNUTLS_SET_SESSION_DATA (c_session, session_data);
+
+ return (scm_from_gnutls_session (c_session));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_bye, "bye", 2, 0, 0,
+ (SCM session, SCM how),
+ "Close @var{session} according to @var{how}.")
+#define FUNC_NAME s_scm_gnutls_bye
+{
+ int err;
+ gnutls_session_t c_session;
+ gnutls_close_request_t c_how;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ c_how = scm_to_gnutls_close_request (how, 2, FUNC_NAME);
+
+ err = gnutls_bye (c_session, c_how);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_handshake, "handshake", 1, 0, 0,
+ (SCM session),
+ "Perform a handshake for @var{session}.")
+#define FUNC_NAME s_scm_gnutls_handshake
+{
+ int err;
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ err = gnutls_handshake (c_session);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_rehandshake, "rehandshake", 1, 0, 0,
+ (SCM session),
+ "Perform a re-handshaking for @var{session}.")
+#define FUNC_NAME s_scm_gnutls_rehandshake
+{
+ int err;
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ err = gnutls_rehandshake (c_session);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_alert_get, "alert-get", 1, 0, 0,
+ (SCM session),
+ "Get an aleter from @var{session}.")
+#define FUNC_NAME s_scm_gnutls_alert_get
+{
+ gnutls_session_t c_session;
+ gnutls_alert_description_t c_alert;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_alert = gnutls_alert_get (c_session);
+
+ return (scm_from_gnutls_alert_description (c_alert));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_alert_send, "alert-send", 3, 0, 0,
+ (SCM session, SCM level, SCM alert),
+ "Send @var{alert} via @var{session}.")
+#define FUNC_NAME s_scm_gnutls_alert_send
+{
+ int err;
+ gnutls_session_t c_session;
+ gnutls_alert_level_t c_level;
+ gnutls_alert_description_t c_alert;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ c_level = scm_to_gnutls_alert_level (level, 2, FUNC_NAME);
+ c_alert = scm_to_gnutls_alert_description (alert, 3, FUNC_NAME);
+
+ err = gnutls_alert_send (c_session, c_level, c_alert);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* FIXME: Omitting `alert-send-appropriate'. */
+
+\f
+/* Session accessors. */
+
+SCM_DEFINE (scm_gnutls_session_cipher, "session-cipher", 1, 0, 0,
+ (SCM session),
+ "Return @var{session}'s cipher.")
+#define FUNC_NAME s_scm_gnutls_session_cipher
+{
+ gnutls_session_t c_session;
+ gnutls_cipher_algorithm_t c_cipher;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_cipher = gnutls_cipher_get (c_session);
+
+ return (scm_from_gnutls_cipher (c_cipher));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_kx, "session-kx", 1, 0, 0,
+ (SCM session),
+ "Return @var{session}'s kx.")
+#define FUNC_NAME s_scm_gnutls_session_kx
+{
+ gnutls_session_t c_session;
+ gnutls_kx_algorithm_t c_kx;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_kx = gnutls_kx_get (c_session);
+
+ return (scm_from_gnutls_kx (c_kx));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_mac, "session-mac", 1, 0, 0,
+ (SCM session),
+ "Return @var{session}'s MAC.")
+#define FUNC_NAME s_scm_gnutls_session_mac
+{
+ gnutls_session_t c_session;
+ gnutls_mac_algorithm_t c_mac;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_mac = gnutls_mac_get (c_session);
+
+ return (scm_from_gnutls_mac (c_mac));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_compression_method,
+ "session-compression-method", 1, 0, 0,
+ (SCM session),
+ "Return @var{session}'s compression method.")
+#define FUNC_NAME s_scm_gnutls_session_compression_method
+{
+ gnutls_session_t c_session;
+ gnutls_compression_method_t c_comp;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_comp = gnutls_compression_get (c_session);
+
+ return (scm_from_gnutls_compression_method (c_comp));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_certificate_type,
+ "session-certificate-type", 1, 0, 0,
+ (SCM session),
+ "Return @var{session}'s certificate type.")
+#define FUNC_NAME s_scm_gnutls_session_certificate_type
+{
+ gnutls_session_t c_session;
+ gnutls_certificate_type_t c_cert;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_cert = gnutls_certificate_type_get (c_session);
+
+ return (scm_from_gnutls_certificate_type (c_cert));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_protocol, "session-protocol", 1, 0, 0,
+ (SCM session),
+ "Return the protocol used by @var{session}.")
+#define FUNC_NAME s_scm_gnutls_session_protocol
+{
+ gnutls_session_t c_session;
+ gnutls_protocol_t c_protocol;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_protocol = gnutls_protocol_get_version (c_session);
+
+ return (scm_from_gnutls_protocol (c_protocol));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_authentication_type,
+ "session-authentication-type",
+ 1, 0, 0,
+ (SCM session),
+ "Return the authentication type (a @code{credential-type} value) "
+ "used by @var{session}.")
+#define FUNC_NAME s_scm_gnutls_session_authentication_type
+{
+ gnutls_session_t c_session;
+ gnutls_credentials_type_t c_auth;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_auth = gnutls_auth_get_type (c_session);
+
+ return (scm_from_gnutls_credentials (c_auth));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_server_authentication_type,
+ "session-server-authentication-type",
+ 1, 0, 0,
+ (SCM session),
+ "Return the server authentication type (a "
+ "@code{credential-type} value) used in @var{session}.")
+#define FUNC_NAME s_scm_gnutls_session_server_authentication_type
+{
+ gnutls_session_t c_session;
+ gnutls_credentials_type_t c_auth;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_auth = gnutls_auth_server_get_type (c_session);
+
+ return (scm_from_gnutls_credentials (c_auth));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_client_authentication_type,
+ "session-client-authentication-type",
+ 1, 0, 0,
+ (SCM session),
+ "Return the client authentication type (a "
+ "@code{credential-type} value) used in @var{session}.")
+#define FUNC_NAME s_scm_gnutls_session_client_authentication_type
+{
+ gnutls_session_t c_session;
+ gnutls_credentials_type_t c_auth;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_auth = gnutls_auth_client_get_type (c_session);
+
+ return (scm_from_gnutls_credentials (c_auth));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_peer_certificate_chain,
+ "session-peer-certificate-chain",
+ 1, 0, 0,
+ (SCM session),
+ "Return the a list of certificates in raw format (u8vectors) "
+ "where the first one is the peer's certificate. In the case "
+ "of OpenPGP, there is always exactly one certificate. In the "
+ "case of X.509, subsequent certificates indicate form a "
+ "certificate chain. Return the empty list if no certificate "
+ "was sent.")
+#define FUNC_NAME s_scm_gnutls_session_peer_certificate_chain
+{
+ SCM result;
+ gnutls_session_t c_session;
+ const gnutls_datum_t *c_cert;
+ unsigned int c_list_size;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_cert = gnutls_certificate_get_peers (c_session, &c_list_size);
+
+ if (EXPECT_FALSE (c_cert == NULL))
+ result = SCM_EOL;
+ else
+ {
+ SCM pair;
+ unsigned int i;
+
+ result = scm_make_list (scm_from_uint (c_list_size), SCM_UNSPECIFIED);
+
+ for (i = 0, pair = result;
+ i < c_list_size;
+ i++, pair = SCM_CDR (pair))
+ {
+ unsigned char *c_cert_copy;
+
+ c_cert_copy = (unsigned char *) malloc (c_cert[i].size);
+ if (EXPECT_FALSE (c_cert_copy == NULL))
+ scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
+
+ memcpy (c_cert_copy, c_cert[i].data, c_cert[i].size);
+
+ SCM_SETCAR (pair, scm_take_u8vector (c_cert_copy, c_cert[i].size));
+ }
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_session_our_certificate_chain,
+ "session-our-certificate-chain",
+ 1, 0, 0,
+ (SCM session),
+ "Return our certificate chain for @var{session} (as sent to "
+ "the peer) in raw format (a u8vector). In the case of OpenPGP "
+ "there is exactly one certificate. Return the empty list "
+ "if no certificate was used.")
+#define FUNC_NAME s_scm_gnutls_session_our_certificate_chain
+{
+ SCM result;
+ gnutls_session_t c_session;
+ const gnutls_datum_t *c_cert;
+ unsigned char *c_cert_copy;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ /* XXX: Currently, the C function actually returns only one certificate.
+ Future versions of the API may provide the full certificate chain, as
+ for `gnutls_certificate_get_peers ()'. */
+ c_cert = gnutls_certificate_get_ours (c_session);
+
+ if (EXPECT_FALSE (c_cert == NULL))
+ result = SCM_EOL;
+ else
+ {
+ c_cert_copy = (unsigned char *) malloc (c_cert->size);
+ if (EXPECT_FALSE (c_cert_copy == NULL))
+ scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
+
+ memcpy (c_cert_copy, c_cert->data, c_cert->size);
+
+ result = scm_list_1 (scm_take_u8vector (c_cert_copy, c_cert->size));
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_server_session_certificate_request_x,
+ "set-server-session-certificate-request!",
+ 2, 0, 0,
+ (SCM session, SCM request),
+ "Tell how @var{session}, a server-side session, should deal "
+ "with certificate requests. @var{request} should be either "
+ "@code{certificate-request/request} or "
+ "@code{certificate-request/require}.")
+#define FUNC_NAME s_scm_gnutls_set_server_session_certificate_request_x
+{
+ gnutls_session_t c_session;
+ gnutls_certificate_status_t c_request;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ c_request = scm_to_gnutls_certificate_request (request, 2, FUNC_NAME);
+
+ gnutls_certificate_server_set_request (c_session, c_request);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* Choice of a protocol and cipher suite. */
+
+#include "priorities.i.c"
+
+SCM_DEFINE (scm_gnutls_set_default_priority_x,
+ "set-session-default-priority!", 1, 0, 0,
+ (SCM session),
+ "Have @var{session} use the default priorities.")
+#define FUNC_NAME s_scm_gnutls_set_default_priority_x
+{
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ gnutls_set_default_priority (c_session);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_default_export_priority_x,
+ "set-session-default-export-priority!", 1, 0, 0,
+ (SCM session),
+ "Have @var{session} use the default export priorities.")
+#define FUNC_NAME s_scm_gnutls_set_default_export_priority_x
+{
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ gnutls_set_default_export_priority (c_session);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_cipher_suite_to_string, "cipher-suite->string",
+ 3, 0, 0,
+ (SCM kx, SCM cipher, SCM mac),
+ "Return the name of the given cipher suite.")
+#define FUNC_NAME s_scm_gnutls_cipher_suite_to_string
+{
+ gnutls_kx_algorithm_t c_kx;
+ gnutls_cipher_algorithm_t c_cipher;
+ gnutls_mac_algorithm_t c_mac;
+ const char *c_name;
+
+ c_kx = scm_to_gnutls_kx (kx, 1, FUNC_NAME);
+ c_cipher = scm_to_gnutls_cipher (cipher, 2, FUNC_NAME);
+ c_mac = scm_to_gnutls_mac (mac, 3, FUNC_NAME);
+
+ c_name = gnutls_cipher_suite_get_name (c_kx, c_cipher, c_mac);
+
+ return (scm_from_locale_string (c_name));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_session_credentials_x, "set-session-credentials!",
+ 2, 0, 0,
+ (SCM session, SCM cred),
+ "Use @var{cred} as @var{session}'s credentials.")
+#define FUNC_NAME s_scm_gnutls_set_session_credentials_x
+{
+ int err = 0;
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_certificate_credentials, cred))
+ {
+ gnutls_certificate_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 2,
+ FUNC_NAME);
+ err = gnutls_credentials_set (c_session, GNUTLS_CRD_CERTIFICATE, c_cred);
+ }
+ else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_anonymous_client_credentials, cred))
+ {
+ gnutls_anon_client_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_anonymous_client_credentials (cred, 2,
+ FUNC_NAME);
+ err = gnutls_credentials_set (c_session, GNUTLS_CRD_ANON, c_cred);
+ }
+ else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_anonymous_server_credentials,
+ cred))
+ {
+ gnutls_anon_server_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_anonymous_server_credentials (cred, 2,
+ FUNC_NAME);
+ err = gnutls_credentials_set (c_session, GNUTLS_CRD_ANON, c_cred);
+ }
+ else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_client_credentials,
+ cred))
+ {
+ gnutls_srp_client_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_srp_client_credentials (cred, 2,
+ FUNC_NAME);
+ err = gnutls_credentials_set (c_session, GNUTLS_CRD_SRP, c_cred);
+ }
+ else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_srp_server_credentials,
+ cred))
+ {
+ gnutls_srp_server_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_srp_server_credentials (cred, 2,
+ FUNC_NAME);
+ err = gnutls_credentials_set (c_session, GNUTLS_CRD_SRP, c_cred);
+ }
+ else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_client_credentials,
+ cred))
+ {
+ gnutls_psk_client_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_psk_client_credentials (cred, 2,
+ FUNC_NAME);
+ err = gnutls_credentials_set (c_session, GNUTLS_CRD_PSK, c_cred);
+ }
+ else if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_psk_server_credentials,
+ cred))
+ {
+ gnutls_psk_server_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_psk_server_credentials (cred, 2,
+ FUNC_NAME);
+ err = gnutls_credentials_set (c_session, GNUTLS_CRD_PSK, c_cred);
+ }
+ else
+ scm_wrong_type_arg (FUNC_NAME, 2, cred);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* Record layer. */
+
+SCM_DEFINE (scm_gnutls_record_send, "record-send", 2, 0, 0,
+ (SCM session, SCM array),
+ "Send the record constituted by @var{array} through "
+ "@var{session}.")
+#define FUNC_NAME s_scm_gnutls_record_send
+{
+ SCM result;
+ ssize_t c_result;
+ gnutls_session_t c_session;
+ scm_t_array_handle c_handle;
+ const char *c_array;
+ size_t c_len;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ SCM_VALIDATE_ARRAY (2, array);
+
+ c_array = scm_gnutls_get_array (array, &c_handle, &c_len,
+ FUNC_NAME);
+
+ c_result = gnutls_record_send (c_session, c_array, c_len);
+
+ scm_gnutls_release_array (&c_handle);
+
+ if (EXPECT_TRUE (c_result >= 0))
+ result = scm_from_ssize_t (c_result);
+ else
+ scm_gnutls_error (c_result, FUNC_NAME);
+
+ return (result);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_record_receive_x, "record-receive!", 2, 0, 0,
+ (SCM session, SCM array),
+ "Receive data from @var{session} into @var{array}, a uniform "
+ "homogeneous array. Return the number of bytes actually "
+ "received.")
+#define FUNC_NAME s_scm_gnutls_record_receive_x
+{
+ SCM result;
+ ssize_t c_result;
+ gnutls_session_t c_session;
+ scm_t_array_handle c_handle;
+ char *c_array;
+ size_t c_len;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ SCM_VALIDATE_ARRAY (2, array);
+
+ c_array = scm_gnutls_get_writable_array (array, &c_handle, &c_len,
+ FUNC_NAME);
+
+ c_result = gnutls_record_recv (c_session, c_array, c_len);
+
+ scm_gnutls_release_array (&c_handle);
+
+ if (EXPECT_TRUE (c_result >= 0))
+ result = scm_from_ssize_t (c_result);
+ else
+ scm_gnutls_error (c_result, FUNC_NAME);
+
+ return (result);
+}
+#undef FUNC_NAME
+
+
+/* The session record port type. */
+static scm_t_bits session_record_port_type;
+
+/* Return the session associated with PORT. */
+#define SCM_GNUTLS_SESSION_RECORD_PORT_SESSION(_port) \
+ (SCM_PACK (SCM_STREAM (_port)))
+
+/* Size of a session port's input buffer. */
+#define SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE 4096
+
+/* Hint for the `scm_gc_' functions. */
+static const char session_record_port_gc_hint[] = "gnutls-session-record-port";
+
+/* Mark the session associated with PORT. */
+static SCM
+mark_session_record_port (SCM port)
+{
+ return (SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port));
+}
+
+static size_t
+free_session_record_port (SCM port)
+#define FUNC_NAME "free_session_record_port"
+{
+ SCM session;
+ scm_t_port *c_port;
+
+ session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
+
+ /* SESSION _can_ be invalid at this point: it can be freed in the same GC
+ cycle as PORT, just before PORT. Thus, we need to check whether SESSION
+ still points to a session SMOB. */
+ if (SCM_SMOB_PREDICATE (scm_tc16_gnutls_session, session))
+ {
+ /* SESSION is still valid. Disassociate PORT from SESSION. */
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session, SCM_BOOL_F);
+ }
+
+ /* Free the input buffer of PORT. */
+ c_port = SCM_PTAB_ENTRY (port);
+ scm_gc_free (c_port->read_buf, c_port->read_buf_size,
+ session_record_port_gc_hint);
+
+ return 0;
+}
+#undef FUNC_NAME
+
+/* Data passed to `do_fill_port ()'. */
+typedef struct
+{
+ scm_t_port *c_port;
+ gnutls_session_t c_session;
+} fill_port_data_t;
+
+/* Actually fill a session record port (see below). */
+static void *
+do_fill_port (void *data)
+{
+ int chr;
+ ssize_t result;
+ scm_t_port *c_port;
+ const fill_port_data_t *args = (fill_port_data_t *) data;
+
+ c_port = args->c_port;
+ result = gnutls_record_recv (args->c_session,
+ c_port->read_buf, c_port->read_buf_size);
+ if (EXPECT_TRUE (result > 0))
+ {
+ c_port->read_pos = c_port->read_buf;
+ c_port->read_end = c_port->read_buf + result;
+ chr = (int) *c_port->read_buf;
+ }
+ else if (result == 0)
+ chr = EOF;
+ else
+ scm_gnutls_error (result, "fill_session_record_port_input");
+
+ return ((void *) chr);
+}
+
+/* Fill in the input buffer of PORT. */
+static int
+fill_session_record_port_input (SCM port)
+#define FUNC_NAME "fill_session_record_port_input"
+{
+ int chr;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ if (c_port->read_pos >= c_port->read_end)
+ {
+ SCM session;
+ fill_port_data_t c_args;
+ gnutls_session_t c_session;
+
+ session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ c_args.c_session = c_session;
+ c_args.c_port = c_port;
+
+ if (SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session))
+ /* SESSION's underlying transport is a raw file descriptor, so we
+ must leave "Guile mode" to allow the GC to run. */
+ chr = (int) scm_without_guile (do_fill_port, &c_args);
+ else
+ /* SESSION's underlying transport is a port, so don't leave "Guile
+ mode". */
+ chr = (int) do_fill_port (&c_args);
+ }
+ else
+ chr = (int) *c_port->read_pos;
+
+ return chr;
+}
+#undef FUNC_NAME
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+write_to_session_record_port (SCM port, const void *data, size_t size)
+#define FUNC_NAME "write_to_session_record_port"
+{
+ SCM session;
+ gnutls_session_t c_session;
+ ssize_t c_result;
+ size_t c_sent = 0;
+
+ session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port);
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ while (c_sent < size)
+ {
+ c_result = gnutls_record_send (c_session, (char *) data + c_sent,
+ size - c_sent);
+ if (EXPECT_FALSE (c_result < 0))
+ scm_gnutls_error (c_result, FUNC_NAME);
+ else
+ c_sent += c_result;
+ }
+}
+#undef FUNC_NAME
+
+/* Return a new session port for SESSION. */
+static inline SCM
+make_session_record_port (SCM session)
+{
+ SCM port;
+ scm_t_port *c_port;
+ unsigned char *c_port_buf;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG | SCM_WRTNG;
+
+ c_port_buf =
+ (unsigned char *) scm_gc_malloc (SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE,
+ session_record_port_gc_hint);
+
+ /* Create a new port. */
+ port = scm_new_port_table_entry (session_record_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Mark PORT as open, readable and writable (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, session_record_port_type | mode_bits);
+
+ /* Associate it with SESSION. */
+ SCM_SETSTREAM (port, SCM_UNPACK (session));
+
+ c_port->read_pos = c_port->read_end = c_port->read_buf = c_port_buf;
+ c_port->read_buf_size = SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE;
+
+ c_port->write_buf = c_port->write_pos = &c_port->shortbuf;
+ c_port->write_buf_size = 1;
+
+ return (port);
+}
+
+SCM_DEFINE (scm_gnutls_session_record_port, "session-record-port", 1, 0, 0,
+ (SCM session),
+ "Return a read-write port that may be used to communicate over "
+ "@var{session}. All invocations of @code{session-port} on a "
+ "given session return the same object (in the sense of "
+ "@code{eq?}).")
+#define FUNC_NAME s_scm_gnutls_session_record_port
+{
+ SCM port;
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ port = SCM_GNUTLS_SESSION_RECORD_PORT (c_session);
+
+ if (!SCM_PORTP (port))
+ {
+ /* Lazily create a new session port. */
+ port = make_session_record_port (session);
+ SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session, port);
+ }
+
+ return (port);
+}
+#undef FUNC_NAME
+
+/* Create the session port type. */
+static inline void
+scm_init_gnutls_session_record_port_type (void)
+{
+ session_record_port_type =
+ scm_make_port_type ("gnutls-session-port",
+ fill_session_record_port_input,
+ write_to_session_record_port);
+ scm_set_port_mark (session_record_port_type, mark_session_record_port);
+ scm_set_port_free (session_record_port_type, free_session_record_port);
+}
+
+\f
+/* Transport. */
+
+SCM_DEFINE (scm_gnutls_set_session_transport_fd_x, "set-session-transport-fd!",
+ 2, 0, 0,
+ (SCM session, SCM fd),
+ "Use file descriptor @var{fd} as the underlying transport for "
+ "@var{session}.")
+#define FUNC_NAME s_scm_gnutls_set_session_transport_fd_x
+{
+ gnutls_session_t c_session;
+ int c_fd;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ c_fd = (int) scm_to_uint (fd);
+
+ gnutls_transport_set_ptr (c_session, (gnutls_transport_ptr_t) c_fd);
+
+ SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session, 1);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Pull SIZE octets from TRANSPORT (a Scheme port) into DATA. */
+static ssize_t
+pull_from_port (gnutls_transport_ptr_t transport, void *data, size_t size)
+{
+ SCM port;
+ ssize_t result;
+
+ port = SCM_PACK ((scm_t_bits) transport);
+
+ result = scm_c_read (port, data, size);
+
+ return ((ssize_t) result);
+}
+
+/* Write SIZE octets from DATA to TRANSPORT (a Scheme port). */
+static ssize_t
+push_to_port (gnutls_transport_ptr_t transport, const void *data,
+ size_t size)
+{
+ SCM port;
+
+ port = SCM_PACK ((scm_t_bits) transport);
+
+ scm_c_write (port, data, size);
+
+ /* All we can do is assume that all SIZE octets were written. */
+ return (size);
+}
+
+SCM_DEFINE (scm_gnutls_set_session_transport_port_x,
+ "set-session-transport-port!",
+ 2, 0, 0,
+ (SCM session, SCM port),
+ "Use @var{port} as the input/output port for @var{session}.")
+#define FUNC_NAME s_scm_gnutls_set_session_transport_port_x
+{
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ SCM_VALIDATE_PORT (2, port);
+
+ /* Note: We do not attempt to optimize the case where PORT is a file port
+ (i.e., over a file descriptor), because of port buffering issues. Users
+ are expected to explicitly use `set-session-transport-fd!' and `fileno'
+ when they wish to do it. */
+
+ gnutls_transport_set_ptr (c_session,
+ (gnutls_transport_ptr_t) SCM_UNPACK (port));
+ gnutls_transport_set_push_function (c_session, push_to_port);
+ gnutls_transport_set_pull_function (c_session, pull_from_port);
+
+ SCM_GNUTLS_SET_SESSION_TRANSPORT_IS_FD (c_session, 0);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* Diffie-Hellman. */
+
+typedef int (* pkcs_export_function_t) (void *, gnutls_x509_crt_fmt_t,
+ unsigned char *, size_t *);
+
+/* Hint for the `scm_gc' functions. */
+static const char pkcs_export_gc_hint[] = "gnutls-pkcs-export";
+
+
+/* Export DH/RSA parameters PARAMS through EXPORT, using format FORMAT.
+ Return a `u8vector'. */
+static inline SCM
+pkcs_export_parameters (pkcs_export_function_t export,
+ void *params, gnutls_x509_crt_fmt_t format,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ int err;
+ unsigned char *output;
+ size_t output_len, output_total_len = 4096;
+
+ output = (unsigned char *) scm_gc_malloc (output_total_len,
+ pkcs_export_gc_hint);
+ do
+ {
+ output_len = output_total_len;
+ err = export (params, format, output, &output_len);
+
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ output = scm_gc_realloc (output, output_total_len,
+ output_total_len * 2,
+ pkcs_export_gc_hint);
+ output_total_len *= 2;
+ }
+ }
+ while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
+
+ if (EXPECT_FALSE (err))
+ {
+ scm_gc_free (output, output_total_len, pkcs_export_gc_hint);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ if (output_len != output_total_len)
+ /* Shrink the output buffer. */
+ output = scm_gc_realloc (output, output_total_len,
+ output_len, pkcs_export_gc_hint);
+
+ return (scm_take_u8vector (output, output_len));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_gnutls_make_dh_parameters, "make-dh-parameters", 1, 0, 0,
+ (SCM bits),
+ "Return new Diffie-Hellman parameters.")
+#define FUNC_NAME s_scm_gnutls_make_dh_parameters
+{
+ int err;
+ unsigned c_bits;
+ gnutls_dh_params_t c_dh_params;
+
+ c_bits = scm_to_uint (bits);
+
+ err = gnutls_dh_params_init (&c_dh_params);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ err = gnutls_dh_params_generate2 (c_dh_params, c_bits);
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_dh_params_deinit (c_dh_params);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_dh_parameters (c_dh_params));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_pkcs3_import_dh_parameters,
+ "pkcs3-import-dh-parameters",
+ 2, 0, 0,
+ (SCM array, SCM format),
+ "Import Diffie-Hellman parameters in PKCS3 format (further "
+ "specified by @var{format}, an @code{x509-certificate-format} "
+ "value) from @var{array} (a homogeneous array) and return a "
+ "new @code{dh-params} object.")
+#define FUNC_NAME s_scm_gnutls_pkcs3_import_dh_parameters
+{
+ int err;
+ gnutls_x509_crt_fmt_t c_format;
+ gnutls_dh_params_t c_dh_params;
+ scm_t_array_handle c_handle;
+ const char *c_array;
+ size_t c_len;
+ gnutls_datum_t c_datum;
+
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+
+ c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
+ c_datum.data = (unsigned char *) c_array;
+ c_datum.size = c_len;
+
+ err = gnutls_dh_params_init (&c_dh_params);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_dh_params_import_pkcs3 (c_dh_params, &c_datum, c_format);
+ scm_gnutls_release_array (&c_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_dh_params_deinit (c_dh_params);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_dh_parameters (c_dh_params));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_pkcs3_export_dh_parameters,
+ "pkcs3-export-dh-parameters",
+ 2, 0, 0,
+ (SCM dh_params, SCM format),
+ "Export Diffie-Hellman parameters @var{dh_params} in PKCS3 "
+ "format according for @var{format} (an "
+ "@code{x509-certificate-format} value). Return a "
+ "@code{u8vector} containing the result.")
+#define FUNC_NAME s_scm_gnutls_pkcs3_export_dh_parameters
+{
+ SCM result;
+ gnutls_dh_params_t c_dh_params;
+ gnutls_x509_crt_fmt_t c_format;
+
+ c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 1, FUNC_NAME);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+
+ result = pkcs_export_parameters ((pkcs_export_function_t)
+ gnutls_dh_params_export_pkcs3,
+ (void *) c_dh_params,
+ c_format, FUNC_NAME);
+
+ return (result);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_session_dh_prime_bits_x,
+ "set-session-dh-prime-bits!", 2, 0, 0,
+ (SCM session, SCM bits),
+ "Use @var{bits} DH prime bits for @var{session}.")
+#define FUNC_NAME s_scm_gnutls_set_session_dh_prime_bits_x
+{
+ unsigned int c_bits;
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ c_bits = scm_to_uint (bits);
+
+ gnutls_dh_set_prime_bits (c_session, c_bits);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* Anonymous credentials. */
+
+SCM_DEFINE (scm_gnutls_make_anon_server_credentials,
+ "make-anonymous-server-credentials",
+ 0, 0, 0, (void),
+ "Return anonymous server credentials.")
+#define FUNC_NAME s_scm_gnutls_make_anon_server_credentials
+{
+ int err;
+ gnutls_anon_server_credentials_t c_cred;
+
+ err = gnutls_anon_allocate_server_credentials (&c_cred);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_anonymous_server_credentials (c_cred));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_make_anon_client_credentials,
+ "make-anonymous-client-credentials",
+ 0, 0, 0, (void),
+ "Return anonymous client credentials.")
+#define FUNC_NAME s_scm_gnutls_make_anon_client_credentials
+{
+ int err;
+ gnutls_anon_client_credentials_t c_cred;
+
+ err = gnutls_anon_allocate_client_credentials (&c_cred);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_anonymous_client_credentials (c_cred));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_anonymous_server_dh_parameters_x,
+ "set-anonymous-server-dh-parameters!", 2, 0, 0,
+ (SCM cred, SCM dh_params),
+ "Set the Diffie-Hellman parameters of anonymous server "
+ "credentials @var{cred}.")
+#define FUNC_NAME s_scm_gnutls_set_anonymous_server_dh_parameters_x
+{
+ gnutls_dh_params_t c_dh_params;
+ gnutls_anon_server_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_anonymous_server_credentials (cred, 1,
+ FUNC_NAME);
+ c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 2,
+ FUNC_NAME);
+
+ gnutls_anon_set_server_dh_params (c_cred, c_dh_params);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* RSA parameters. */
+
+SCM_DEFINE (scm_gnutls_make_rsa_parameters, "make-rsa-parameters", 1, 0, 0,
+ (SCM bits),
+ "Return new RSA parameters.")
+#define FUNC_NAME s_scm_gnutls_make_rsa_parameters
+{
+ int err;
+ unsigned c_bits;
+ gnutls_rsa_params_t c_rsa_params;
+
+ c_bits = scm_to_uint (bits);
+
+ err = gnutls_rsa_params_init (&c_rsa_params);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ err = gnutls_rsa_params_generate2 (c_rsa_params, c_bits);
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_rsa_params_deinit (c_rsa_params);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_rsa_parameters (c_rsa_params));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_pkcs1_import_rsa_parameters,
+ "pkcs1-import-rsa-parameters",
+ 2, 0, 0,
+ (SCM array, SCM format),
+ "Import Diffie-Hellman parameters in PKCS1 format (further "
+ "specified by @var{format}, an @code{x509-certificate-format} "
+ "value) from @var{array} (a homogeneous array) and return a "
+ "new @code{rsa-params} object.")
+#define FUNC_NAME s_scm_gnutls_pkcs1_import_rsa_parameters
+{
+ int err;
+ gnutls_x509_crt_fmt_t c_format;
+ gnutls_rsa_params_t c_rsa_params;
+ scm_t_array_handle c_handle;
+ const char *c_array;
+ size_t c_len;
+ gnutls_datum_t c_datum;
+
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+
+ c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
+ c_datum.data = (unsigned char *) c_array;
+ c_datum.size = c_len;
+
+ err = gnutls_rsa_params_init (&c_rsa_params);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_rsa_params_import_pkcs1 (c_rsa_params, &c_datum, c_format);
+ scm_gnutls_release_array (&c_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_rsa_params_deinit (c_rsa_params);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_rsa_parameters (c_rsa_params));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_pkcs1_export_rsa_parameters,
+ "pkcs1-export-rsa-parameters",
+ 2, 0, 0,
+ (SCM rsa_params, SCM format),
+ "Export Diffie-Hellman parameters @var{rsa_params} in PKCS1 "
+ "format according for @var{format} (an "
+ "@code{x509-certificate-format} value). Return a "
+ "@code{u8vector} containing the result.")
+#define FUNC_NAME s_scm_gnutls_pkcs1_export_rsa_parameters
+{
+ SCM result;
+ gnutls_rsa_params_t c_rsa_params;
+ gnutls_x509_crt_fmt_t c_format;
+
+ c_rsa_params = scm_to_gnutls_rsa_parameters (rsa_params, 1, FUNC_NAME);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+
+ result = pkcs_export_parameters ((pkcs_export_function_t)
+ gnutls_rsa_params_export_pkcs1,
+ (void *) c_rsa_params,
+ c_format, FUNC_NAME);
+
+ return (result);
+}
+#undef FUNC_NAME
+
+\f
+/* Certificate credentials. */
+
+typedef int (* certificate_set_file_function_t) (gnutls_certificate_credentials_t,
+ const char *,
+ gnutls_x509_crt_fmt_t);
+
+typedef int (* certificate_set_data_function_t) (gnutls_certificate_credentials_t,
+ const gnutls_datum_t *,
+ gnutls_x509_crt_fmt_t);
+
+/* Helper function to implement the `set-file!' functions. */
+static inline unsigned int
+set_certificate_file (certificate_set_file_function_t set_file,
+ SCM cred, SCM file, SCM format,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ int err;
+ char *c_file;
+ size_t c_file_len;
+
+ gnutls_certificate_credentials_t c_cred;
+ gnutls_x509_crt_fmt_t c_format;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, file);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 3, FUNC_NAME);
+
+ c_file_len = scm_c_string_length (file);
+ c_file = (char *) alloca (c_file_len + 1);
+
+ (void) scm_to_locale_stringbuf (file, c_file, c_file_len + 1);
+ c_file[c_file_len] = '\0';
+
+ err = set_file (c_cred, c_file, c_format);
+ if (EXPECT_FALSE (err < 0))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ /* Return the number of certificates processed. */
+ return ((unsigned int) err);
+}
+#undef FUNC_NAME
+
+/* Helper function implementing the `set-data!' functions. */
+static inline unsigned int
+set_certificate_data (certificate_set_data_function_t set_data,
+ SCM cred, SCM data, SCM format,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ int err;
+ gnutls_certificate_credentials_t c_cred;
+ gnutls_x509_crt_fmt_t c_format;
+ gnutls_datum_t c_datum;
+ scm_t_array_handle c_handle;
+ const char *c_data;
+ size_t c_len;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_ARRAY (2, data);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 3, FUNC_NAME);
+
+ c_data = scm_gnutls_get_array (data, &c_handle, &c_len, FUNC_NAME);
+ c_datum.data = (unsigned char *) c_data;
+ c_datum.size = c_len;
+
+ err = set_data (c_cred, &c_datum, c_format);
+ scm_gnutls_release_array (&c_handle);
+
+ if (EXPECT_FALSE (err < 0))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ /* Return the number of certificates processed. */
+ return ((unsigned int) err);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_gnutls_make_certificate_credentials,
+ "make-certificate-credentials",
+ 0, 0, 0,
+ (void),
+ "Return new certificate credentials (i.e., for use with "
+ "either X.509 or OpenPGP certificates.")
+#define FUNC_NAME s_scm_gnutls_make_certificate_credentials
+{
+ int err;
+ gnutls_certificate_credentials_t c_cred;
+
+ err = gnutls_certificate_allocate_credentials (&c_cred);
+ if (err)
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_certificate_credentials (c_cred));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_dh_params_x,
+ "set-certificate-credentials-dh-parameters!",
+ 2, 0, 0,
+ (SCM cred, SCM dh_params),
+ "Use Diffie-Hellman parameters @var{dh_params} for "
+ "certificate credentials @var{cred}.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_dh_params_x
+{
+ gnutls_dh_params_t c_dh_params;
+ gnutls_certificate_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 2, FUNC_NAME);
+
+ gnutls_certificate_set_dh_params (c_cred, c_dh_params);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_rsa_export_params_x,
+ "set-certificate-credentials-rsa-export-parameters!",
+ 2, 0, 0,
+ (SCM cred, SCM rsa_params),
+ "Use RSA parameters @var{rsa_params} for certificate "
+ "credentials @var{cred}.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_rsa_export_params_x
+{
+ gnutls_rsa_params_t c_rsa_params;
+ gnutls_certificate_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ c_rsa_params = scm_to_gnutls_rsa_parameters (rsa_params, 2, FUNC_NAME);
+
+ gnutls_certificate_set_rsa_export_params (c_cred, c_rsa_params);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_files_x,
+ "set-certificate-credentials-x509-key-files!",
+ 4, 0, 0,
+ (SCM cred, SCM cert_file, SCM key_file, SCM format),
+ "Use @var{file} as the password file for PSK server "
+ "credentials @var{cred}.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_files_x
+{
+ int err;
+ gnutls_certificate_credentials_t c_cred;
+ gnutls_x509_crt_fmt_t c_format;
+ char *c_cert_file, *c_key_file;
+ size_t c_cert_file_len, c_key_file_len;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, cert_file);
+ SCM_VALIDATE_STRING (3, key_file);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+
+ c_cert_file_len = scm_c_string_length (cert_file);
+ c_cert_file = (char *) alloca (c_cert_file_len + 1);
+
+ c_key_file_len = scm_c_string_length (key_file);
+ c_key_file = (char *) alloca (c_key_file_len + 1);
+
+ (void) scm_to_locale_stringbuf (cert_file, c_cert_file,
+ c_cert_file_len + 1);
+ c_cert_file[c_cert_file_len] = '\0';
+ (void) scm_to_locale_stringbuf (key_file, c_key_file,
+ c_key_file_len + 1);
+ c_key_file[c_key_file_len] = '\0';
+
+ err = gnutls_certificate_set_x509_key_file (c_cred, c_cert_file, c_key_file,
+ c_format);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_file_x,
+ "set-certificate-credentials-x509-trust-file!",
+ 3, 0, 0,
+ (SCM cred, SCM file, SCM format),
+ "Use @var{file} as the X.509 trust file for certificate "
+ "credentials @var{cred}. On success, return the number of "
+ "certificates processed.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_file_x
+{
+ unsigned int count;
+
+ count = set_certificate_file (gnutls_certificate_set_x509_trust_file,
+ cred, file, format,
+ FUNC_NAME);
+
+ return scm_from_uint (count);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_file_x,
+ "set-certificate-credentials-x509-crl-file!",
+ 3, 0, 0,
+ (SCM cred, SCM file, SCM format),
+ "Use @var{file} as the X.509 CRL (certificate revocation list) "
+ "file for certificate credentials @var{cred}. On success, "
+ "return the number of CRLs processed.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_file_x
+{
+ unsigned int count;
+
+ count = set_certificate_file (gnutls_certificate_set_x509_crl_file,
+ cred, file, format,
+ FUNC_NAME);
+
+ return scm_from_uint (count);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_trust_data_x,
+ "set-certificate-credentials-x509-trust-data!",
+ 3, 0, 0,
+ (SCM cred, SCM data, SCM format),
+ "Use @var{data} (a uniform array) as the X.509 trust "
+ "database for @var{cred}. On success, return the number "
+ "of certificates processed.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_trust_data_x
+{
+ unsigned int count;
+
+ count = set_certificate_data (gnutls_certificate_set_x509_trust_mem,
+ cred, data, format,
+ FUNC_NAME);
+
+ return scm_from_uint (count);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_crl_data_x,
+ "set-certificate-credentials-x509-crl-data!",
+ 3, 0, 0,
+ (SCM cred, SCM data, SCM format),
+ "Use @var{data} (a uniform array) as the X.509 CRL "
+ "(certificate revocation list) database for @var{cred}. "
+ "On success, return the number of CRLs processed.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_crl_data_x
+{
+ unsigned int count;
+
+ count = set_certificate_data (gnutls_certificate_set_x509_crl_mem,
+ cred, data, format,
+ FUNC_NAME);
+
+ return scm_from_uint (count);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_key_data_x,
+ "set-certificate-credentials-x509-key-data!",
+ 4, 0, 0,
+ (SCM cred, SCM cert, SCM key, SCM format),
+ "Use X.509 certificate @var{cert} and private key @var{key}, "
+ "both uniform arrays containing the X.509 certificate and key "
+ "in format @var{format}, for certificate credentials "
+ "@var{cred}.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_key_data_x
+{
+ int err;
+ gnutls_x509_crt_fmt_t c_format;
+ gnutls_certificate_credentials_t c_cred;
+ gnutls_datum_t c_cert_d, c_key_d;
+ scm_t_array_handle c_cert_handle, c_key_handle;
+ const char *c_cert, *c_key;
+ size_t c_cert_len, c_key_len;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 4, FUNC_NAME);
+ SCM_VALIDATE_ARRAY (2, cert);
+ SCM_VALIDATE_ARRAY (3, key);
+
+ /* FIXME: If the second call fails, an exception is raised and
+ C_CERT_HANDLE is not released. */
+ c_cert = scm_gnutls_get_array (cert, &c_cert_handle, &c_cert_len,
+ FUNC_NAME);
+ c_key = scm_gnutls_get_array (key, &c_key_handle, &c_key_len,
+ FUNC_NAME);
+
+ c_cert_d.data = (unsigned char *) c_cert;
+ c_cert_d.size = c_cert_len;
+ c_key_d.data = (unsigned char *) c_key;
+ c_key_d.size = c_key_len;
+
+ err = gnutls_certificate_set_x509_key_mem (c_cred, &c_cert_d, &c_key_d,
+ c_format);
+ scm_gnutls_release_array (&c_cert_handle);
+ scm_gnutls_release_array (&c_key_handle);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_x509_keys_x,
+ "set-certificate-credentials-x509-keys!",
+ 3, 0, 0,
+ (SCM cred, SCM certs, SCM privkey),
+ "Have certificate credentials @var{cred} use the X.509 "
+ "certificates listed in @var{certs} and X.509 private key "
+ "@var{privkey}.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_x509_keys_x
+{
+ int err;
+ gnutls_x509_crt_t *c_certs;
+ gnutls_x509_privkey_t c_key;
+ gnutls_certificate_credentials_t c_cred;
+ long int c_cert_count, i;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST_COPYLEN (2, certs, c_cert_count);
+ c_key = scm_to_gnutls_x509_private_key (privkey, 3, FUNC_NAME);
+
+ c_certs = (gnutls_x509_crt_t *) alloca (c_cert_count * sizeof (* c_certs));
+ for (i = 0;
+ scm_is_pair (certs);
+ certs = SCM_CDR (certs), i++)
+ {
+ c_certs[i] = scm_to_gnutls_x509_certificate (SCM_CAR (certs),
+ 2, FUNC_NAME);
+ }
+
+ err = gnutls_certificate_set_x509_key (c_cred, c_certs, c_cert_count,
+ c_key);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_limits_x,
+ "set-certificate-credentials-verify-limits!",
+ 3, 0, 0,
+ (SCM cred, SCM max_bits, SCM max_depth),
+ "Set the verification limits of @code{peer-certificate-status} "
+ "for certificate credentials @var{cred} to @var{max_bits} "
+ "bits for an acceptable certificate and @var{max_depth} "
+ "as the maximum depth of a certificate chain.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_limits_x
+{
+ gnutls_certificate_credentials_t c_cred;
+ unsigned int c_max_bits, c_max_depth;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ c_max_bits = scm_to_uint (max_bits);
+ c_max_depth = scm_to_uint (max_depth);
+
+ gnutls_certificate_set_verify_limits (c_cred, c_max_bits, c_max_depth);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_verify_flags_x,
+ "set-certificate-credentials-verify-flags!",
+ 1, 0, 1,
+ (SCM cred, SCM flags),
+ "Set the certificate verification flags to @var{flags}, a "
+ "series of @code{certificate-verify} values.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_verify_flags_x
+{
+ unsigned int c_flags, c_pos;
+ gnutls_certificate_credentials_t c_cred;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+
+ for (c_flags = 0, c_pos = 2;
+ !scm_is_null (flags);
+ flags = SCM_CDR (flags), c_pos++)
+ {
+ c_flags |= (unsigned int)
+ scm_to_gnutls_certificate_verify (SCM_CAR (flags), c_pos, FUNC_NAME);
+ }
+
+ gnutls_certificate_set_verify_flags (c_cred, c_flags);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_peer_certificate_status, "peer-certificate-status",
+ 1, 0, 0,
+ (SCM session),
+ "Verify the peer certificate for @var{session} and return "
+ "a list of @code{certificate-status} values (such as "
+ "@code{certificate-status/revoked}), or the empty list if "
+ "the certificate is valid.")
+#define FUNC_NAME s_scm_gnutls_peer_certificate_status
+{
+ int err;
+ unsigned int c_status;
+ gnutls_session_t c_session;
+ SCM result = SCM_EOL;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+
+ err = gnutls_certificate_verify_peers2 (c_session, &c_status);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+#define MATCH_STATUS(_value) \
+ if (c_status & (_value)) \
+ { \
+ result = scm_cons (scm_from_gnutls_certificate_status (_value), \
+ result); \
+ c_status &= ~(_value); \
+ }
+
+ MATCH_STATUS (GNUTLS_CERT_INVALID);
+ MATCH_STATUS (GNUTLS_CERT_REVOKED);
+ MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_FOUND);
+ MATCH_STATUS (GNUTLS_CERT_SIGNER_NOT_CA);
+ MATCH_STATUS (GNUTLS_CERT_INSECURE_ALGORITHM);
+
+ if (EXPECT_FALSE (c_status != 0))
+ /* XXX: We failed to interpret one of the status flags. */
+ scm_gnutls_error (GNUTLS_E_UNIMPLEMENTED_FEATURE, FUNC_NAME);
+
+#undef MATCH_STATUS
+
+ return (result);
+}
+#undef FUNC_NAME
+
+\f
+/* SRP credentials. */
+
+SCM_DEFINE (scm_gnutls_make_srp_server_credentials,
+ "make-srp-server-credentials",
+ 0, 0, 0,
+ (void),
+ "Return new SRP server credentials.")
+#define FUNC_NAME s_scm_gnutls_make_srp_server_credentials
+{
+ int err;
+ gnutls_srp_server_credentials_t c_cred;
+
+ err = gnutls_srp_allocate_server_credentials (&c_cred);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_srp_server_credentials (c_cred));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_srp_server_credentials_files_x,
+ "set-srp-server-credentials-files!",
+ 3, 0, 0,
+ (SCM cred, SCM password_file, SCM password_conf_file),
+ "Set the credentials files for @var{cred}, an SRP server "
+ "credentials object.")
+#define FUNC_NAME s_scm_gnutls_set_srp_server_credentials_files_x
+{
+ int err;
+ gnutls_srp_server_credentials_t c_cred;
+ char *c_password_file, *c_password_conf_file;
+ size_t c_password_file_len, c_password_conf_file_len;
+
+ c_cred = scm_to_gnutls_srp_server_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, password_file);
+ SCM_VALIDATE_STRING (3, password_conf_file);
+
+ c_password_file_len = scm_c_string_length (password_file);
+ c_password_conf_file_len = scm_c_string_length (password_conf_file);
+
+ c_password_file = (char *) alloca (c_password_file_len + 1);
+ c_password_conf_file = (char *) alloca (c_password_conf_file_len + 1);
+
+ (void) scm_to_locale_stringbuf (password_file, c_password_file,
+ c_password_file_len + 1);
+ c_password_file[c_password_file_len] = '\0';
+ (void) scm_to_locale_stringbuf (password_conf_file, c_password_conf_file,
+ c_password_conf_file_len + 1);
+ c_password_conf_file[c_password_conf_file_len] = '\0';
+
+ err = gnutls_srp_set_server_credentials_file (c_cred, c_password_file,
+ c_password_conf_file);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_make_srp_client_credentials,
+ "make-srp-client-credentials",
+ 0, 0, 0,
+ (void),
+ "Return new SRP client credentials.")
+#define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
+{
+ int err;
+ gnutls_srp_client_credentials_t c_cred;
+
+ err = gnutls_srp_allocate_client_credentials (&c_cred);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_srp_client_credentials (c_cred));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_gnutls_set_srp_client_credentials_x,
+ "set-srp-client-credentials!",
+ 3, 0, 0,
+ (SCM cred, SCM username, SCM password),
+ "Use @var{username} and @var{password} as the credentials "
+ "for @var{cred}, a client-side SRP credentials object.")
+#define FUNC_NAME s_scm_gnutls_make_srp_client_credentials
+{
+ int err;
+ gnutls_srp_client_credentials_t c_cred;
+ char *c_username, *c_password;
+ size_t c_username_len, c_password_len;
+
+ c_cred = scm_to_gnutls_srp_client_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, username);
+ SCM_VALIDATE_STRING (3, password);
+
+ c_username_len = scm_c_string_length (username);
+ c_password_len = scm_c_string_length (password);
+
+ c_username = (char *) alloca (c_username_len + 1);
+ c_password = (char *) alloca (c_password_len + 1);
+
+ (void) scm_to_locale_stringbuf (username, c_username,
+ c_username_len + 1);
+ c_username[c_username_len] = '\0';
+ (void) scm_to_locale_stringbuf (password, c_password,
+ c_password_len + 1);
+ c_password[c_password_len] = '\0';
+
+ err = gnutls_srp_set_client_credentials (c_cred, c_username,
+ c_password);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_server_session_srp_username,
+ "server-session-srp-username",
+ 1, 0, 0,
+ (SCM session),
+ "Return the SRP username used in @var{session} (a server-side "
+ "session).")
+#define FUNC_NAME s_scm_gnutls_server_session_srp_username
+{
+ SCM result;
+ const char *c_username;
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ c_username = gnutls_srp_server_get_username (c_session);
+
+ if (EXPECT_FALSE (c_username == NULL))
+ result = SCM_BOOL_F;
+ else
+ result = scm_from_locale_string (c_username);
+
+ return (result);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_srp_base64_encode, "srp-base64-encode",
+ 1, 0, 0,
+ (SCM str),
+ "Encode @var{str} using SRP's base64 algorithm. Return "
+ "the encoded string.")
+#define FUNC_NAME s_scm_gnutls_srp_base64_encode
+{
+ int err;
+ char *c_str, *c_result;
+ size_t c_str_len, c_result_len, c_result_actual_len;
+ gnutls_datum_t c_str_d;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ c_str_len = scm_c_string_length (str);
+ c_str = (char *) alloca (c_str_len + 1);
+ (void) scm_to_locale_stringbuf (str, c_str, c_str_len + 1);
+ c_str[c_str_len] = '\0';
+
+ /* Typical size ratio is 4/3 so 3/2 is an upper bound. */
+ c_result_len = (c_str_len * 3) / 2;
+ c_result = (char *) scm_malloc (c_result_len);
+ if (EXPECT_FALSE (c_result == NULL))
+ scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
+
+ c_str_d.data = (unsigned char *) c_str;
+ c_str_d.size = c_str_len;
+
+ do
+ {
+ c_result_actual_len = c_result_len;
+ err = gnutls_srp_base64_encode (&c_str_d, c_result,
+ &c_result_actual_len);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ char *c_new_buf;
+
+ c_new_buf = scm_realloc (c_result, c_result_len * 2);
+ if (EXPECT_FALSE (c_new_buf == NULL))
+ {
+ free (c_result);
+ scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
+ }
+ else
+ c_result = c_new_buf, c_result_len *= 2;
+ }
+ }
+ while (EXPECT_FALSE (err == GNUTLS_E_SHORT_MEMORY_BUFFER));
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ if (c_result_actual_len + 1 < c_result_len)
+ /* Shrink the buffer. */
+ c_result = scm_realloc (c_result, c_result_actual_len + 1);
+
+ c_result[c_result_actual_len] = '\0';
+
+ return (scm_take_locale_string (c_result));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_srp_base64_decode, "srp-base64-decode",
+ 1, 0, 0,
+ (SCM str),
+ "Decode @var{str}, an SRP-base64 encoded string, and return "
+ "the decoded string.")
+#define FUNC_NAME s_scm_gnutls_srp_base64_decode
+{
+ int err;
+ char *c_str, *c_result;
+ size_t c_str_len, c_result_len, c_result_actual_len;
+ gnutls_datum_t c_str_d;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ c_str_len = scm_c_string_length (str);
+ c_str = (char *) alloca (c_str_len + 1);
+ (void) scm_to_locale_stringbuf (str, c_str, c_str_len + 1);
+ c_str[c_str_len] = '\0';
+
+ /* We assume that the decoded string is smaller than the encoded
+ string. */
+ c_result_len = c_str_len;
+ c_result = (char *) alloca (c_result_len);
+
+ c_str_d.data = (unsigned char *) c_str;
+ c_str_d.size = c_str_len;
+
+ c_result_actual_len = c_result_len;
+ err = gnutls_srp_base64_decode (&c_str_d, c_result,
+ &c_result_actual_len);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ c_result[c_result_actual_len] = '\0';
+
+ return (scm_from_locale_string (c_result));
+}
+#undef FUNC_NAME
+
+\f
+/* PSK credentials. */
+
+SCM_DEFINE (scm_gnutls_make_psk_server_credentials,
+ "make-psk-server-credentials",
+ 0, 0, 0,
+ (void),
+ "Return new PSK server credentials.")
+#define FUNC_NAME s_scm_gnutls_make_psk_server_credentials
+{
+ int err;
+ gnutls_psk_server_credentials_t c_cred;
+
+ err = gnutls_psk_allocate_server_credentials (&c_cred);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_psk_server_credentials (c_cred));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_psk_server_credentials_file_x,
+ "set-psk-server-credentials-file!",
+ 2, 0, 0,
+ (SCM cred, SCM file),
+ "Use @var{file} as the password file for PSK server "
+ "credentials @var{cred}.")
+#define FUNC_NAME s_scm_gnutls_set_psk_server_credentials_file_x
+{
+ int err;
+ gnutls_psk_server_credentials_t c_cred;
+ char *c_file;
+ size_t c_file_len;
+
+ c_cred = scm_to_gnutls_psk_server_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, file);
+
+ c_file_len = scm_c_string_length (file);
+ c_file = (char *) alloca (c_file_len + 1);
+
+ (void) scm_to_locale_stringbuf (file, c_file, c_file_len + 1);
+ c_file[c_file_len] = '\0';
+
+ err = gnutls_psk_set_server_credentials_file (c_cred, c_file);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_make_psk_client_credentials,
+ "make-psk-client-credentials",
+ 0, 0, 0,
+ (void),
+ "Return a new PSK client credentials object.")
+#define FUNC_NAME s_scm_gnutls_make_psk_client_credentials
+{
+ int err;
+ gnutls_psk_client_credentials_t c_cred;
+
+ err = gnutls_psk_allocate_client_credentials (&c_cred);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_psk_client_credentials (c_cred));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_psk_client_credentials_x,
+ "set-psk-client-credentials!",
+ 4, 0, 0,
+ (SCM cred, SCM username, SCM key, SCM key_format),
+ "Set the client credentials for @var{cred}, a PSK client "
+ "credentials object.")
+#define FUNC_NAME s_scm_gnutls_set_psk_client_credentials_x
+{
+ int err;
+ gnutls_psk_client_credentials_t c_cred;
+ gnutls_psk_key_flags c_key_format;
+ scm_t_array_handle c_handle;
+ const char *c_key;
+ char *c_username;
+ size_t c_username_len, c_key_len;
+ gnutls_datum_t c_datum;
+
+ c_cred = scm_to_gnutls_psk_client_credentials (cred, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, username);
+ SCM_VALIDATE_ARRAY (3, key);
+ c_key_format = scm_to_gnutls_psk_key_format (key_format, 4, FUNC_NAME);
+
+ c_username_len = scm_c_string_length (username);
+ c_username = (char *) alloca (c_username_len + 1);
+
+ (void) scm_to_locale_stringbuf (username, c_username,
+ c_username_len + 1);
+ c_username[c_username_len] = '\0';
+
+ c_key = scm_gnutls_get_array (key, &c_handle, &c_key_len, FUNC_NAME);
+ c_datum.data = (unsigned char *) c_key;
+ c_datum.size = c_key_len;
+
+ err = gnutls_psk_set_client_credentials (c_cred, c_username,
+ &c_datum, c_key_format);
+ scm_gnutls_release_array (&c_handle);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_server_session_psk_username,
+ "server-session-psk-username",
+ 1, 0, 0,
+ (SCM session),
+ "Return the username associated with PSK server session "
+ "@var{session}.")
+#define FUNC_NAME s_scm_gnutls_server_session_psk_username
+{
+ SCM result;
+ const char *c_username;
+ gnutls_session_t c_session;
+
+ c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
+ c_username = gnutls_srp_server_get_username (c_session);
+
+ if (EXPECT_FALSE (c_username == NULL))
+ result = SCM_BOOL_F;
+ else
+ result = scm_from_locale_string (c_username);
+
+ return (result);
+}
+#undef FUNC_NAME
+
+\f
+/* X.509 certificates. */
+
+SCM_DEFINE (scm_gnutls_import_x509_certificate, "import-x509-certificate",
+ 2, 0, 0,
+ (SCM data, SCM format),
+ "Return a new X.509 certificate object resulting from the "
+ "import of @var{data} (a uniform array) according to "
+ "@var{format}.")
+#define FUNC_NAME s_scm_gnutls_import_x509_certificate
+{
+ int err;
+ gnutls_x509_crt_t c_cert;
+ gnutls_x509_crt_fmt_t c_format;
+ gnutls_datum_t c_data_d;
+ scm_t_array_handle c_data_handle;
+ const char *c_data;
+ size_t c_data_len;
+
+ SCM_VALIDATE_ARRAY (1, data);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+
+ c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
+ FUNC_NAME);
+ c_data_d.data = (unsigned char *) c_data;
+ c_data_d.size = c_data_len;
+
+ err = gnutls_x509_crt_init (&c_cert);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_data_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_x509_crt_import (c_cert, &c_data_d, c_format);
+ scm_gnutls_release_array (&c_data_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_x509_crt_deinit (c_cert);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_x509_certificate (c_cert));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_import_x509_private_key, "import-x509-private-key",
+ 2, 0, 0,
+ (SCM data, SCM format),
+ "Return a new X.509 private key object resulting from the "
+ "import of @var{data} (a uniform array) according to "
+ "@var{format}.")
+#define FUNC_NAME s_scm_gnutls_import_x509_private_key
+{
+ int err;
+ gnutls_x509_privkey_t c_key;
+ gnutls_x509_crt_fmt_t c_format;
+ gnutls_datum_t c_data_d;
+ scm_t_array_handle c_data_handle;
+ const char *c_data;
+ size_t c_data_len;
+
+ SCM_VALIDATE_ARRAY (1, data);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+
+ c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
+ FUNC_NAME);
+ c_data_d.data = (unsigned char *) c_data;
+ c_data_d.size = c_data_len;
+
+ err = gnutls_x509_privkey_init (&c_key);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_data_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_x509_privkey_import (c_key, &c_data_d, c_format);
+ scm_gnutls_release_array (&c_data_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_x509_privkey_deinit (c_key);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_x509_private_key (c_key));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_pkcs8_import_x509_private_key,
+ "pkcs8-import-x509-private-key",
+ 2, 2, 0,
+ (SCM data, SCM format, SCM pass, SCM encrypted),
+ "Return a new X.509 private key object resulting from the "
+ "import of @var{data} (a uniform array) according to "
+ "@var{format}. Optionally, if @var{pass} is not @code{#f}, "
+ "it should be a string denoting a passphrase. "
+ "@var{encrypted} tells whether the private key is encrypted "
+ "(@code{#t} by default).")
+#define FUNC_NAME s_scm_gnutls_pkcs8_import_x509_private_key
+{
+ int err;
+ gnutls_x509_privkey_t c_key;
+ gnutls_x509_crt_fmt_t c_format;
+ unsigned int c_flags;
+ gnutls_datum_t c_data_d;
+ scm_t_array_handle c_data_handle;
+ const char *c_data;
+ char *c_pass;
+ size_t c_data_len, c_pass_len;
+
+ SCM_VALIDATE_ARRAY (1, data);
+ c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
+ if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
+ c_pass = NULL;
+ else
+ {
+ c_pass_len = scm_c_string_length (pass);
+ c_pass = (char *) alloca (c_pass_len + 1);
+ (void) scm_to_locale_stringbuf (pass, c_pass, c_pass_len + 1);
+ c_pass[c_pass_len] = '\0';
+ }
+
+ if (encrypted == SCM_UNDEFINED)
+ c_flags = 0;
+ else
+ {
+ SCM_VALIDATE_BOOL (4, encrypted);
+ if (scm_is_true (encrypted))
+ c_flags = 0;
+ else
+ c_flags = GNUTLS_PKCS8_PLAIN;
+ }
+
+ c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
+ FUNC_NAME);
+ c_data_d.data = (unsigned char *) c_data;
+ c_data_d.size = c_data_len;
+
+ err = gnutls_x509_privkey_init (&c_key);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_data_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_x509_privkey_import_pkcs8 (c_key, &c_data_d, c_format, c_pass,
+ c_flags);
+ scm_gnutls_release_array (&c_data_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_x509_privkey_deinit (c_key);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_x509_private_key (c_key));
+}
+#undef FUNC_NAME
+
+/* Provide the body of a `get_dn' function. */
+#define X509_CERTIFICATE_DN_FUNCTION_BODY(get_the_dn) \
+ int err; \
+ gnutls_x509_crt_t c_cert; \
+ char *c_dn; \
+ size_t c_dn_len; \
+ \
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); \
+ \
+ /* Get the DN size. */ \
+ (void) get_the_dn (c_cert, NULL, &c_dn_len); \
+ \
+ /* Get the DN itself. */ \
+ c_dn = (char *) alloca (c_dn_len); \
+ err = get_the_dn (c_cert, c_dn, &c_dn_len); \
+ \
+ if (EXPECT_FALSE (err)) \
+ scm_gnutls_error (err, FUNC_NAME); \
+ \
+ /* XXX: The returned string is actually ASCII or UTF-8. */ \
+ return (scm_from_locale_string (c_dn));
+
+SCM_DEFINE (scm_gnutls_x509_certificate_dn, "x509-certificate-dn",
+ 1, 0, 0,
+ (SCM cert),
+ "Return the distinguished name (DN) of X.509 certificate "
+ "@var{cert}. The form of the DN is as described in @uref{"
+ "http://tools.ietf.org/html/rfc2253, RFC 2253}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_dn
+{
+ X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_dn);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn,
+ "x509-certificate-issuer-dn",
+ 1, 0, 0,
+ (SCM cert),
+ "Return the distinguished name (DN) of X.509 certificate "
+ "@var{cert}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn
+{
+ X509_CERTIFICATE_DN_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn);
+}
+#undef FUNC_NAME
+
+#undef X509_CERTIFICATE_DN_FUNCTION_BODY
+
+
+/* Provide the body of a `get_dn_oid' function. */
+#define X509_CERTIFICATE_DN_OID_FUNCTION_BODY(get_dn_oid) \
+ int err; \
+ gnutls_x509_crt_t c_cert; \
+ unsigned int c_index; \
+ char *c_oid; \
+ size_t c_oid_actual_len, c_oid_len; \
+ SCM result; \
+ \
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); \
+ c_index = scm_to_uint (index); \
+ \
+ c_oid_len = 256; \
+ c_oid = scm_malloc (c_oid_len); \
+ \
+ do \
+ { \
+ c_oid_actual_len = c_oid_len; \
+ err = get_dn_oid (c_cert, c_index, c_oid, &c_oid_actual_len); \
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) \
+ { \
+ c_oid = scm_realloc (c_oid, c_oid_len * 2); \
+ c_oid_len *= 2; \
+ } \
+ } \
+ while (err == GNUTLS_E_SHORT_MEMORY_BUFFER); \
+ \
+ if (EXPECT_FALSE (err)) \
+ { \
+ free (c_oid); \
+ \
+ if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE) \
+ result = SCM_BOOL_F; \
+ else \
+ scm_gnutls_error (err, FUNC_NAME); \
+ } \
+ else \
+ { \
+ if (c_oid_actual_len < c_oid_len) \
+ c_oid = scm_realloc (c_oid, c_oid_actual_len); \
+ \
+ result = scm_take_locale_string (c_oid); \
+ } \
+ \
+ return result;
+
+SCM_DEFINE (scm_gnutls_x509_certificate_dn_oid, "x509-certificate-dn-oid",
+ 2, 0, 0,
+ (SCM cert, SCM index),
+ "Return OID (a string) at @var{index} from @var{cert}. "
+ "Return @code{#f} if no OID is available at @var{index}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_dn_oid
+{
+ X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_dn_oid);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_issuer_dn_oid,
+ "x509-certificate-issuer-dn-oid",
+ 2, 0, 0,
+ (SCM cert, SCM index),
+ "Return the OID (a string) at @var{index} from @var{cert}'s "
+ "issuer DN. Return @code{#f} if no OID is available at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_issuer_dn_oid
+{
+ X509_CERTIFICATE_DN_OID_FUNCTION_BODY (gnutls_x509_crt_get_issuer_dn_oid);
+}
+#undef FUNC_NAME
+
+#undef X509_CERTIFICATE_DN_OID_FUNCTION_BODY
+
+
+SCM_DEFINE (scm_gnutls_x509_certificate_matches_hostname_p,
+ "x509-certificate-matches-hostname?",
+ 2, 0, 0,
+ (SCM cert, SCM hostname),
+ "Return true if @var{cert} matches @var{hostname}, a string "
+ "denoting a DNS host name. This is the basic implementation "
+ "of @uref{http://tools.ietf.org/html/rfc2818, RFC 2818} (aka. "
+ "HTTPS).")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_matches_hostname_p
+{
+ SCM result;
+ gnutls_x509_crt_t c_cert;
+ char *c_hostname;
+ size_t c_hostname_len;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, hostname);
+
+ c_hostname_len = scm_c_string_length (hostname);
+ c_hostname = (char *) alloca (c_hostname_len + 1);
+
+ (void) scm_to_locale_stringbuf (hostname, c_hostname, c_hostname_len + 1);
+ c_hostname[c_hostname_len] = '\0';
+
+ if (gnutls_x509_crt_check_hostname (c_cert, c_hostname))
+ result = SCM_BOOL_T;
+ else
+ result = SCM_BOOL_F;
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_signature_algorithm,
+ "x509-certificate-signature-algorithm",
+ 1, 0, 0,
+ (SCM cert),
+ "Return the signature algorithm used by @var{cert} (i.e., "
+ "one of the @code{sign-algorithm/} values).")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_signature_algorithm
+{
+ int c_result;
+ gnutls_x509_crt_t c_cert;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+
+ c_result = gnutls_x509_crt_get_signature_algorithm (c_cert);
+ if (EXPECT_FALSE (c_result < 0))
+ scm_gnutls_error (c_result, FUNC_NAME);
+
+ return (scm_from_gnutls_sign_algorithm (c_result));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_public_key_algorithm,
+ "x509-certificate-public-key-algorithm",
+ 1, 0, 0,
+ (SCM cert),
+ "Return two values: the public key algorithm (i.e., "
+ "one of the @code{pk-algorithm/} values) of @var{cert} "
+ "and the number of bits used.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_public_key_algorithm
+{
+ gnutls_x509_crt_t c_cert;
+ gnutls_pk_algorithm_t c_pk;
+ unsigned int c_bits;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+
+ c_pk = gnutls_x509_crt_get_pk_algorithm (c_cert, &c_bits);
+
+ return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_pk),
+ scm_from_uint (c_bits))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_key_usage,
+ "x509-certificate-key-usage",
+ 1, 0, 0,
+ (SCM cert),
+ "Return the key usage of @var{cert} (i.e., a list of "
+ "@code{key-usage/} values), or the empty list if @var{cert} "
+ "does not contain such information.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_key_usage
+{
+ int err;
+ SCM usage;
+ gnutls_x509_crt_t c_cert;
+ unsigned int c_usage, c_critical;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+
+ err = gnutls_x509_crt_get_key_usage (c_cert, &c_usage, &c_critical);
+ if (EXPECT_FALSE (err))
+ {
+ if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE)
+ usage = SCM_EOL;
+ else
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+ else
+ usage = scm_from_gnutls_key_usage_flags (c_usage);
+
+ return usage;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_version, "x509-certificate-version",
+ 1, 0, 0,
+ (SCM cert),
+ "Return the version of @var{cert}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_version
+{
+ int c_result;
+ gnutls_x509_crt_t c_cert;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+
+ c_result = gnutls_x509_crt_get_version (c_cert);
+ if (EXPECT_FALSE (c_result < 0))
+ scm_gnutls_error (c_result, FUNC_NAME);
+
+ return (scm_from_int (c_result));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_key_id, "x509-certificate-key-id",
+ 1, 0, 0,
+ (SCM cert),
+ "Return a statistically unique ID (a u8vector) for @var{cert} "
+ "that depends on its public key parameters. This is normally "
+ "a 20-byte SHA-1 hash.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_key_id
+{
+ int err;
+ SCM result;
+ scm_t_array_handle c_id_handle;
+ gnutls_x509_crt_t c_cert;
+ scm_t_uint8 *c_id;
+ size_t c_id_len = 20;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+
+ result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
+ scm_array_get_handle (result, &c_id_handle);
+ c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
+
+ err = gnutls_x509_crt_get_key_id (c_cert, 0, c_id, &c_id_len);
+ scm_array_handle_release (&c_id_handle);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_authority_key_id,
+ "x509-certificate-authority-key-id",
+ 1, 0, 0,
+ (SCM cert),
+ "Return the key ID (a u8vector) of the X.509 certificate "
+ "authority of @var{cert}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_authority_key_id
+{
+ int err;
+ SCM result;
+ scm_t_array_handle c_id_handle;
+ gnutls_x509_crt_t c_cert;
+ scm_t_uint8 *c_id;
+ size_t c_id_len = 20;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+
+ result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
+ scm_array_get_handle (result, &c_id_handle);
+ c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
+
+ err = gnutls_x509_crt_get_authority_key_id (c_cert, c_id, &c_id_len,
+ NULL);
+ scm_array_handle_release (&c_id_handle);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_subject_key_id,
+ "x509-certificate-subject-key-id",
+ 1, 0, 0,
+ (SCM cert),
+ "Return the subject key ID (a u8vector) for @var{cert}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_subject_key_id
+{
+ int err;
+ SCM result;
+ scm_t_array_handle c_id_handle;
+ gnutls_x509_crt_t c_cert;
+ scm_t_uint8 *c_id;
+ size_t c_id_len = 20;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+
+ result = scm_make_u8vector (scm_from_uint (c_id_len), SCM_INUM0);
+ scm_array_get_handle (result, &c_id_handle);
+ c_id = scm_array_handle_u8_writable_elements (&c_id_handle);
+
+ err = gnutls_x509_crt_get_subject_key_id (c_cert, c_id, &c_id_len,
+ NULL);
+ scm_array_handle_release (&c_id_handle);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_subject_alternative_name,
+ "x509-certificate-subject-alternative-name",
+ 2, 0, 0,
+ (SCM cert, SCM index),
+ "Return two values: the alternative name type for @var{cert} "
+ "(i.e., one of the @code{x509-subject-alternative-name/} values) "
+ "and the actual subject alternative name (a string) at "
+ "@var{index}. Both values are @code{#f} if no alternative name "
+ "is available at @var{index}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_subject_alternative_name
+{
+ int err;
+ SCM result;
+ gnutls_x509_crt_t c_cert;
+ unsigned int c_index;
+ char *c_name;
+ size_t c_name_len = 512, c_name_actual_len;
+
+ c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+ c_index = scm_to_uint (index);
+
+ c_name = scm_malloc (c_name_len);
+ do
+ {
+ c_name_actual_len = c_name_len;
+ err = gnutls_x509_crt_get_subject_alt_name (c_cert, c_index,
+ c_name, &c_name_actual_len,
+ NULL);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ c_name = scm_realloc (c_name, c_name_len * 2);
+ c_name_len *= 2;
+ }
+ }
+ while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
+
+ if (EXPECT_FALSE (err < 0))
+ {
+ free (c_name);
+
+ if (err == GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE)
+ result = scm_values (scm_list_2 (SCM_BOOL_F, SCM_BOOL_F));
+ else
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+ else
+ {
+ if (c_name_actual_len < c_name_len)
+ c_name = scm_realloc (c_name, c_name_actual_len);
+
+ result =
+ scm_values (scm_list_2
+ (scm_from_gnutls_x509_subject_alternative_name (err),
+ scm_take_locale_string (c_name)));
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+\f
+/* Debugging. */
+
+static SCM log_procedure = SCM_BOOL_F;
+
+static void
+scm_gnutls_log (int level, const char *str)
+{
+ if (scm_is_true (log_procedure))
+ (void) scm_call_2 (log_procedure, scm_from_int (level),
+ scm_from_locale_string (str));
+}
+
+SCM_DEFINE (scm_gnutls_set_log_procedure_x, "set-log-procedure!",
+ 1, 0, 0,
+ (SCM proc),
+ "Use @var{proc} (a two-argument procedure) as the global "
+ "GnuTLS log procedure.")
+#define FUNC_NAME s_scm_gnutls_set_log_procedure_x
+{
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_true (log_procedure))
+ (void) scm_gc_unprotect_object (log_procedure);
+
+ log_procedure = scm_gc_protect_object (proc);
+ gnutls_global_set_log_function (scm_gnutls_log);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_set_log_level_x, "set-log-level!", 1, 0, 0,
+ (SCM level),
+ "Enable GnuTLS logging up to @var{level} (an integer).")
+#define FUNC_NAME s_scm_gnutls_set_log_level_x
+{
+ unsigned int c_level;
+
+ c_level = scm_to_uint (level);
+ gnutls_global_set_log_level (c_level);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* Initialization. */
+
+void
+scm_init_gnutls (void)
+{
+#include "core.c.x"
+
+ (void) gnutls_global_init ();
+
+ scm_gnutls_define_enums ();
+
+ scm_init_gnutls_error ();
+
+ scm_init_gnutls_session_record_port_type ();
+}
+
+/* arch-tag: 58420abe-0769-4684-b522-da7f32f4474c
+ */
--- /dev/null
+/* GNUTLS --- Guile bindings for GnuTLS.
+ Copyright (C) 2007 Free Software Foundation
+
+ GNUTLS 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.
+
+ GNUTLS 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 GNUTLS; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
+
+/* Written by Ludovic Courtès <ludo@chbouib.org>. */
+
+#include <libguile.h>
+#include <gnutls/gnutls.h>
+
+#include "errors.h"
+#include "enums.h"
+
+SCM_SYMBOL (gnutls_error_key, "gnutls-error");
+
+void
+scm_gnutls_error (int c_err, const char *c_func)
+{
+ SCM err, func;
+
+ /* Note: If error code C_ERR is unknown, then ERR will be `#f'. */
+ err = scm_from_gnutls_error (c_err);
+ func = scm_from_locale_symbol (c_func);
+
+ (void) scm_throw (gnutls_error_key, scm_list_2 (err, func));
+
+ /* XXX: This is actually never reached, but since the Guile headers don't
+ declare `scm_throw ()' as `noreturn', we must add this to avoid GCC's
+ complaints. */
+ abort ();
+}
+
+\f
+void
+scm_init_gnutls_error (void)
+{
+#include "errors.c.x"
+}
+
+/* arch-tag: 48f07ecf-65c4-480c-b043-a51eab592d6b
+ */
--- /dev/null
+/* GNUTLS --- Guile bindings for GnuTLS.
+ Copyright (C) 2007 Free Software Foundation
+
+ GNUTLS 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.
+
+ GNUTLS 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 GNUTLS; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
+
+#ifndef GUILE_GNUTLS_ERRORS_H
+#define GUILE_GNUTLS_ERRORS_H
+
+#include <libguile.h>
+
+#include "utils.h"
+
+SCM_API void scm_gnutls_error (int, const char *) NO_RETURN;
+SCM_API void scm_init_gnutls_error (void);
+
+#endif
+
+/* arch-tag: e7a92e44-b399-4c85-99d4-2dd3564600f7
+ */
--- /dev/null
+/* GNUTLS-EXTRA --- Guile bindings for GNUTLS-EXTRA.
+ Copyright (C) 2007 Free Software Foundation
+
+ GNUTLS-EXTRA is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ GNUTLS-EXTRA 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 General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNUTLS-EXTRA; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/* Important note: As written above, this part of the code is ditributed
+ under the GPL, not the LGPL. */
+
+/* Written by Ludovic Courtès <ludo@chbouib.org>. */
+
+
+#include <stdio.h>
+#include <gnutls/gnutls.h>
+#include <gnutls/extra.h>
+#include <gnutls/openpgp.h>
+#include <libguile.h>
+
+#include <alloca.h>
+
+#include "errors.h"
+#include "utils.h"
+#include "smobs.h"
+#include "enums.h"
+#include "extra-enums.h"
+#include "extra-smobs.h"
+
+
+\f
+/* SMOB and enums type definitions. */
+
+#include "extra-smob-types.i.c"
+#include "extra-enum-map.i.c"
+
+\f
+/* OpenPGP keys. */
+
+
+/* Maximum size we support for the name of OpenPGP keys. */
+#define GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH 2048
+
+SCM_DEFINE (scm_gnutls_import_openpgp_public_key, "import-openpgp-public-key",
+ 2, 0, 0,
+ (SCM data, SCM format),
+ "Return a new OpenPGP public key object resulting from the "
+ "import of @var{data} (a uniform array) according to "
+ "@var{format}.")
+#define FUNC_NAME s_scm_gnutls_import_openpgp_public_key
+{
+ int err;
+ gnutls_openpgp_key_t c_key;
+ gnutls_openpgp_key_fmt c_format;
+ gnutls_datum_t c_data_d;
+ scm_t_array_handle c_data_handle;
+ const char *c_data;
+ size_t c_data_len;
+
+ SCM_VALIDATE_ARRAY (1, data);
+ c_format = scm_to_gnutls_openpgp_key_format (format, 2, FUNC_NAME);
+
+ c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
+ FUNC_NAME);
+ c_data_d.data = (unsigned char *) c_data;
+ c_data_d.size = c_data_len;
+
+ err = gnutls_openpgp_key_init (&c_key);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_data_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_openpgp_key_import (c_key, &c_data_d, c_format);
+ scm_gnutls_release_array (&c_data_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_openpgp_key_deinit (c_key);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_openpgp_public_key (c_key));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_import_openpgp_private_key, "import-openpgp-private-key",
+ 2, 1, 0,
+ (SCM data, SCM format, SCM pass),
+ "Return a new OpenPGP private key object resulting from the "
+ "import of @var{data} (a uniform array) according to "
+ "@var{format}. Optionally, a passphrase may be provided.")
+#define FUNC_NAME s_scm_gnutls_import_openpgp_private_key
+{
+ int err;
+ gnutls_openpgp_privkey_t c_key;
+ gnutls_openpgp_key_fmt c_format;
+ gnutls_datum_t c_data_d;
+ scm_t_array_handle c_data_handle;
+ const char *c_data;
+ char *c_pass;
+ size_t c_data_len, c_pass_len;
+
+ SCM_VALIDATE_ARRAY (1, data);
+ c_format = scm_to_gnutls_openpgp_key_format (format, 2, FUNC_NAME);
+ if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
+ c_pass = NULL;
+ else
+ {
+ c_pass_len = scm_c_string_length (pass);
+ c_pass = (char *) alloca (c_pass_len + 1);
+ (void) scm_to_locale_stringbuf (pass, c_pass, c_pass_len + 1);
+ c_pass[c_pass_len] = '\0';
+ }
+
+ c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
+ FUNC_NAME);
+ c_data_d.data = (unsigned char *) c_data;
+ c_data_d.size = c_data_len;
+
+ err = gnutls_openpgp_privkey_init (&c_key);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_data_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_openpgp_privkey_import (c_key, &c_data_d, c_format, c_pass,
+ 0 /* currently unused */);
+ scm_gnutls_release_array (&c_data_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_openpgp_privkey_deinit (c_key);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_openpgp_private_key (c_key));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_id, "openpgp-public-key-id",
+ 1, 0, 0,
+ (SCM key),
+ "Return the ID (an 8-element u8vector) of public key "
+ "@var{key}.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_id
+{
+ int err;
+ unsigned char *c_id;
+ gnutls_openpgp_key_t c_key;
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+
+ c_id = (unsigned char * ) malloc (8);
+ if (c_id == NULL)
+ scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
+
+ err = gnutls_openpgp_key_get_id (c_key, c_id);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_take_u8vector (c_id, 8));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_id_x, "openpgp-public-key-id!",
+ 2, 0, 0,
+ (SCM key, SCM id),
+ "Store the ID (an 8 byte sequence) of public key "
+ "@var{key} in @var{id} (a u8vector).")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_id_x
+{
+ int err;
+ char *c_id;
+ scm_t_array_handle c_id_handle;
+ size_t c_id_size;
+ gnutls_openpgp_key_t c_key;
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+ c_id = scm_gnutls_get_writable_array (id, &c_id_handle, &c_id_size,
+ FUNC_NAME);
+
+ if (EXPECT_FALSE (c_id_size < 8))
+ {
+ scm_gnutls_release_array (&c_id_handle);
+ scm_misc_error (FUNC_NAME, "ID vector too small: ~A",
+ scm_list_1 (id));
+ }
+
+ err = gnutls_openpgp_key_get_id (c_key, (unsigned char *) c_id);
+ scm_gnutls_release_array (&c_id_handle);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_fingerpint_x,
+ "openpgp-public-key-fingerprint!",
+ 2, 0, 0,
+ (SCM key, SCM fpr),
+ "Store in @var{fpr} (a u8vector) the fingerprint of @var{key}. "
+ "Return the number of bytes stored in @var{fpr}.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_fingerpint_x
+{
+ int err;
+ gnutls_openpgp_key_t c_key;
+ char *c_fpr;
+ scm_t_array_handle c_fpr_handle;
+ size_t c_fpr_len, c_actual_len = 0;
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+ SCM_VALIDATE_ARRAY (2, fpr);
+
+ c_fpr = scm_gnutls_get_writable_array (fpr, &c_fpr_handle, &c_fpr_len,
+ FUNC_NAME);
+
+ err = gnutls_openpgp_key_get_fingerprint (c_key, c_fpr, &c_actual_len);
+ scm_gnutls_release_array (&c_fpr_handle);
+
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_size_t (c_actual_len));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_fingerprint,
+ "openpgp-public-key-fingerprint",
+ 1, 0, 0,
+ (SCM key),
+ "Return a new u8vector denoting the fingerprint of "
+ "@var{key}.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_fingerprint
+{
+ int err;
+ gnutls_openpgp_key_t c_key;
+ unsigned char *c_fpr;
+ size_t c_fpr_len, c_actual_len;
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+
+ /* V4 fingerprints are 160-bit SHA-1 hashes (see RFC2440). */
+ c_fpr_len = 20;
+ c_fpr = (unsigned char *) malloc (c_fpr_len);
+ if (EXPECT_FALSE (c_fpr == NULL))
+ scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
+
+ do
+ {
+ c_actual_len = 0;
+ err = gnutls_openpgp_key_get_fingerprint (c_key, c_fpr,
+ &c_actual_len);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ /* Grow C_FPR. */
+ unsigned char *c_new;
+
+ c_new = (unsigned char *) realloc (c_fpr, c_fpr_len * 2);
+ if (EXPECT_FALSE (c_new == NULL))
+ {
+ free (c_fpr);
+ scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
+ }
+ else
+ {
+ c_fpr_len *= 2;
+ c_fpr = c_new;
+ }
+ }
+ }
+ while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
+
+ if (EXPECT_FALSE (err))
+ {
+ free (c_fpr);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ if (c_actual_len < c_fpr_len)
+ /* Shrink C_FPR. */
+ c_fpr = realloc (c_fpr, c_actual_len);
+
+ return (scm_take_u8vector (c_fpr, c_actual_len));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_name, "openpgp-public-key-name",
+ 2, 0, 0,
+ (SCM key, SCM index),
+ "Return the @var{index}th name of @var{key}.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_name
+{
+ int err;
+ gnutls_openpgp_key_t c_key;
+ int c_index;
+ char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
+ size_t c_name_len = sizeof (c_name);
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+ c_index = scm_to_int (index);
+
+ err = gnutls_openpgp_key_get_name (c_key, c_index, c_name,
+ &c_name_len);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ /* XXX: The name is really UTF-8. */
+ return (scm_from_locale_string (c_name));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_names, "openpgp-public-key-names",
+ 1, 0, 0,
+ (SCM key),
+ "Return the list of names for @var{key}.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_names
+{
+ int err;
+ SCM result = SCM_EOL;
+ gnutls_openpgp_key_t c_key;
+ int c_index = 0;
+ char c_name[GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH];
+ size_t c_name_len = sizeof (c_name);
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+
+ do
+ {
+ err = gnutls_openpgp_key_get_name (c_key, c_index, c_name,
+ &c_name_len);
+ if (!err)
+ {
+ result = scm_cons (scm_from_locale_string (c_name),
+ result);
+ c_index++;
+ }
+ }
+ while (!err);
+
+ if (EXPECT_FALSE (err != GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_reverse_x (result, SCM_EOL));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_algorithm,
+ "openpgp-public-key-algorithm",
+ 1, 0, 0,
+ (SCM key),
+ "Return two values: the public key algorithm used by "
+ "@var{key} and the number of bits used.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_algorithm
+{
+ gnutls_openpgp_key_t c_key;
+ unsigned int c_bits;
+ gnutls_pk_algorithm_t c_algo;
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+ c_algo = gnutls_openpgp_key_get_pk_algorithm (c_key, &c_bits);
+
+ return (scm_values (scm_list_2 (scm_from_gnutls_pk_algorithm (c_algo),
+ scm_from_uint (c_bits))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_version,
+ "openpgp-public-key-version",
+ 1, 0, 0,
+ (SCM key),
+ "Return the version of the OpenPGP message format (RFC2440) "
+ "honored by @var{key}.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_version
+{
+ int c_version;
+ gnutls_openpgp_key_t c_key;
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+ c_version = gnutls_openpgp_key_get_version (c_key);
+
+ return (scm_from_int (c_version));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_public_key_usage, "openpgp-public-key-usage",
+ 1, 0, 0,
+ (SCM key),
+ "Return a list of values denoting the key usage of @var{key}.")
+#define FUNC_NAME s_scm_gnutls_openpgp_public_key_usage
+{
+ int err;
+ unsigned int c_usage = 0;
+ gnutls_openpgp_key_t c_key;
+
+ c_key = scm_to_gnutls_openpgp_public_key (key, 1, FUNC_NAME);
+
+ err = gnutls_openpgp_key_get_key_usage (c_key, &c_usage);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return (scm_from_gnutls_key_usage_flags (c_usage));
+}
+#undef FUNC_NAME
+
+
+\f
+/* OpenPGP keyrings. */
+
+SCM_DEFINE (scm_gnutls_import_openpgp_keyring, "import-openpgp-keyring",
+ 2, 0, 0,
+ (SCM data, SCM format),
+ "Import @var{data} (a u8vector) according to @var{format} "
+ "and return the imported keyring.")
+#define FUNC_NAME s_scm_gnutls_import_openpgp_keyring
+{
+ int err;
+ gnutls_openpgp_keyring_t c_keyring;
+ gnutls_openpgp_key_fmt c_format;
+ gnutls_datum_t c_data_d;
+ scm_t_array_handle c_data_handle;
+ const char *c_data;
+ size_t c_data_len;
+
+ SCM_VALIDATE_ARRAY (1, data);
+ c_format = scm_to_gnutls_openpgp_key_format (format, 2, FUNC_NAME);
+
+ c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
+ FUNC_NAME);
+
+ c_data_d.data = (unsigned char *) c_data;
+ c_data_d.size = c_data_len;
+
+ err = gnutls_openpgp_keyring_init (&c_keyring);
+ if (EXPECT_FALSE (err))
+ {
+ scm_gnutls_release_array (&c_data_handle);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ err = gnutls_openpgp_keyring_import (c_keyring, &c_data_d, c_format);
+ scm_gnutls_release_array (&c_data_handle);
+
+ if (EXPECT_FALSE (err))
+ {
+ gnutls_openpgp_keyring_deinit (c_keyring);
+ scm_gnutls_error (err, FUNC_NAME);
+ }
+
+ return (scm_from_gnutls_openpgp_keyring (c_keyring));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_openpgp_keyring_contains_key_id_p,
+ "openpgp-keyring-contains-key-id?",
+ 2, 0, 0,
+ (SCM keyring, SCM id),
+ "Return @code{#f} if key ID @var{id} is in @var{keyring}, "
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_gnutls_openpgp_keyring_contains_key_id_p
+{
+ int c_result;
+ gnutls_openpgp_keyring_t c_keyring;
+ scm_t_array_handle c_id_handle;
+ const char *c_id;
+ size_t c_id_len;
+
+ c_keyring = scm_to_gnutls_openpgp_keyring (keyring, 1, FUNC_NAME);
+ SCM_VALIDATE_ARRAY (1, id);
+
+ c_id = scm_gnutls_get_array (id, &c_id_handle, &c_id_len,
+ FUNC_NAME);
+ if (EXPECT_FALSE (c_id_len != 8))
+ {
+ scm_gnutls_release_array (&c_id_handle);
+ scm_wrong_type_arg (FUNC_NAME, 1, id);
+ }
+
+ c_result = gnutls_openpgp_keyring_check_id (c_keyring,
+ (unsigned char *) c_id,
+ 0 /* unused */);
+
+ scm_gnutls_release_array (&c_id_handle);
+
+ return (scm_from_bool (c_result == 0));
+}
+#undef FUNC_NAME
+
+\f
+/* Certificates. */
+
+SCM_DEFINE (scm_gnutls_set_certificate_credentials_openpgp_keys_x,
+ "set-certificate-credentials-openpgp-keys!",
+ 3, 0, 0,
+ (SCM cred, SCM pub, SCM sec),
+ "Use public key @var{pub} and secret key @var{sec} in "
+ "certificate credentials @var{cred}.")
+#define FUNC_NAME s_scm_gnutls_set_certificate_credentials_openpgp_keys_x
+{
+ int err;
+ gnutls_certificate_credentials_t c_cred;
+ gnutls_openpgp_key_t c_pub;
+ gnutls_openpgp_privkey_t c_sec;
+
+ c_cred = scm_to_gnutls_certificate_credentials (cred, 1, FUNC_NAME);
+ c_pub = scm_to_gnutls_openpgp_public_key (pub, 2, FUNC_NAME);
+ c_sec = scm_to_gnutls_openpgp_private_key (sec, 3, FUNC_NAME);
+
+ err = gnutls_certificate_set_openpgp_key (c_cred, c_pub, c_sec);
+ if (EXPECT_FALSE (err))
+ scm_gnutls_error (err, FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* Initialization. */
+
+void
+scm_init_gnutls_extra (void)
+{
+#include "extra.c.x"
+
+ (void) gnutls_global_init_extra ();
+
+ scm_gnutls_define_enums ();
+}
+
+/* arch-tag: 655f308d-5643-4bc7-9db4-1f84bd902bef
+ */
--- /dev/null
+;;; Help produce Guile wrappers for GnuTLS types.
+;;;
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+(use-modules (gnutls build enums))
+
+\f
+;;;
+;;; The program.
+;;;
+
+(define (main . args)
+ (define extra? (not (null? args)))
+
+ (let ((port (current-output-port))
+ (enums (if (not extra?)
+ %gnutls-enums
+ %gnutls-extra-enums)))
+ (format port "/* Automatically generated, do not edit. */~%~%")
+ (format port "#ifndef GUILE_GNUTLS_~aENUMS_H~%"
+ (if extra? "EXTRA_" ""))
+ (format port "#define GUILE_GNUTLS_~aENUMS_H~%"
+ (if extra? "EXTRA_" ""))
+
+ (format port "#include \"config.h\"~%")
+ (format port "#include <gnutls/gnutls.h>~%")
+ (format port "#include <gnutls/x509.h>~%")
+
+ (if extra?
+ (begin
+ (format port "#include <gnutls/extra.h>~%")
+ (format port "#include <gnutls/openpgp.h>~%")))
+
+ (for-each (lambda (enum)
+ (output-enum-declarations enum port)
+ (output-enum->c-converter enum port)
+ (output-c->enum-converter enum port))
+ enums)
+ (format port "#endif~%")))
+
+(apply main (cdr (command-line)))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 07d834ca-e823-4663-9143-6d22704fbb5b
--- /dev/null
+;;; Help produce Guile wrappers for GnuTLS types.
+;;;
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+(use-modules (gnutls build enums))
+
+\f
+;;;
+;;; The program.
+;;;
+
+(define (main . args)
+ (let ((port (current-output-port))
+ (enums (if (null? args)
+ %gnutls-enums
+ %gnutls-extra-enums)))
+ (for-each (lambda (enum)
+ (output-enum-smob-definitions enum port))
+ enums)
+ (output-enum-definition-function enums port)))
+
+(apply main (cdr (command-line)))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 3deb7d3a-005d-4f83-a72a-7382ef1e74a0
--- /dev/null
+;;; Help produce Guile wrappers for GnuTLS types.
+;;;
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+(use-modules (gnutls build priorities))
+
+\f
+;;;
+;;; The program.
+;;;
+
+(define (main . args)
+ (let ((port (current-output-port)))
+ (for-each (lambda (priority)
+ (output-session-set-priority-function priority port))
+ %gnutls-priorities)))
+
+(main)
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 026228de-e6d6-421b-bf2f-aaf9630d6b73
--- /dev/null
+;;; Help produce Guile wrappers for GnuTLS types.
+;;;
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+(use-modules (gnutls build smobs))
+
+\f
+;;;
+;;; The program.
+;;;
+
+(define (main . args)
+ (define extra? (not (null? args)))
+
+ (let ((port (current-output-port))
+ (enums (if (not extra?)
+ %gnutls-smobs
+ %gnutls-extra-smobs)))
+ (format port "/* Automatically generated, do not edit. */~%~%")
+ (format port "#ifndef GUILE_GNUTLS_~aSMOBS_H~%"
+ (if extra? "EXTRA_" ""))
+ (format port "#define GUILE_GNUTLS_~aSMOBS_H~%"
+ (if extra? "EXTRA_" ""))
+ (for-each (lambda (type)
+ (output-smob-type-declaration type port)
+ (output-c->smob-converter type port)
+ (output-smob->c-converter type port))
+ enums)
+ (format port "#endif~%")))
+
+(apply main (cdr (command-line)))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 7ae9c82f-a423-4251-9a58-6e2581267567
--- /dev/null
+;;; Help produce Guile wrappers for GnuTLS types.
+;;;
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+(use-modules (gnutls build smobs))
+
+\f
+;;;
+;;; The program.
+;;;
+
+(define (main . args)
+ (let ((port (current-output-port)))
+ (for-each (lambda (type)
+ (output-smob-type-definition type port)
+ (output-smob-type-predicate type port))
+ (if (null? args)
+ %gnutls-smobs
+ %gnutls-extra-smobs))))
+
+(apply main (cdr (command-line)))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 364811a0-6d0a-431a-ae50-d2f7dc529903
--- /dev/null
+/* GNUTLS --- Guile bindings for GnuTLS.
+ Copyright (C) 2007 Free Software Foundation
+
+ GNUTLS 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.
+
+ GNUTLS 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 GNUTLS; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
+
+/* Written by Ludovic Courtès <ludo@chbouib.org>. */
+
+#include "utils.h"
+
+#include <gnutls/gnutls.h>
+#include <libguile.h>
+
+#include <alloca.h>
+
+#include "enums.h"
+#include "errors.h"
+
+SCM
+scm_from_gnutls_key_usage_flags (unsigned int c_usage)
+{
+ SCM usage = SCM_EOL;
+
+#define MATCH_USAGE(_value) \
+ if (c_usage & (_value)) \
+ { \
+ usage = scm_cons (scm_from_gnutls_key_usage (_value), \
+ usage); \
+ c_usage &= ~(_value); \
+ }
+
+ /* when the key is to be used for signing: */
+ MATCH_USAGE (GNUTLS_KEY_DIGITAL_SIGNATURE);
+ MATCH_USAGE (GNUTLS_KEY_NON_REPUDIATION);
+ /* when the key is to be used for encryption: */
+ MATCH_USAGE (GNUTLS_KEY_KEY_ENCIPHERMENT);
+ MATCH_USAGE (GNUTLS_KEY_DATA_ENCIPHERMENT);
+ MATCH_USAGE (GNUTLS_KEY_KEY_AGREEMENT);
+ MATCH_USAGE (GNUTLS_KEY_KEY_CERT_SIGN);
+ MATCH_USAGE (GNUTLS_KEY_CRL_SIGN);
+ MATCH_USAGE (GNUTLS_KEY_ENCIPHER_ONLY);
+ MATCH_USAGE (GNUTLS_KEY_DECIPHER_ONLY);
+
+ if (EXPECT_FALSE (c_usage != 0))
+ /* XXX: We failed to interpret one of the usage flags. */
+ scm_gnutls_error (GNUTLS_E_UNIMPLEMENTED_FEATURE, __FUNCTION__);
+
+#undef MATCH_USAGE
+
+ return usage;
+}
+
+/* arch-tag: a55fe230-ead7-495d-ab11-dfe18452ca2a
+ */
--- /dev/null
+/* GNUTLS --- Guile bindings for GnuTLS.
+ Copyright (C) 2007 Free Software Foundation
+
+ GNUTLS 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.
+
+ GNUTLS 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 GNUTLS; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */
+
+#ifndef GUILE_GNUTLS_UTILS_H
+#define GUILE_GNUTLS_UTILS_H
+
+/* Common utilities. */
+
+#include "config.h"
+#include <libguile.h>
+
+\f
+/* Compiler twiddling. */
+
+#ifdef __GNUC__
+# define EXPECT __builtin_expect
+# define NO_RETURN __attribute__ ((__noreturn__))
+#else
+# define EXPECT(_expr, _value) (_expr)
+# define NO_RETURN
+#endif
+
+#define EXPECT_TRUE(_expr) EXPECT ((_expr), 1)
+#define EXPECT_FALSE(_expr) EXPECT ((_expr), 0)
+
+\f
+/* Arrays as byte vectors. */
+
+extern const char scm_gnutls_array_error_message[];
+
+/* Initialize C_HANDLE and C_LEN and return the contiguous C array
+ corresponding to ARRAY. */
+static inline const char *
+scm_gnutls_get_array (SCM array, scm_t_array_handle *c_handle, size_t *c_len,
+ const char *func_name)
+{
+ const char *c_array = NULL;
+ const scm_t_array_dim *c_dims;
+
+ scm_array_get_handle (array, c_handle);
+ c_dims = scm_array_handle_dims (c_handle);
+ if ((scm_array_handle_rank (c_handle) != 1) || (c_dims->inc != 1))
+ {
+ scm_array_handle_release (c_handle);
+ scm_misc_error (func_name, scm_gnutls_array_error_message,
+ scm_list_1 (array));
+ }
+ else
+ {
+ size_t c_elem_size;
+
+ c_elem_size = scm_array_handle_uniform_element_size (c_handle);
+ *c_len = c_elem_size * (c_dims->ubnd - c_dims->lbnd + 1);
+
+ c_array = (char *) scm_array_handle_uniform_elements (c_handle);
+ }
+
+ return (c_array);
+}
+
+/* Initialize C_HANDLE and C_LEN and return the contiguous C array
+ corresponding to ARRAY. The returned array can be written to. */
+static inline char *
+scm_gnutls_get_writable_array (SCM array, scm_t_array_handle *c_handle,
+ size_t *c_len,
+ const char *func_name)
+{
+ char *c_array = NULL;
+ const scm_t_array_dim *c_dims;
+
+ scm_array_get_handle (array, c_handle);
+ c_dims = scm_array_handle_dims (c_handle);
+ if ((scm_array_handle_rank (c_handle) != 1) || (c_dims->inc != 1))
+ {
+ scm_array_handle_release (c_handle);
+ scm_misc_error (func_name, scm_gnutls_array_error_message,
+ scm_list_1 (array));
+ }
+ else
+ {
+ size_t c_elem_size;
+
+ c_elem_size = scm_array_handle_uniform_element_size (c_handle);
+ *c_len = c_elem_size * (c_dims->ubnd - c_dims->lbnd + 1);
+
+ c_array = (char *) scm_array_handle_uniform_writable_elements (c_handle);
+ }
+
+ return (c_array);
+}
+
+#define scm_gnutls_release_array scm_array_handle_release
+
+
+\f
+/* Type conversion. */
+
+/* Return a list corresponding to the key usage values ORed in C_USAGE. */
+SCM_API SCM scm_from_gnutls_key_usage_flags (unsigned int c_usage);
+
+#endif
+
+/* arch-tag: a33400bc-b5e3-429e-80e0-6ff14cab79e7
+ */
--- /dev/null
+# GNUTLS -- Guile bindings for GnuTLS.
+# Copyright (C) 2007 Free Software Foundation
+#
+# GNUTLS 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.
+#
+# GNUTLS 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 GNUTLS; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+TESTS = anonymous-auth.scm session-record-port.scm \
+ pkcs-import-export.scm \
+ openpgp-keys.scm openpgp-keyring.scm openpgp-auth.scm \
+ srp-base64.scm errors.scm \
+ x509-certificates.scm x509-auth.scm
+
+TESTS_ENVIRONMENT = $(top_builddir)/guile/pre-inst-guile -L $(srcdir)
+
+
+EXTRA_DIST = $(TESTS) openpgp-pub.asc openpgp-sec.asc \
+ openpgp-keyring.gpg openpgp-keyring.asc \
+ rsa-parameters.pem \
+ x509-certificate.pem x509-key.pem
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Test session establishment using anonymous authentication. Exercise the
+;;; record layer low-level API.
+;;;
+
+(use-modules (gnutls)
+ (srfi srfi-4))
+
+
+;; TLS session settings.
+(define %protos (list protocol/tls-1.0))
+(define %certs '())
+(define %ciphers (list cipher/null cipher/arcfour cipher/aes-128-cbc
+ cipher/aes-256-cbc))
+(define %kx (list kx/anon-dh))
+(define %macs (list mac/sha1 mac/rmd160 mac/md5))
+
+;; Message sent by the client.
+(define %message (apply u8vector (iota 256)))
+
+;; Debugging.
+;; (set-log-level! 100)
+;; (set-log-procedure! (lambda (level str)
+;; (format #t "[~a|~a] ~a" (getpid) level str)))
+
+(dynamic-wind
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
+ (pid (primitive-fork)))
+ (if (= 0 pid)
+
+ (let ((client (make-session connection-end/client)))
+ ;; client-side (child process)
+ (set-session-default-priority! client)
+ (set-session-certificate-type-priority! client %certs)
+ (set-session-kx-priority! client %kx)
+ (set-session-protocol-priority! client %protos)
+ (set-session-cipher-priority! client %ciphers)
+ (set-session-mac-priority! client %macs)
+
+ (set-session-transport-fd! client (fileno (car socket-pair)))
+ (set-session-credentials! client (make-anonymous-client-credentials))
+ (set-session-dh-prime-bits! client 1024)
+
+ (handshake client)
+ (record-send client %message)
+ (bye client close-request/rdwr)
+
+ (exit))
+
+ (let ((server (make-session connection-end/server)))
+ ;; server-side
+ (set-session-default-priority! server)
+ (set-session-certificate-type-priority! server %certs)
+ (set-session-kx-priority! server %kx)
+ (set-session-protocol-priority! server %protos)
+ (set-session-cipher-priority! server %ciphers)
+ (set-session-mac-priority! server %macs)
+
+ (set-session-transport-fd! server (fileno (cdr socket-pair)))
+ (let ((cred (make-anonymous-server-credentials))
+ (dh-params (make-dh-parameters 1024)))
+ ;; Note: DH parameter generation can take some time.
+ (set-anonymous-server-dh-parameters! cred dh-params)
+ (set-session-credentials! server cred))
+ (set-session-dh-prime-bits! server 1024)
+
+ (handshake server)
+ (let* ((buf (make-u8vector (u8vector-length %message)))
+ (amount (record-receive! server buf)))
+ (bye server close-request/rdwr)
+ (exit (= amount (u8vector-length %message))
+ (equal? buf %message)))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Test the error/exception mechanism.
+;;;
+
+(use-modules (gnutls))
+
+(dynamic-wind
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (let ((s (make-session connection-end/server)))
+ (catch 'gnutls-error
+ (lambda ()
+ (handshake s))
+ (lambda (key err function . currently-unused)
+ (exit (and (eq? key 'gnutls-error)
+ err
+ (string? (error->string err))
+ (eq? function 'handshake)))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: 73ed6229-378d-4a12-a5c6-4c2586c6e3a2
--- /dev/null
+;;; GNUTLS-EXTRA --- Guile bindings for GnuTLS-EXTRA.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS-EXTRA is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNUTLS-EXTRA 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNUTLS-EXTRA; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Test session establishment using OpenPGP certificate authentication.
+;;;
+;;; XXX: `set-certificate-credentials-openpgp-keys!' is broken (i.e.,
+;;; segfaults) in GnuTLS 1.7.2 and earlier.
+;;;
+
+(use-modules (gnutls)
+ (gnutls extra)
+ (srfi srfi-4))
+
+
+;; TLS session settings.
+(define %protos (list protocol/tls-1.0))
+(define %certs (list certificate-type/openpgp))
+(define %ciphers (list cipher/null cipher/arcfour cipher/aes-128-cbc
+ cipher/aes-256-cbc))
+(define %kx (list kx/rsa kx/rsa-export kx/dhe-dss kx/dhe-dss))
+(define %macs (list mac/sha1 mac/rmd160 mac/md5))
+
+;; Message sent by the client.
+(define %message
+ (cons "hello, world!" (iota 4444)))
+
+(define (import-something import-proc file fmt)
+ (let* ((path (search-path %load-path file))
+ (size (stat:size (stat path)))
+ (raw (make-u8vector size)))
+ (uniform-vector-read! raw (open-input-file path))
+ (import-proc raw fmt)))
+
+(define (import-key import-proc file)
+ (import-something import-proc file openpgp-key-format/base64))
+
+(define (import-rsa-params file)
+ (import-something pkcs1-import-rsa-parameters file
+ x509-certificate-format/pem))
+
+;; Debugging.
+;; (set-log-level! 3)
+;; (set-log-procedure! (lambda (level str)
+;; (format #t "[~a|~a] ~a" (getpid) level str)))
+
+(dynamic-wind
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
+ (pub (import-key import-openpgp-public-key
+ "openpgp-pub.asc"))
+ (sec (import-key import-openpgp-private-key
+ "openpgp-sec.asc")))
+ (let ((pid (primitive-fork)))
+ (if (= 0 pid)
+
+ (let ((client (make-session connection-end/client))
+ (cred (make-certificate-credentials)))
+ ;; client-side (child process)
+ (set-session-default-priority! client)
+ (set-session-certificate-type-priority! client %certs)
+ (set-session-kx-priority! client %kx)
+ (set-session-protocol-priority! client %protos)
+ (set-session-cipher-priority! client %ciphers)
+ (set-session-mac-priority! client %macs)
+
+ (set-certificate-credentials-openpgp-keys! cred pub sec)
+ (set-session-credentials! client cred)
+ (set-session-dh-prime-bits! client 1024)
+
+ (set-session-transport-fd! client (fileno (car socket-pair)))
+
+ (handshake client)
+ (write %message (session-record-port client))
+ (bye client close-request/rdwr)
+
+ (exit))
+
+ (let ((server (make-session connection-end/server))
+ (rsa (import-rsa-params "rsa-parameters.pem"))
+ (dh (make-dh-parameters 1024)))
+ ;; server-side
+ (set-session-default-priority! server)
+ (set-session-certificate-type-priority! server %certs)
+ (set-session-kx-priority! server %kx)
+ (set-session-protocol-priority! server %protos)
+ (set-session-cipher-priority! server %ciphers)
+ (set-session-mac-priority! server %macs)
+ (set-server-session-certificate-request! server
+ certificate-request/require)
+
+ (set-session-transport-fd! server (fileno (cdr socket-pair)))
+ (let ((cred (make-certificate-credentials)))
+ (set-certificate-credentials-dh-parameters! cred dh)
+ (set-certificate-credentials-rsa-export-parameters! cred rsa)
+ (set-certificate-credentials-openpgp-keys! cred pub sec)
+ (set-session-credentials! server cred))
+ (set-session-dh-prime-bits! server 1024)
+
+ (handshake server)
+ (let ((msg (read (session-record-port server)))
+ (auth-type (session-authentication-type server)))
+ (bye server close-request/rdwr)
+ (exit (and (eq? auth-type credentials/certificate)
+ (equal? msg %message)))))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: 1a973ed5-f45d-45a4-8160-900b6a8c27ff
--- /dev/null
+-----BEGIN PGP PUBLIC KEY BLOCK-----
+Version: GnuPG v1.4.6 (GNU/Linux)
+
+mQGiBDxnlY0RBACAsWUhi/goBvpvTBgL8fFPwBAuD04VYFEtC7+4pBp6kFsHjUR7
+TTUkBsOk2PvMHrDdv0+C4x2CH8YGP1e+O0f2yLWk8Uu+kkF12yiqbbvDEiCdeJT6
+c3vIstY8vJ9Jso5g/LB8Xggq88R7jXFS3hH+WC5v/6P6SARfzXl457cVewCgvxSf
+Gsm9mFospJ0B3RGyg5MB0d8D/RQQryJCGdR2nLe4VfctPL2QBD/1XhtubqEbetaV
+PxssqrJdA+eplBRT7UHokSBahM8gmSmNuSrLDujPfEtaMg6YIkB+Kq0VeJLE0cXT
+ZIH29KJlI/qk1xG4K7D6B0cKaHC/L4BIoKcQLJzfTIPw3frS4jVeNaQZNHSVqZ8/
+VmOMA/9rkNtccQ4RVd9WTFoHKvT4vfiISEOIzKGmcBY9Hymq7MCci3mNe4CDImkv
+ZgnjDlJAM91CX1ODthPLBqvyhnMhhxDnaDl4Nh42uPMSr9JEW2IwoIbFne10ihGT
+O4lBS1C28UfSGEMm/8JBMtxAjbYy3BYzUtCMA+bGBG6Voe5i5LQlRHIuIFdobyAo
+Tm8gY29tbWVudHMpIDx3aG9Ad2hvaXMub3JnPohdBBMRAgAdBQI8Z5WNBQkDwmcA
+BQsHCgMEAxUDAgMWAgECF4AACgkQNRRc6qfZPD+WWACfeJnLyfbpTDB7mDh3aATb
++0PXz28AoKRdApBVM6Bty+vWyXH6HfF6ZTj+mQGiBDxKxWwRBADnLna2Lu+po71Z
+QJMpJBgFDALXAp1sogZu/DTIYDhifGQ+saZSp68dN89G/FBaweDGmbN4lbS8s+U1
+Qf/aR2bWFowriq/WqyJGbQbRgDTV2saY5pk7pbNQ/4IuHNhwKnURTotzprCcs7k8
+5E27UWybtflbtmYYhgKgoURyNsBljwCgj1teeNhfeSzCBy+UdGRXJvtNk3MD/jV4
+1onWYG6RGOn5pwQrljzyPz2PE3eic8Dwl02/RLPKvL4U3WRBJVWGPjmpxidmLXes
+NmYq5El5LDJi0/EumDKnVlMJ1nugrk3yX17aCTcFatW+ifQGnr1+x2zkMkQd9dUv
+/9BtOeX2HjaUe2mKd8tiq4HkpBIr+QUGcdmUbIZeBADQYUN6lk3eMYgYwrJN4Ajm
+AJa2DbimhLhag40Rn8kwMRiJrVejuSf0SPhOslPGI+2nO0L/eLzmOmpTHXWmTOhU
+BROAjp9bEM4HXTQXuAEWSRixMdNUTIdlqOy5lx9hoJ/HPVCYBhBrWXfSEcsOHQTQ
+7Za86Juuj3PYALBSE5y/jbRJT3BlbkNESyB0ZXN0IGtleSAoT25seSBpbnRlbmRl
+ZCBmb3IgdGVzdCBwdXJwb3NlcyEpIDxvcGVuY2RrQGZvby1iYXIub3JnPohiBBMR
+AgAaBQI8SsVsBQsHCgMEAxUDAgMWAgECHgECF4AAEgkQvVcs3MzAfDUHZUdQRwAB
+AYHBAJwOEo2O1ER8bcvOYVDZzYbiDYRZpQCfZoFmLIDGqs8dLSvCBPCC/oDT26S5
+AQ0EPErFbxAEAOIBVlJgadBn0k9NcebThljgi+O/JGwa3OCNtpzY1FnB7TNXOEEH
+mHVa/befF5fPAi5wx5YPEspoltJ8/SShHNMW3eH7zB6mFcXDH+xlbkZweMh1/FCb
+HsuZyLVsLYdcUOIBi1sPo3hgbrZCWiUzgw9V/SHWSQFWFdSaHQnpUQ9fAAMFBADQ
+va3kBDJ1hnXIfQcww2CYFGe64b62zBBaPB82a/2+oS43hFZRMji4rUFOUqKpZh0d
+8dtrtfM/aQYWYQdVbIEyJDMLMJMtt8jMgiVnLXriSvJGl1DlObZh6mR10uA82NOD
+jcSorEr9ITU2/j6W7J0K6mUWS1duAbN6jcqJ8rJX0IhOBBgRAgAGBQI8SsVvABIJ
+EL1XLNzMwHw1B2VHUEcAAQF1ZgCfYB4fmeCwfHfmfz7soeGflGPTc2cAn2rGnrQR
+mm/79Enn0VTYLgXUCGHb
+=7B/E
+-----END PGP PUBLIC KEY BLOCK-----
--- /dev/null
+;;; GNUTLS-EXTRA --- Guile bindings for GnuTLS-EXTRA.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS-EXTRA is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNUTLS-EXTRA 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNUTLS-EXTRA; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Exercise the OpenPGP keyring API part of GnuTLS-extra.
+;;;
+;;; XXX: Keyring import is broken in GnuTLS versions up to and including 1.7.8.
+;;;
+
+(use-modules (gnutls extra) (gnutls)
+ (srfi srfi-1)
+ (srfi srfi-4))
+
+(define %raw-keyring-file
+ (search-path %load-path "openpgp-keyring.gpg"))
+
+(define %ascii-keyring-file
+ (search-path %load-path "openpgp-keyring.asc"))
+
+(define %ids-in-keyring
+ ;; The IDs of keys that are in the keyring.
+ ;; Change me if you change the keyring file.
+ (list '#u8(#x35 #x14 #x5c #xea
+ #xa7 #xd9 #x3c #x3f)
+ '#u8(#xbd #x57 #x2c #xdc
+ #xcc #xc0 #x7c #x35)))
+
+(define (file-size file)
+ (stat:size (stat file)))
+
+(define (valid-keyring? file format)
+ ;; Return true if FILE contains a valid keyring encoded in FORMAT.
+ (let ((raw-keyring (make-u8vector (file-size file))))
+
+ (uniform-vector-read! raw-keyring (open-input-file file))
+
+ (let ((keyring (import-openpgp-keyring raw-keyring format))
+ (null-id (make-u8vector 8 0)))
+
+ (and (openpgp-keyring? keyring)
+ (not (openpgp-keyring-contains-key-id? keyring null-id))
+ (every (lambda (id)
+ (openpgp-keyring-contains-key-id? keyring id))
+ %ids-in-keyring)))))
+
+(dynamic-wind
+
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (exit
+ (every valid-keyring?
+ (list %raw-keyring-file %ascii-keyring-file)
+ (list openpgp-key-format/raw openpgp-key-format/base64))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: 516bf608-5c8b-4787-abe9-5f7b6e6d660b
--- /dev/null
+;;; GNUTLS-EXTRA --- Guile bindings for GnuTLS-EXTRA.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS-EXTRA is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNUTLS-EXTRA 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNUTLS-EXTRA; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Exercise the OpenPGP key API part of GnuTLS-extra.
+;;;
+
+(use-modules (gnutls)
+ (gnutls extra)
+ (srfi srfi-1)
+ (srfi srfi-4)
+ (srfi srfi-11))
+
+(define %public-key-file
+ (search-path %load-path "openpgp-pub.asc"))
+
+(define %private-key-file
+ (search-path %load-path "openpgp-sec.asc"))
+
+(define %key-id
+ ;; Change me if you change the key files.
+ '#u8(#xbd #x57 #x2c #xdc #xcc #xc0 #x7c #x35))
+
+(define (file-size file)
+ (stat:size (stat file)))
+
+
+(dynamic-wind
+
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (let ((raw-pubkey (make-u8vector (file-size %public-key-file)))
+ (raw-privkey (make-u8vector (file-size %private-key-file))))
+
+ (uniform-vector-read! raw-pubkey (open-input-file %public-key-file))
+ (uniform-vector-read! raw-privkey (open-input-file %private-key-file))
+
+ (let ((pub (import-openpgp-public-key raw-pubkey
+ openpgp-key-format/base64))
+ (sec (import-openpgp-private-key raw-privkey
+ openpgp-key-format/base64)))
+
+ (exit (and (openpgp-public-key? pub)
+ (openpgp-private-key? sec)
+ (equal? (openpgp-public-key-id pub) %key-id)
+ (u8vector? (openpgp-public-key-fingerprint pub))
+ (every string? (openpgp-public-key-names pub))
+ (member (openpgp-public-key-version pub) '(3 4))
+ (list? (openpgp-public-key-usage pub))
+ (let-values (((pk bits)
+ (openpgp-public-key-algorithm pub)))
+ (and (string? (pk-algorithm->string pk))
+ (number? bits))))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: 2ee2a377-7f4d-4031-92a8-275090e4f83d
--- /dev/null
+-----BEGIN PGP PUBLIC KEY BLOCK-----
+
+mQGiBDxKxWwRBADnLna2Lu+po71ZQJMpJBgFDALXAp1sogZu/DTIYDhifGQ+saZS
+p68dN89G/FBaweDGmbN4lbS8s+U1Qf/aR2bWFowriq/WqyJGbQbRgDTV2saY5pk7
+pbNQ/4IuHNhwKnURTotzprCcs7k85E27UWybtflbtmYYhgKgoURyNsBljwCgj1te
+eNhfeSzCBy+UdGRXJvtNk3MD/jV41onWYG6RGOn5pwQrljzyPz2PE3eic8Dwl02/
+RLPKvL4U3WRBJVWGPjmpxidmLXesNmYq5El5LDJi0/EumDKnVlMJ1nugrk3yX17a
+CTcFatW+ifQGnr1+x2zkMkQd9dUv/9BtOeX2HjaUe2mKd8tiq4HkpBIr+QUGcdmU
+bIZeBADQYUN6lk3eMYgYwrJN4AjmAJa2DbimhLhag40Rn8kwMRiJrVejuSf0SPhO
+slPGI+2nO0L/eLzmOmpTHXWmTOhUBROAjp9bEM4HXTQXuAEWSRixMdNUTIdlqOy5
+lx9hoJ/HPVCYBhBrWXfSEcsOHQTQ7Za86Juuj3PYALBSE5y/jbRJT3BlbkNESyB0
+ZXN0IGtleSAoT25seSBpbnRlbmRlZCBmb3IgdGVzdCBwdXJwb3NlcyEpIDxvcGVu
+Y2RrQGZvby1iYXIub3JnPohaBBMRAgAaBQI8SsVsBQsHCgMEAxUDAgMWAgECHgEC
+F4AACgkQvVcs3MzAfDWBwQCcDhKNjtREfG3LzmFQ2c2G4g2EWaUAn2aBZiyAxqrP
+HS0rwgTwgv6A09ukuQENBDxKxW8QBADiAVZSYGnQZ9JPTXHm04ZY4IvjvyRsGtzg
+jbac2NRZwe0zVzhBB5h1Wv23nxeXzwIucMeWDxLKaJbSfP0koRzTFt3h+8wephXF
+wx/sZW5GcHjIdfxQmx7Lmci1bC2HXFDiAYtbD6N4YG62QlolM4MPVf0h1kkBVhXU
+mh0J6VEPXwADBQQA0L2t5AQydYZ1yH0HMMNgmBRnuuG+tswQWjwfNmv9vqEuN4RW
+UTI4uK1BTlKiqWYdHfHba7XzP2kGFmEHVWyBMiQzCzCTLbfIzIIlZy164kryRpdQ
+5Tm2YepkddLgPNjTg43EqKxK/SE1Nv4+luydCuplFktXbgGzeo3KifKyV9CIRgQY
+EQIABgUCPErFbwAKCRC9VyzczMB8NXVmAJ9gHh+Z4LB8d+Z/Puyh4Z+UY9NzZwCf
+asaetBGab/v0SefRVNguBdQIYds=
+=GwWK
+-----END PGP PUBLIC KEY BLOCK-----
--- /dev/null
+-----BEGIN PGP PRIVATE KEY BLOCK-----
+
+lQG7BDxKxWwRBADnLna2Lu+po71ZQJMpJBgFDALXAp1sogZu/DTIYDhifGQ+saZS
+p68dN89G/FBaweDGmbN4lbS8s+U1Qf/aR2bWFowriq/WqyJGbQbRgDTV2saY5pk7
+pbNQ/4IuHNhwKnURTotzprCcs7k85E27UWybtflbtmYYhgKgoURyNsBljwCgj1te
+eNhfeSzCBy+UdGRXJvtNk3MD/jV41onWYG6RGOn5pwQrljzyPz2PE3eic8Dwl02/
+RLPKvL4U3WRBJVWGPjmpxidmLXesNmYq5El5LDJi0/EumDKnVlMJ1nugrk3yX17a
+CTcFatW+ifQGnr1+x2zkMkQd9dUv/9BtOeX2HjaUe2mKd8tiq4HkpBIr+QUGcdmU
+bIZeBADQYUN6lk3eMYgYwrJN4AjmAJa2DbimhLhag40Rn8kwMRiJrVejuSf0SPhO
+slPGI+2nO0L/eLzmOmpTHXWmTOhUBROAjp9bEM4HXTQXuAEWSRixMdNUTIdlqOy5
+lx9hoJ/HPVCYBhBrWXfSEcsOHQTQ7Za86Juuj3PYALBSE5y/jQAAn2P+O9oRyd/b
+1jXd4F2H8SSzMMu3DM/9JiM6RFNBX2ZhY3RvcjoAAK9+8VCrUSp2tkcQT5PxLJzr
+ENoOP4NB/SYjOkRTQV9mYWN0b3I6AACvTy8J9Y0wrRLLV4I96AjHaNfLwQp9E/0m
+IzpEU0FfZmFjdG9yOgAAr2T4CrVVKLaOwyIga909v8jvsToXmxu0SU9wZW5DREsg
+dGVzdCBrZXkgKE9ubHkgaW50ZW5kZWQgZm9yIHRlc3QgcHVycG9zZXMhKSA8b3Bl
+bmNka0Bmb28tYmFyLm9yZz6IWgQTEQIAGgUCPErFbAULBwoDBAMVAwIDFgIBAh4B
+AheAAAoJEL1XLNzMwHw1gcEAmQGbWA2HMKJfa1qvFUwrpVK9zdHtAJ9HHAujC4X+
+0AnRZNUKFdC94Ct+r50BMgQ8SsVvEAQA4gFWUmBp0GfST01x5tOGWOCL478kbBrc
+4I22nNjUWcHtM1c4QQeYdVr9t58Xl88CLnDHlg8SymiW0nz9JKEc0xbd4fvMHqYV
+xcMf7GVuRnB4yHX8UJsey5nItWwth1xQ4gGLWw+jeGButkJaJTODD1X9IdZJAVYV
+1JodCelRD18AAwUEANC9reQEMnWGdch9BzDDYJgUZ7rhvrbMEFo8HzZr/b6hLjeE
+VlEyOLitQU5SoqlmHR3x22u18z9pBhZhB1VsgTIkMwswky23yMyCJWcteuJK8kaX
+UOU5tmHqZHXS4DzY04ONxKisSv0hNTb+PpbsnQrqZRZLV24Bs3qNyonyslfQAAD6
+AqTLHwdVk3VLPMjSKNONdwwYPDTowJ5cHw5Uc2vRRG0OJf0mIzpFTEdfZmFjdG9y
+OgAAqwRFtBcGdsy2AtBSxX4HPMvtBiODIhf9JiM6RUxHX2ZhY3RvcjoAAKsFn0GK
+Y7/TzpNP3IdTXmkQfUXC+YpP/SYjOkVMR19mYWN0b3I6AACrBV0wh13upAu9+4N1
+rXOuK6EkJ4T1//0mIzpFTEdfZmFjdG9yOgAAqwbJVCRiM/nb341fujR8AELlrBOb
+Lqv9JiM6RUxHX2ZhY3RvcjoAAKsGhKSsyEs0Yrs4YvI0CBiIZn1b2G9LiEYEGBEC
+AAYFAjxKxW8ACgkQvVcs3MzAfDV1ZgCeLovqxqOYaIfjREbT8e9+2jy1D20An268
+JJzFTBkCFFN0YlBK57y6qjf0
+=0tJj
+-----END PGP PRIVATE KEY BLOCK-----
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Exercise the DH/RSA PKCS3/PKCS1 export/import functions.
+;;;
+
+(use-modules (gnutls)
+ (srfi srfi-4))
+
+(dynamic-wind
+
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (exit
+ (let* ((dh-params (make-dh-parameters 1024))
+ (export
+ (pkcs3-export-dh-parameters dh-params
+ x509-certificate-format/pem)))
+ (and (u8vector? export)
+ (let ((import
+ (pkcs3-import-dh-parameters export
+ x509-certificate-format/pem)))
+ (dh-parameters? import))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: adff0f07-479e-421e-b47f-8956e06b9902
--- /dev/null
+(use-modules (r6rs i/o ports)
+ (ice-9 format))
+
+(define line-len 12)
+
+(let ((input (open-input-file "openpgp-keyring.gpg")))
+ (let loop ((byte (get-u8 input))
+ (total 0))
+ (if (eof-object? byte)
+ #t
+ (begin
+ (format #t "0x~:@(~2,'0x, " byte)
+ (if (>= (+ 1 total) line-len) (newline))
+ (loop (get-u8 input)
+ (modulo (+ total 1) line-len))))))
+(newline)
\ No newline at end of file
--- /dev/null
+-----BEGIN RSA PRIVATE KEY-----
+MIICWwIBAAKBgQDMOUZ0VEyX41ZLmZ7O0FPDaUYoJRFSoQF82TVt7zTcyLGTIoER
+QRpqpzA6DUyHZyX4bEodiCc4ks0efZYv7sjfz9pH1nEQiNe30ScFml79Yz8TmGtC
+aSiDEigZOq8F0NAzBgN9pfS5sxZw5yMK69m9DOUU/uQRJPM0nIaa6IHQ9QIDAQAB
+AoGAChNITcxr4/FwDDZFvrPJ8iHTN39OqbouQdvQdj4/KCZRlm31GqYQ2NKrPy3x
+SNvWpHkpNehF8RVS/85X1sEL0WJQ4h9/krWYsmO6h8ve/kMT6A2K2vVkv+Li/QBi
+6RyjP+FUcN5INe2cmRx7U04HaBoLyXg0wSOfRxpIez6nobkCQQDafbFQhGxqf0cS
+sMMu1jOX2HGGWwoPXWk8CANVmZWAZz3B507hc0di4ITgwTpw/JRr0RxzkEZQChLy
+RQDbW/5NAkEA70iPmsCVD7mSf8yo4h52YClmHhsHGkHD+kealg1Nq5LmnKoNftfa
+Ftg3wG8X7d86DU1pq1tJbRiUmxtgcGgBSQJABXNrUAnttn50ZHf6dpmrcddZhbOR
+va5j6LZ+ds09GJX6yXKe2isJFeNqDT1k2trCTSpLXmq0Bl0p+ddU3SQfZQJAXIXl
+KUSAHtV1pT8AqnZ29VXsq4Vt6KQ3YEZhqtW4C7jAvSEwGLTkGmM+o4URbqQbMVuW
+mXCx4qJXi+Y5Ex3UKQJAcuKAICXkM0Zi2aKE5Rv64w30VRbT2dNFGw2hWoHcQU9X
+S6Bf9LJmL8rJ8GOqwjEO8TbnAn+yNevd9zuFsGbw9A==
+-----END RSA PRIVATE KEY-----
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Test session establishment using anonymous authentication. Exercise the
+;;; `session-record-port' API.
+;;;
+
+(use-modules (gnutls)
+ (srfi srfi-4))
+
+
+;; TLS session settings.
+(define %protos (list protocol/tls-1.0))
+(define %certs '())
+(define %ciphers (list cipher/null cipher/arcfour cipher/aes-128-cbc
+ cipher/aes-256-cbc))
+(define %kx (list kx/anon-dh))
+(define %macs (list mac/sha1 mac/rmd160 mac/md5))
+
+;; Message sent by the client.
+(define %message (apply u8vector (iota 256)))
+
+;; Debugging.
+;; (set-log-level! 100)
+;; (set-log-procedure! (lambda (level str)
+;; (format #t "[~a|~a] ~a" (getpid) level str)))
+
+(dynamic-wind
+ (lambda ()
+ #t)
+
+ (lambda ()
+ ;; Stress the GC. In 0.0, this triggered an abort due to
+ ;; "scm_unprotect_object called during GC".
+ (let ((sessions (map (lambda (i)
+ (make-session connection-end/server))
+ (iota 123))))
+ (for-each session-record-port sessions)
+ (gc)(gc)(gc))
+
+ ;; Stress the GC. The session associated to each port in PORTS should
+ ;; remain reachable.
+ (let ((ports (map session-record-port
+ (map (lambda (i)
+ (make-session connection-end/server))
+ (iota 123)))))
+ (gc)(gc)(gc)
+ (for-each (lambda (p)
+ (catch 'gnutls-error
+ (lambda ()
+ (read p))
+ (lambda (key . args)
+ #t)))
+ ports))
+
+ ;; Try using the record port for I/O.
+ (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
+ (pid (primitive-fork)))
+ (if (= 0 pid)
+
+ (let ((client (make-session connection-end/client)))
+ ;; client-side (child process)
+ (set-session-default-priority! client)
+ (set-session-certificate-type-priority! client %certs)
+ (set-session-kx-priority! client %kx)
+ (set-session-protocol-priority! client %protos)
+ (set-session-cipher-priority! client %ciphers)
+ (set-session-mac-priority! client %macs)
+
+ (set-session-transport-port! client (car socket-pair))
+ (set-session-credentials! client (make-anonymous-client-credentials))
+ (set-session-dh-prime-bits! client 1024)
+
+ (handshake client)
+ (uniform-vector-write %message (session-record-port client))
+ (bye client close-request/rdwr)
+
+ (exit))
+
+ (let ((server (make-session connection-end/server)))
+ ;; server-side
+ (set-session-default-priority! server)
+ (set-session-certificate-type-priority! server %certs)
+ (set-session-kx-priority! server %kx)
+ (set-session-protocol-priority! server %protos)
+ (set-session-cipher-priority! server %ciphers)
+ (set-session-mac-priority! server %macs)
+
+ (set-session-transport-port! server (cdr socket-pair))
+ (let ((cred (make-anonymous-server-credentials))
+ (dh-params (make-dh-parameters 1024)))
+ ;; Note: DH parameter generation can take some time.
+ (set-anonymous-server-dh-parameters! cred dh-params)
+ (set-session-credentials! server cred))
+ (set-session-dh-prime-bits! server 1024)
+
+ (handshake server)
+ (let* ((buf (make-u8vector (u8vector-length %message)))
+ (amount
+ (uniform-vector-read! buf (session-record-port server))))
+ (bye server close-request/rdwr)
+
+ ;; Make sure we got everything right.
+ (exit (eq? (session-record-port server)
+ (session-record-port server))
+ (= amount (u8vector-length %message))
+ (equal? buf %message)
+ (eof-object?
+ (read-char (session-record-port server)))))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Test SRP base64 encoding and decoding.
+;;;
+
+(use-modules (gnutls))
+
+(define %message
+ "GNUTLS 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.")
+
+(exit (let ((encoded (srp-base64-encode %message)))
+ (and (string? encoded)
+ (string=? (srp-base64-decode encoded)
+ %message))))
+
+
+;;; arch-tag: ea1534a5-d513-4208-9a75-54bd4710f915
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Test session establishment using X.509 certificate authentication.
+;;; Based on `openpgp-auth.scm'.
+;;;
+
+(use-modules (gnutls)
+ (srfi srfi-4))
+
+
+;; TLS session settings.
+(define %protos (list protocol/tls-1.0))
+(define %certs (list certificate-type/x509))
+(define %ciphers (list cipher/null cipher/arcfour cipher/aes-128-cbc
+ cipher/aes-256-cbc))
+(define %kx (list kx/rsa kx/rsa-export kx/dhe-dss kx/dhe-dss))
+(define %macs (list mac/sha1 mac/rmd160 mac/md5))
+
+;; Message sent by the client.
+(define %message
+ (cons "hello, world!" (iota 4444)))
+
+(define (import-something import-proc file fmt)
+ (let* ((path (search-path %load-path file))
+ (size (stat:size (stat path)))
+ (raw (make-u8vector size)))
+ (uniform-vector-read! raw (open-input-file path))
+ (import-proc raw fmt)))
+
+(define (import-key import-proc file)
+ (import-something import-proc file x509-certificate-format/pem))
+
+(define (import-rsa-params file)
+ (import-something pkcs1-import-rsa-parameters file
+ x509-certificate-format/pem))
+
+;; Debugging.
+;; (set-log-level! 3)
+;; (set-log-procedure! (lambda (level str)
+;; (format #t "[~a|~a] ~a" (getpid) level str)))
+
+(dynamic-wind
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
+ (pub (import-key import-x509-certificate
+ "x509-certificate.pem"))
+ (sec (import-key import-x509-private-key
+ "x509-key.pem")))
+ (let ((pid (primitive-fork)))
+ (if (= 0 pid)
+
+ (let ((client (make-session connection-end/client))
+ (cred (make-certificate-credentials)))
+ ;; client-side (child process)
+ (set-session-default-priority! client)
+ (set-session-certificate-type-priority! client %certs)
+ (set-session-kx-priority! client %kx)
+ (set-session-protocol-priority! client %protos)
+ (set-session-cipher-priority! client %ciphers)
+ (set-session-mac-priority! client %macs)
+
+ (set-certificate-credentials-x509-keys! cred (list pub) sec)
+ (set-session-credentials! client cred)
+ (set-session-dh-prime-bits! client 1024)
+
+ (set-session-transport-fd! client (fileno (car socket-pair)))
+
+ (handshake client)
+ (write %message (session-record-port client))
+ (bye client close-request/rdwr)
+
+ (exit))
+
+ (let ((server (make-session connection-end/server))
+ (rsa (import-rsa-params "rsa-parameters.pem"))
+ (dh (make-dh-parameters 1024)))
+ ;; server-side
+ (set-session-default-priority! server)
+ (set-session-certificate-type-priority! server %certs)
+ (set-session-kx-priority! server %kx)
+ (set-session-protocol-priority! server %protos)
+ (set-session-cipher-priority! server %ciphers)
+ (set-session-mac-priority! server %macs)
+ (set-server-session-certificate-request! server
+ certificate-request/require)
+
+ (set-session-transport-fd! server (fileno (cdr socket-pair)))
+ (let ((cred (make-certificate-credentials))
+ (trust-file (search-path %load-path
+ "x509-certificate.pem"))
+ (trust-fmt x509-certificate-format/pem))
+ (set-certificate-credentials-dh-parameters! cred dh)
+ (set-certificate-credentials-rsa-export-parameters! cred rsa)
+ (set-certificate-credentials-x509-keys! cred (list pub) sec)
+ (set-certificate-credentials-x509-trust-file! cred
+ trust-file
+ trust-fmt)
+ (set-session-credentials! server cred))
+ (set-session-dh-prime-bits! server 1024)
+
+ (handshake server)
+ (let ((msg (read (session-record-port server)))
+ (auth-type (session-authentication-type server)))
+ (bye server close-request/rdwr)
+ (exit (and (eq? auth-type credentials/certificate)
+ (equal? msg %message)))))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: 1f88f835-a5c8-4fd6-94b6-5a13571ba03d
+
--- /dev/null
+-----BEGIN CERTIFICATE-----
+MIICmDCCAgOgAwIBAgIBAjALBgkqhkiG9w0BAQUwUjELMAkGA1UEBhMCR1IxDDAK
+BgNVBAoTA0ZTRjEPMA0GA1UECxMGR05VVExTMSQwIgYDVQQDExtHTlVUTFMgSU5U
+RVJNRURJQVRFIFRFU1QgQ0EwHhcNMDQwNjI4MjI0NzAwWhcNMDcwMzIyMjI0NzAw
+WjBJMQswCQYDVQQGEwJHUjEMMAoGA1UEChMDRlNGMQ8wDQYDVQQLEwZHTlVUTFMx
+GzAZBgNVBAMTEkdOVVRMUyBURVNUIFNFUlZFUjCBnDALBgkqhkiG9w0BAQEDgYwA
+MIGIAoGA1chUqA9ib8S5GKd29B9d1rwgUncFhJPu0+RK8kOyOsV3qBdtdWeBSiGW
+So1RHkcmV9BlbUtmuHioAUkZPSo8gtoEy3JpSemW221BsjwITjGeZxZsb+4C/U2X
+HUIlO+jqBK5VYbpNXkP/2ofMkWWAZyKnI+PMIfFvv/cASsI0k48CAwEAAaOBjTCB
+ijAMBgNVHRMBAf8EAjAAMBQGA1UdEQQNMAuCCWxvY2FsaG9zdDATBgNVHSUEDDAK
+BggrBgEFBQcDATAPBgNVHQ8BAf8EBQMDB6AAMB0GA1UdDgQWBBTIZD/hlqUB89OE
+AwonwqGflkHtijAfBgNVHSMEGDAWgBQ2tS+xHdrw3r4o20MwGkLdzh5UlDALBgkq
+hkiG9w0BAQUDgYEAWPpWlUlvzDZRbpneYw8d6Q8On/ZPmSYBCm38vTKPEoNA6lW1
+WIc3Vbw5zOeSfDLifIWV2W/MqyjDo9MeWvSKpcUfRfibpXBgbA4RAGW0j2K1JQmE
+gP3k1vMicYzn5EglhZjoa9I+36a90vJraqzHQ7DrKtW0FDfW2GREzSh9RV8=
+-----END CERTIFICATE-----
+
+-----BEGIN CERTIFICATE-----
+MIICajCCAdWgAwIBAgIBATALBgkqhkiG9w0BAQUwRTELMAkGA1UEBhMCR1IxDDAK
+BgNVBAoTA0ZTRjEPMA0GA1UECxMGR05VVExTMRcwFQYDVQQDEw5HTlVUTFMgVEVT
+VCBDQTAeFw0wNDA2MjgyMjQ2MDBaFw0wNzAzMjMyMjQ2MDBaMFIxCzAJBgNVBAYT
+AkdSMQwwCgYDVQQKEwNGU0YxDzANBgNVBAsTBkdOVVRMUzEkMCIGA1UEAxMbR05V
+VExTIElOVEVSTUVESUFURSBURVNUIENBMIGcMAsGCSqGSIb3DQEBAQOBjAAwgYgC
+gYC0JKSLzHuiWK66XYOJk6AxDBo94hdCFnfIor7xnZkqTgiUQZhk9HDVmmz1+tLd
+yJk6r9PK+WMDDBkSOvT+SmQNd9mL2JzI+bJWwoB77aJ7vUI3/9+ugtffiapnX6wx
+vLyAxeJRyN0Q3oBHc6N2dJo9z1NHoFe8xipXXHOdxU1DAwIDAQABo2QwYjAPBgNV
+HRMBAf8EBTADAQH/MA8GA1UdDwEB/wQFAwMHBAAwHQYDVR0OBBYEFDa1L7Ed2vDe
+vijbQzAaQt3OHlSUMB8GA1UdIwQYMBaAFHnrG2+jZuZ54dHitdvaJwZFKQpIMAsG
+CSqGSIb3DQEBBQOBgQCi/SI37DrGCeZhtGhU2AyZFaqskRoFt4zAb9UYaGZaYEh5
+0VUZsA/Ol8jiiQTtiCokZswhSsn+2McZmcspKigsY2aEBrry+TGFWMnYu5j5kcwP
+1nVuHxLRwLt2rIsjgkeSNdHr8XHKi9/Roz/Gj86OnBAHwPt8WHfHK+63cMX1WA==
+-----END CERTIFICATE-----
+
--- /dev/null
+;;; GNUTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007 Free Software Foundation
+;;;
+;;; GNUTLS 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.
+;;;
+;;; GNUTLS 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 GNUTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>.
+
+
+;;;
+;;; Exercise the X.509 certificate API.
+;;;
+
+(use-modules (gnutls)
+ (srfi srfi-4)
+ (srfi srfi-11))
+
+(define %certificate-file
+ (search-path %load-path "x509-certificate.pem"))
+
+(define %private-key-file
+ (search-path %load-path "x509-key.pem"))
+
+(define %first-oid
+ ;; The certificate's first OID.
+ "2.5.4.6")
+
+(define %signature-algorithm
+ ;; The certificate's signature algorithm.
+ sign-algorithm/rsa-sha1)
+
+
+(define (file-size file)
+ (stat:size (stat file)))
+
+
+(dynamic-wind
+
+ (lambda ()
+ #t)
+
+ (lambda ()
+ (let ((raw-certificate (make-u8vector (file-size %certificate-file)))
+ (raw-privkey (make-u8vector (file-size %private-key-file))))
+
+ (uniform-vector-read! raw-certificate
+ (open-input-file %certificate-file))
+ (uniform-vector-read! raw-privkey
+ (open-input-file %private-key-file))
+
+ (let ((cert (import-x509-certificate raw-certificate
+ x509-certificate-format/pem))
+ (sec (import-x509-private-key raw-privkey
+ x509-certificate-format/pem)))
+
+ (exit (and (x509-certificate? cert)
+ (x509-private-key? sec)
+ (string? (x509-certificate-dn cert))
+ (string? (x509-certificate-issuer-dn cert))
+ (string=? (x509-certificate-dn-oid cert 0) %first-oid)
+ (eq? (x509-certificate-signature-algorithm cert)
+ %signature-algorithm)
+ (x509-certificate-matches-hostname? cert "localhost")
+ (let-values (((type name)
+ (x509-certificate-subject-alternative-name
+ cert 0)))
+ (and (string? name)
+ (string?
+ (x509-subject-alternative-name->string type)))))))))
+
+ (lambda ()
+ ;; failure
+ (exit 1)))
+
+;;; arch-tag: eef09b52-30e8-472a-8b93-cb636434f6eb
--- /dev/null
+-----BEGIN RSA PRIVATE KEY-----
+MIICWwIBAAKBgQDVyFSoD2JvxLkYp3b0H13WvCBSdwWEk+7T5EryQ7I6xXeoF211
+Z4FKIZZKjVEeRyZX0GVtS2a4eKgBSRk9KjyC2gTLcmlJ6ZbbbUGyPAhOMZ5nFmxv
+7gL9TZcdQiU76OoErlVhuk1eQ//ah8yRZYBnIqcj48wh8W+/9wBKwjSTjwIDAQAB
+AoGAAn2Ueua++1Vb4K0mxh5NbhCAAeXwEwTULfTFaMAgJe4iADvRoyIDEBWHFjRC
+QyuKB1DetaDAwBprvqQW3q8MyGYD7P9h85Wfu/hpIYKTw9hNeph420aE8WXw2ygl
+TkJz3bzkMrXe/WjdhS1kTt8avCNQR/p0jM/UHvNze4oLc1ECQQDfammiczQFtj+F
+uf3CNcYwp5XNumF+pubdGb+UHUiHyCuVQxvm+LXgq8wXV/uXFLrp7FQFLCDQf0ji
+KDB2YQvRAkEA9PY/2AaGsU7j8ePwQbxCkwuj3hY6O6aNLIGxKxwZrzbob26c+tQk
+/++e0IXusIscBvcRV1Kg8Ff6fnw7/AdhXwJAG8qVbOuRmGk0BkwuFmPoeW3vNQgR
+X96O7po0qPBqVdRAU2rvzYtkCFxYqq0ilI0ekZtAfKxbeykaQaRkkKPaoQJAcifP
+yWJ/tu8z4DM7Ka+pFqTMwIllM1U3vFtv3LXezDE7AGDCyHKdB7MXcPXqj6nmCLMi
+swwiLLahAOBnUqk6xwJAJQ4pGcFFlCiIiVsq0wYSYmZUcRpSIInEQ0f8/xN6J22Z
+siP5vnJM3F7R6ciYTt2gzNci/W9cdZI2HxskkO5lbQ==
+-----END RSA PRIVATE KEY-----
projects / thirdparty / gnutls.git / commitdiff
