diff options
Diffstat (limited to 'guile/modules/gnutls/build')
| -rw-r--r-- | guile/modules/gnutls/build/enums.scm | 596 | ||||
| -rw-r--r-- | guile/modules/gnutls/build/priorities.scm | 102 | ||||
| -rw-r--r-- | guile/modules/gnutls/build/smobs.scm | 238 | ||||
| -rw-r--r-- | guile/modules/gnutls/build/utils.scm | 46 |
4 files changed, 982 insertions, 0 deletions
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 |