diff options
| author | Ludovic Courtès <ludo@chbouib.org> | 2007-05-30 00:39:23 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@chbouib.org> | 2007-05-30 00:39:23 +0200 |
| commit | d374e7df710477ae0212234d688064876cb7d05f (patch) | |
| tree | 9130cc704019c6b89da9eb2b5dd7da59d41b8b31 /guile | |
| parent | 331a51173f748bca0850a275dd9454486948a9da (diff) | |
| download | gnutls-d374e7df710477ae0212234d688064876cb7d05f.tar.gz | |
Started Guile integration.
Documentation is still missing. A bit rough on the edges, but `make'
and `make check' do work.
Diffstat (limited to 'guile')
43 files changed, 6886 insertions, 0 deletions
diff --git a/guile/Makefile.am b/guile/Makefile.am new file mode 100644 index 0000000000..3e3e9f3306 --- /dev/null +++ b/guile/Makefile.am @@ -0,0 +1,18 @@ +# 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 diff --git a/guile/modules/Makefile.am b/guile/modules/Makefile.am new file mode 100644 index 0000000000..85cf709790 --- /dev/null +++ b/guile/modules/Makefile.am @@ -0,0 +1,28 @@ +# 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) diff --git a/guile/modules/gnutls.scm b/guile/modules/gnutls.scm new file mode 100644 index 0000000000..f98c4cf48a --- /dev/null +++ b/guile/modules/gnutls.scm @@ -0,0 +1,384 @@ +;;; 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 diff --git a/guile/modules/gnutls/build/enums.scm b/guile/modules/gnutls/build/enums.scm new file mode 100644 index 0000000000..e09ef4f7c7 --- /dev/null +++ b/guile/modules/gnutls/build/enums.scm @@ -0,0 +1,596 @@ +;;; 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. +;;; + + +;;; +;;; 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")) + + +;;; +;;; 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 "}~%"))) + + +;;; +;;; 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 diff --git a/guile/modules/gnutls/build/priorities.scm b/guile/modules/gnutls/build/priorities.scm new file mode 100644 index 0000000000..419364acd2 --- /dev/null +++ b/guile/modules/gnutls/build/priorities.scm @@ -0,0 +1,102 @@ +;;; 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. +;;; + + + +;;; +;;; 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)) + + +;;; +;;; 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~%"))) + + +;;; +;;; 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 diff --git a/guile/modules/gnutls/build/smobs.scm b/guile/modules/gnutls/build/smobs.scm new file mode 100644 index 0000000000..a21cb583f0 --- /dev/null +++ b/guile/modules/gnutls/build/smobs.scm @@ -0,0 +1,238 @@ +;;; 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)) + + +;;; +;;; 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)))) + + +;;; +;;; 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~%")) + + +;;; +;;; 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 diff --git a/guile/modules/gnutls/build/utils.scm b/guile/modules/gnutls/build/utils.scm new file mode 100644 index 0000000000..dedd6ec3a5 --- /dev/null +++ b/guile/modules/gnutls/build/utils.scm @@ -0,0 +1,46 @@ +;;; 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. +;;; + + +;;; +;;; 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 diff --git a/guile/modules/gnutls/extra.scm b/guile/modules/gnutls/extra.scm new file mode 100644 index 0000000000..73f89b2215 --- /dev/null +++ b/guile/modules/gnutls/extra.scm @@ -0,0 +1,59 @@ +;;; 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 diff --git a/guile/modules/system/documentation/README b/guile/modules/system/documentation/README new file mode 100644 index 0000000000..de45e2e503 --- /dev/null +++ b/guile/modules/system/documentation/README @@ -0,0 +1,15 @@ +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>. diff --git a/guile/modules/system/documentation/c-snarf.scm b/guile/modules/system/documentation/c-snarf.scm new file mode 100644 index 0000000000..c0ca2e819b --- /dev/null +++ b/guile/modules/system/documentation/c-snarf.scm @@ -0,0 +1,189 @@ +;;; 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: + + + +;;; +;;; 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))) + + +;;; +;;; 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 diff --git a/guile/modules/system/documentation/output.scm b/guile/modules/system/documentation/output.scm new file mode 100644 index 0000000000..b760dc7bec --- /dev/null +++ b/guile/modules/system/documentation/output.scm @@ -0,0 +1,176 @@ +;;; 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: + + +;;; +;;; 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))) + + +;;; +;;; 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 " " ;; 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)))) + + +;;; +;;; 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 diff --git a/guile/pre-inst-guile.in b/guile/pre-inst-guile.in new file mode 100644 index 0000000000..62bac03e03 --- /dev/null +++ b/guile/pre-inst-guile.in @@ -0,0 +1,29 @@ +#!/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@ "$@" diff --git a/guile/src/Makefile.am b/guile/src/Makefile.am new file mode 100644 index 0000000000..79c6eed55f --- /dev/null +++ b/guile/src/Makefile.am @@ -0,0 +1,96 @@ +# 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) diff --git a/guile/src/core.c b/guile/src/core.c new file mode 100644 index 0000000000..d620a31f17 --- /dev/null +++ b/guile/src/core.c @@ -0,0 +1,2759 @@ +/* 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" + + + +/* 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)) + + + +/* 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'. */ + + +/* 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 + + +/* 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 + + +/* 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); +} + + +/* 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 + + +/* 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 + + +/* 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 + + +/* 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 + + +/* 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 + + +/* 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 + + +/* 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 + + +/* 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 + + +/* 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 + + +/* 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 + */ diff --git a/guile/src/errors.c b/guile/src/errors.c new file mode 100644 index 0000000000..fdc46c4a9b --- /dev/null +++ b/guile/src/errors.c @@ -0,0 +1,53 @@ +/* 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 (); +} + + +void +scm_init_gnutls_error (void) +{ +#include "errors.c.x" +} + +/* arch-tag: 48f07ecf-65c4-480c-b043-a51eab592d6b + */ diff --git a/guile/src/errors.h b/guile/src/errors.h new file mode 100644 index 0000000000..c360899f34 --- /dev/null +++ b/guile/src/errors.h @@ -0,0 +1,31 @@ +/* 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 + */ diff --git a/guile/src/extra.c b/guile/src/extra.c new file mode 100644 index 0000000000..440e6c3099 --- /dev/null +++ b/guile/src/extra.c @@ -0,0 +1,544 @@ +/* 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" + + + +/* SMOB and enums type definitions. */ + +#include "extra-smob-types.i.c" +#include "extra-enum-map.i.c" + + +/* 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 + + + +/* 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 + + +/* 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 + + +/* 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 + */ diff --git a/guile/src/make-enum-header.scm b/guile/src/make-enum-header.scm new file mode 100644 index 0000000000..d7e7aeede8 --- /dev/null +++ b/guile/src/make-enum-header.scm @@ -0,0 +1,66 @@ +;;; 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)) + + +;;; +;;; 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 diff --git a/guile/src/make-enum-map.scm b/guile/src/make-enum-map.scm new file mode 100644 index 0000000000..27c8d6f9ce --- /dev/null +++ b/guile/src/make-enum-map.scm @@ -0,0 +1,47 @@ +;;; 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)) + + +;;; +;;; 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 diff --git a/guile/src/make-session-priorities.scm b/guile/src/make-session-priorities.scm new file mode 100644 index 0000000000..059254b5f9 --- /dev/null +++ b/guile/src/make-session-priorities.scm @@ -0,0 +1,43 @@ +;;; 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)) + + +;;; +;;; 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 diff --git a/guile/src/make-smob-header.scm b/guile/src/make-smob-header.scm new file mode 100644 index 0000000000..64a2b67fac --- /dev/null +++ b/guile/src/make-smob-header.scm @@ -0,0 +1,56 @@ +;;; 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)) + + +;;; +;;; 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 diff --git a/guile/src/make-smob-types.scm b/guile/src/make-smob-types.scm new file mode 100644 index 0000000000..71a0c4347f --- /dev/null +++ b/guile/src/make-smob-types.scm @@ -0,0 +1,46 @@ +;;; 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)) + + +;;; +;;; 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 diff --git a/guile/src/utils.c b/guile/src/utils.c new file mode 100644 index 0000000000..b388e06ff4 --- /dev/null +++ b/guile/src/utils.c @@ -0,0 +1,65 @@ +/* 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 + */ diff --git a/guile/src/utils.h b/guile/src/utils.h new file mode 100644 index 0000000000..8a30ff5987 --- /dev/null +++ b/guile/src/utils.h @@ -0,0 +1,118 @@ +/* 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> + + +/* 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) + + +/* 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 + + + +/* 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 + */ diff --git a/guile/tests/Makefile.am b/guile/tests/Makefile.am new file mode 100644 index 0000000000..b0109217f4 --- /dev/null +++ b/guile/tests/Makefile.am @@ -0,0 +1,30 @@ +# 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 diff --git a/guile/tests/anonymous-auth.scm b/guile/tests/anonymous-auth.scm new file mode 100644 index 0000000000..eb4375fc3b --- /dev/null +++ b/guile/tests/anonymous-auth.scm @@ -0,0 +1,102 @@ +;;; 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 diff --git a/guile/tests/errors.scm b/guile/tests/errors.scm new file mode 100644 index 0000000000..d739cecb40 --- /dev/null +++ b/guile/tests/errors.scm @@ -0,0 +1,46 @@ +;;; 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 diff --git a/guile/tests/openpgp-auth.scm b/guile/tests/openpgp-auth.scm new file mode 100644 index 0000000000..bdc1d97d43 --- /dev/null +++ b/guile/tests/openpgp-auth.scm @@ -0,0 +1,132 @@ +;;; 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 diff --git a/guile/tests/openpgp-keyring.asc b/guile/tests/openpgp-keyring.asc new file mode 100644 index 0000000000..4495a5a8e3 --- /dev/null +++ b/guile/tests/openpgp-keyring.asc @@ -0,0 +1,37 @@ +-----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----- diff --git a/guile/tests/openpgp-keyring.gpg b/guile/tests/openpgp-keyring.gpg Binary files differnew file mode 100644 index 0000000000..f78440407b --- /dev/null +++ b/guile/tests/openpgp-keyring.gpg diff --git a/guile/tests/openpgp-keyring.scm b/guile/tests/openpgp-keyring.scm new file mode 100644 index 0000000000..6a25f866da --- /dev/null +++ b/guile/tests/openpgp-keyring.scm @@ -0,0 +1,79 @@ +;;; 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 diff --git a/guile/tests/openpgp-keys.scm b/guile/tests/openpgp-keys.scm new file mode 100644 index 0000000000..29cbe821ef --- /dev/null +++ b/guile/tests/openpgp-keys.scm @@ -0,0 +1,79 @@ +;;; 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 diff --git a/guile/tests/openpgp-pub.asc b/guile/tests/openpgp-pub.asc new file mode 100644 index 0000000000..6bdfabf9d2 --- /dev/null +++ b/guile/tests/openpgp-pub.asc @@ -0,0 +1,24 @@ +-----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----- diff --git a/guile/tests/openpgp-sec.asc b/guile/tests/openpgp-sec.asc new file mode 100644 index 0000000000..58bafeea47 --- /dev/null +++ b/guile/tests/openpgp-sec.asc @@ -0,0 +1,32 @@ +-----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----- diff --git a/guile/tests/pkcs-import-export.scm b/guile/tests/pkcs-import-export.scm new file mode 100644 index 0000000000..d202668c81 --- /dev/null +++ b/guile/tests/pkcs-import-export.scm @@ -0,0 +1,49 @@ +;;; 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 diff --git a/guile/tests/raw-to-c.scm b/guile/tests/raw-to-c.scm new file mode 100644 index 0000000000..8f506e7f7c --- /dev/null +++ b/guile/tests/raw-to-c.scm @@ -0,0 +1,16 @@ +(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 diff --git a/guile/tests/rsa-parameters.pem b/guile/tests/rsa-parameters.pem new file mode 100644 index 0000000000..b1cd7db3f5 --- /dev/null +++ b/guile/tests/rsa-parameters.pem @@ -0,0 +1,15 @@ +-----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----- diff --git a/guile/tests/session-record-port.scm b/guile/tests/session-record-port.scm new file mode 100644 index 0000000000..e0b313c9de --- /dev/null +++ b/guile/tests/session-record-port.scm @@ -0,0 +1,133 @@ +;;; 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 diff --git a/guile/tests/srp-base64.scm b/guile/tests/srp-base64.scm new file mode 100644 index 0000000000..bb994a508d --- /dev/null +++ b/guile/tests/srp-base64.scm @@ -0,0 +1,39 @@ +;;; 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 diff --git a/guile/tests/x509-auth.scm b/guile/tests/x509-auth.scm new file mode 100644 index 0000000000..5c82aaebf5 --- /dev/null +++ b/guile/tests/x509-auth.scm @@ -0,0 +1,135 @@ +;;; 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 + diff --git a/guile/tests/x509-certificate.pem b/guile/tests/x509-certificate.pem new file mode 100644 index 0000000000..8891072581 --- /dev/null +++ b/guile/tests/x509-certificate.pem @@ -0,0 +1,33 @@ +-----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----- + diff --git a/guile/tests/x509-certificates.scm b/guile/tests/x509-certificates.scm new file mode 100644 index 0000000000..3b5629c3a3 --- /dev/null +++ b/guile/tests/x509-certificates.scm @@ -0,0 +1,86 @@ +;;; 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 diff --git a/guile/tests/x509-key.pem b/guile/tests/x509-key.pem new file mode 100644 index 0000000000..1e80b2e55e --- /dev/null +++ b/guile/tests/x509-key.pem @@ -0,0 +1,15 @@ +-----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----- |