diff options
| author | Simon Josefsson <simon@josefsson.org> | 2022-10-12 15:02:35 +0200 |
|---|---|---|
| committer | Simon Josefsson <simon@josefsson.org> | 2022-10-26 13:03:35 +0200 |
| commit | 100cc2a706b8e097cbeb63d08c7ea59717c906ca (patch) | |
| tree | 914c59fcb47a35d67ee209b0b9d38e2f3cbaa3b6 | |
| parent | 8610f63f5a757b6f688bf44cb4c52609f48fdb5e (diff) | |
| download | gnutls-100cc2a706b8e097cbeb63d08c7ea59717c906ca.tar.gz | |
Drop guile bindings. See <https://gitlab.com/gnutls/guile/>.
Signed-off-by: Simon Josefsson <simon@josefsson.org>
56 files changed, 32 insertions, 8756 deletions
diff --git a/.github/workflows/macos.yml b/.github/workflows/macos.yml index a549910fb3..b200769bda 100644 --- a/.github/workflows/macos.yml +++ b/.github/workflows/macos.yml @@ -26,7 +26,7 @@ jobs: run: ./bootstrap - name: configure run: | - CC=clang ./configure --disable-full-test-suite --disable-valgrind-tests --disable-doc --disable-guile --disable-dependency-tracking + CC=clang ./configure --disable-full-test-suite --disable-valgrind-tests --disable-doc --disable-dependency-tracking - name: make run: | make -j$(sysctl -n hw.ncpu) || make -j$(sysctl -n hw.ncpu) V=1 diff --git a/.gitignore b/.gitignore index 1e876c2dc8..634979f3bc 100644 --- a/.gitignore +++ b/.gitignore @@ -96,7 +96,6 @@ doc/gnutls.epub doc/gnutls-extra-api.texi doc/gnutls.fn doc/gnutls.fns -doc/gnutls-guile.html doc/gnutls.html doc/gnutls.info* doc/gnutls.ky @@ -177,13 +176,11 @@ doc/sbuf-api.texi doc/scripts/Makefile doc/scripts/Makefile.in doc/socket-api.texi -doc/stamp-1 doc/stamp_enums doc/stamp_functions doc/stamp_invoke doc/stamp-vti doc/tpm-api.texi -doc/version-guile.texi doc/version.texi doc/x509-api.texi extra/includes/Makefile @@ -202,18 +199,6 @@ GnuTLS-*-coverage/ gnutls-*.tar.* gtk-doc.m4 gtk-doc.make -guile/Makefile -guile/Makefile.in -guile/modules/gnutls/extra.go -guile/modules/gnutls.go -guile/modules/gnutls.scm -guile/modules/Makefile -guile/modules/Makefile.in -guile/src/guile-gnutls-v-2.la -guile/src/Makefile -guile/src/Makefile.in -guile/tests/Makefile -guile/tests/Makefile.in INSTALL ldd.sh lib/accelerated/aarch64/libaarch64.la diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 250964873b..b784172bc9 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -183,13 +183,8 @@ doc-dist.Fedora: needs: - fedora/bootstrap script: - - GUILE=/usr/bin/guile2.2 - - GUILD=/usr/bin/guild2.2 - - guile_snarf=/usr/bin/guile-snarf2.2 - - export GUILE GUILD guile_snarf - CFLAGS="-std=c99 -O2 -g" dash ./configure --disable-gcc-warnings --cache-file $CCACHE_FILE --prefix=/usr --libdir=/usr/lib64 --disable-cxx --disable-non-suiteb-curves --enable-gtk-doc --disable-maintainer-mode --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS -C doc stamp-vti - - make -j$BUILDJOBS -C doc stamp-1 - make -j$BUILDJOBS -C doc stamp_enums - make -j$BUILDJOBS - make -j$BUILDJOBS -C doc gnutls.html @@ -212,7 +207,7 @@ UB+ASAN-Werror.Fedora.x86_64.gcc: - export LSAN_OPTIONS=suppressions=$(pwd)/devel/lsan.supp - export CFLAGS="-std=c99 -O1 -g -Wno-cpp -Werror -fno-omit-frame-pointer -fsanitize=undefined,bool,alignment,null,enum,bounds-strict,address,leak,nonnull-attribute -fno-sanitize-recover=all -fsanitize-address-use-after-scope" - export CXXFLAGS="$CFLAGS" - - dash ./configure --cache-file $CCACHE_FILE --disable-guile --disable-doc --with-pkcs12-iter-count=10000 + - dash ./configure --cache-file $CCACHE_FILE --disable-doc --with-pkcs12-iter-count=10000 - sed -i 's/-Werror/-Wno-parentheses -Werror/g' src/Makefile - make -j$BUILDJOBS # Use $BUILDJOBS since the fuzzers should use mainly CPU (no blocking I/O) @@ -223,7 +218,7 @@ UB+ASAN-Werror.Fedora.x86_64.gcc: - make -j$BUILDJOBS check -C fuzz GNUTLS_CPUID_OVERRIDE=0x8 - make -j$BUILDJOBS check -C fuzz GNUTLS_CPUID_OVERRIDE=0x20 - make -j$CHECKJOBS check -C tests - - dash ./configure --cache-file $CCACHE_FILE --disable-guile --disable-doc --with-pkcs12-iter-count=10000 --with-default-trust-store-pkcs11="pkcs11:" --with-system-priority-file=/etc/crypto-policies/back-ends/gnutls.config --with-default-priority-string=@SYSTEM + - dash ./configure --cache-file $CCACHE_FILE --disable-doc --with-pkcs12-iter-count=10000 --with-default-trust-store-pkcs11="pkcs11:" --with-system-priority-file=/etc/crypto-policies/back-ends/gnutls.config --with-default-priority-string=@SYSTEM - make clean - sed -i 's/-Werror/-Wno-parentheses -Werror/g' src/Makefile - make -j$BUILDJOBS @@ -247,7 +242,7 @@ UB+ASAN-Werror-aggressive.Fedora.x86_64.gcc: - export LSAN_OPTIONS=suppressions=$(pwd)/devel/lsan.supp - export CFLAGS="-std=c99 -O1 -g -Wno-cpp -Werror -fno-omit-frame-pointer -fsanitize=undefined,bool,alignment,null,enum,bounds-strict,address,leak,nonnull-attribute -fno-sanitize-recover=all -fsanitize-address-use-after-scope -DAGGRESSIVE_REALLOC" - export CXXFLAGS="$CFLAGS" - - dash ./configure --cache-file $CCACHE_FILE --disable-guile --disable-doc --with-pkcs12-iter-count=10000 + - dash ./configure --cache-file $CCACHE_FILE --disable-doc --with-pkcs12-iter-count=10000 - sed -i 's/-Werror/-Wno-parentheses -Werror/g' src/Makefile - make -j$BUILDJOBS # Use $BUILDJOBS since the fuzzers should use mainly CPU (no blocking I/O) @@ -258,7 +253,7 @@ UB+ASAN-Werror-aggressive.Fedora.x86_64.gcc: - make -j$BUILDJOBS check -C fuzz GNUTLS_CPUID_OVERRIDE=0x8 - make -j$BUILDJOBS check -C fuzz GNUTLS_CPUID_OVERRIDE=0x20 - make -j$CHECKJOBS check -C tests - - dash ./configure --cache-file $CCACHE_FILE --disable-guile --disable-doc --with-pkcs12-iter-count=10000 --with-default-trust-store-pkcs11="pkcs11:" --with-system-priority-file=/etc/crypto-policies/back-ends/gnutls.config --with-default-priority-string=@SYSTEM + - dash ./configure --cache-file $CCACHE_FILE --disable-doc --with-pkcs12-iter-count=10000 --with-default-trust-store-pkcs11="pkcs11:" --with-system-priority-file=/etc/crypto-policies/back-ends/gnutls.config --with-default-priority-string=@SYSTEM - make clean - sed -i 's/-Werror/-Wno-parentheses -Werror/g' src/Makefile - make -j$BUILDJOBS @@ -283,7 +278,7 @@ UB+ASAN-Werror.Fedora.x86_64.gcc-aggressive: - export LSAN_OPTIONS=suppressions=$(pwd)/devel/lsan.supp - export CFLAGS="-std=c99 -O1 -g -Wno-cpp -Werror -fno-omit-frame-pointer -fsanitize=undefined,bool,alignment,null,enum,bounds-strict,address,leak,nonnull-attribute -fno-sanitize-recover=all -fsanitize-address-use-after-scope -DAGGRESSIVE_REALLOC" - export CXXFLAGS="$CFLAGS" - - dash ./configure --cache-file $CCACHE_FILE --disable-guile --disable-doc --disable-hardware-acceleration + - dash ./configure --cache-file $CCACHE_FILE --disable-doc --disable-hardware-acceleration - sed -i 's/-Werror/-Wno-parentheses -Werror/g' src/Makefile - make -j$BUILDJOBS # Use $BUILDJOBS since the fuzzers should use mainly CPU (no blocking I/O) @@ -294,7 +289,7 @@ UB+ASAN-Werror.Fedora.x86_64.gcc-aggressive: - make -j$BUILDJOBS check -C fuzz GNUTLS_CPUID_OVERRIDE=0x8 - make -j$BUILDJOBS check -C fuzz GNUTLS_CPUID_OVERRIDE=0x20 - make -j$CHECKJOBS check -C tests - - dash ./configure --cache-file $CCACHE_FILE --disable-guile --disable-doc --disable-hardware-acceleration --with-default-trust-store-pkcs11="pkcs11:" --with-system-priority-file=/etc/crypto-policies/back-ends/gnutls.config --with-default-priority-string=@SYSTEM + - dash ./configure --cache-file $CCACHE_FILE --disable-doc --disable-hardware-acceleration --with-default-trust-store-pkcs11="pkcs11:" --with-system-priority-file=/etc/crypto-policies/back-ends/gnutls.config --with-default-priority-string=@SYSTEM - make clean - sed -i 's/-Werror/-Wno-parentheses -Werror/g' src/Makefile - make -j$BUILDJOBS @@ -322,7 +317,7 @@ fedora-notools/build: needs: - fedora/bootstrap script: - - dash ./configure --cache-file $CCACHE_FILE --disable-gcc-warnings --disable-full-test-suite --disable-doc --disable-guile --disable-tools --enable-tests --with-pkcs12-iter-count=10000 + - dash ./configure --cache-file $CCACHE_FILE --disable-gcc-warnings --disable-full-test-suite --disable-doc --disable-tools --enable-tests --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS # build tests, but don't execute them - make -j$BUILDJOBS check TESTS="" @@ -353,7 +348,6 @@ fedora-minimal/build: --disable-ssl3-support --disable-ssl2-support --disable-doc --enable-openssl-compatibility --disable-gcc-warnings --with-system-priority-file="" --disable-gost - --disable-guile --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS # build tests, but don't execute them @@ -404,7 +398,7 @@ fedora-SSL-3.0/build: - fedora/bootstrap script: - update-crypto-policies --set LEGACY - - dash ./configure --disable-tls13-interop --disable-gcc-warnings --cache-file $CCACHE_FILE --enable-sha1-support --enable-ssl3-support --enable-seccomp-tests --disable-doc --disable-guile --disable-strict-der-time --with-pkcs12-iter-count=10000 + - dash ./configure --disable-tls13-interop --disable-gcc-warnings --cache-file $CCACHE_FILE --enable-sha1-support --enable-ssl3-support --enable-seccomp-tests --disable-doc --disable-strict-der-time --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS # build tests, but don't execute them - make -j$BUILDJOBS check TESTS="" @@ -425,7 +419,7 @@ fedora-FIPS140-2/build: needs: - fedora/bootstrap script: - - dash ./configure --disable-gcc-warnings --cache-file $CCACHE_FILE --disable-non-suiteb-curves --enable-fips140-mode --disable-doc --disable-full-test-suite --disable-guile --with-pkcs12-iter-count=10000 + - dash ./configure --disable-gcc-warnings --cache-file $CCACHE_FILE --disable-non-suiteb-curves --enable-fips140-mode --disable-doc --disable-full-test-suite --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS # build tests, but don't execute them - GNUTLS_FORCE_FIPS_MODE=1 make -j$BUILDJOBS check TESTS="" @@ -448,7 +442,7 @@ fedora-ktls/build: needs: - fedora/bootstrap script: - - dash ./configure --disable-gcc-warnings --cache-file $CCACHE_FILE --disable-non-suiteb-curves --enable-ktls --disable-doc --disable-full-test-suite --disable-guile --with-pkcs12-iter-count=10000 + - dash ./configure --disable-gcc-warnings --cache-file $CCACHE_FILE --disable-non-suiteb-curves --enable-ktls --disable-doc --disable-full-test-suite --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS # build tests, but don't execute them - make -j$BUILDJOBS check TESTS="" @@ -484,7 +478,7 @@ fedora-ktls/test: - make -j$BUILDJOBS - make -j$BUILDJOBS install - popd - - PKG_CONFIG_PATH=${PWD}/nettle-git/$NETTLE_DIR/lib64/pkgconfig dash ./configure --disable-gcc-warnings --disable-doc --disable-guile --with-pkcs12-iter-count=10000 + - PKG_CONFIG_PATH=${PWD}/nettle-git/$NETTLE_DIR/lib64/pkgconfig dash ./configure --disable-gcc-warnings --disable-doc --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS - make -j$BUILDJOBS check TESTS="" @@ -535,7 +529,7 @@ fedora-threadsan/build: - fedora/bootstrap script: - CFLAGS="-fsanitize=thread -g -O2" CXXFLAGS=$CFLAGS - dash ./configure --disable-gcc-warnings --disable-doc --cache-file $CCACHE_FILE --disable-non-suiteb-curves --disable-guile --enable-fips140-mode --disable-full-test-suite --with-pkcs12-iter-count=10000 + dash ./configure --disable-gcc-warnings --disable-doc --cache-file $CCACHE_FILE --disable-non-suiteb-curves --enable-fips140-mode --disable-full-test-suite --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS - make -j$BUILDJOBS -C tests check SUBDIRS=. TESTS="" TSAN_OPTIONS="suppressions=$(pwd)/devel/tsan.supp" GNUTLS_SKIP_FIPS_INTEGRITY_CHECKS=1 GNUTLS_FORCE_FIPS_MODE=1 @@ -558,7 +552,7 @@ fedora-static-analyzers/build: - fedora/bootstrap #TODO originally, before_script was set to "/bin/true".. is there a reason not to create the cache? script: - - scan-build ./configure --cache-file $CCACHE_FILE --disable-doc --disable-guile --enable-fips140-mode --with-pkcs12-iter-count=10000 + - scan-build ./configure --cache-file $CCACHE_FILE --disable-doc --enable-fips140-mode --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS syntax-check gnulib_dir=$GNULIB_SRCDIR - make -j$BUILDJOBS -C gl - scan-build --status-bugs -o scan-build-lib make -j$BUILDJOBS -C lib @@ -592,13 +586,8 @@ fedora-static-analyzers/test: # - .fedora # script: # - SUBMODULE_NOFETCH=1 ./bootstrap -# - GUILE=/usr/bin/guile2.2 -# - GUILD=/usr/bin/guild2.2 -# - guile_snarf=/usr/bin/guile-snarf2.2 -# - export GUILE GUILD guile_snarf # - CFLAGS="-std=c99 -O2 -g" dash ./configure --disable-gcc-warnings --cache-file $CCACHE_FILE --prefix=/usr --libdir=/usr/lib64 --disable-cxx --disable-non-suiteb-curves --enable-gtk-doc --disable-maintainer-mode # - make -j$BUILDJOBS -C doc stamp-vti -# - make -j$BUILDJOBS -C doc stamp-1 # - make -j$BUILDJOBS -C doc stamp_enums # - make -j$BUILDJOBS # - make -j$BUILDJOBS -C doc gnutls.html @@ -635,10 +624,6 @@ fedora-abicoverage/build: needs: - fedora/bootstrap script: - - GUILE=/usr/bin/guile2.2 - - GUILD=/usr/bin/guild2.2 - - guile_snarf=/usr/bin/guile-snarf2.2 - - export GUILE GUILD guile_snarf - CFLAGS="-g -Og" dash ./configure --disable-gcc-warnings --cache-file $CCACHE_FILE --prefix=/usr --libdir=/usr/lib64 --enable-code-coverage --disable-maintainer-mode --disable-doc --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS - make -j$BUILDJOBS check TESTS="" @@ -688,7 +673,7 @@ debian/build: needs: - debian/bootstrap script: - - dash ./configure --enable-oldgnutls-interop --disable-gcc-warnings --cache-file $CCACHE_FILE --disable-doc --disable-guile --with-pkcs12-iter-count=10000 LDFLAGS='-Wl,-Bsymbolic-functions -Wl,-z,relro -Wl,-z,now' + - dash ./configure --enable-oldgnutls-interop --disable-gcc-warnings --cache-file $CCACHE_FILE --disable-doc --with-pkcs12-iter-count=10000 LDFLAGS='-Wl,-Bsymbolic-functions -Wl,-z,relro -Wl,-z,now' - make -j$BUILDJOBS - make -j$BUILDJOBS check TESTS="" @@ -716,7 +701,7 @@ debian/test: # Debian's softhsm package is not multiarch yet. Missing softhsm libraries # for the target will cause the test suite to fail when p11-kit is enabled. - dash ./configure --build=$build --host=$host --disable-gcc-warnings - --cache-file $CCACHE_FILE --disable-doc --disable-guile + --cache-file $CCACHE_FILE --disable-doc --without-p11-kit --disable-full-test-suite --with-pkcs12-iter-count=10000 - make -j$BUILDJOBS @@ -810,7 +795,7 @@ debian-cross/aarch64-linux-gnu/test: script: # - mount -t binfmt_misc binfmt_misc /proc/sys/fs/binfmt_misc # - echo ':DOSWin:M::MZ::/usr/bin/wine:' > /proc/sys/fs/binfmt_misc/register - - dash ./configure --disable-gcc-warnings --host=${arch_name}-w64-mingw32 --target=${arch_name}-w64-mingw32 --cache-file $CCACHE_FILE --with-included-libtasn1 --disable-guile --disable-nls --with-included-unistring --disable-non-suiteb-curves --disable-full-test-suite --disable-doc --with-pkcs12-iter-count=10000 + - dash ./configure --disable-gcc-warnings --host=${arch_name}-w64-mingw32 --target=${arch_name}-w64-mingw32 --cache-file $CCACHE_FILE --with-included-libtasn1 --disable-nls --with-included-unistring --disable-non-suiteb-curves --disable-full-test-suite --disable-doc --with-pkcs12-iter-count=10000 - mingw${arch_bits}-make -j$BUILDJOBS # https://bugzilla.redhat.com/show_bug.cgi?id=2049401 - mingw${arch_bits}-make -j$BUILDJOBS -C $PWD/tests check TESTS="" diff --git a/.packit.yaml b/.packit.yaml index a27df63658..2a7dee2f87 100644 --- a/.packit.yaml +++ b/.packit.yaml @@ -15,7 +15,6 @@ actions: post-upstream-clone: - "wget https://src.fedoraproject.org/rpms/gnutls/raw/main/f/gnutls.spec" - "wget https://src.fedoraproject.org/rpms/gnutls/raw/main/f/gnutls-3.2.7-rpath.patch" - - "wget https://src.fedoraproject.org/rpms/gnutls/raw/main/f/gnutls-3.6.7-no-now-guile.patch" get-current-version: - "git describe --abbrev=0" create-archive: diff --git a/.x-sc_prohibit_test_minus_ao b/.x-sc_prohibit_test_minus_ao deleted file mode 100644 index ad4342ffed..0000000000 --- a/.x-sc_prohibit_test_minus_ao +++ /dev/null @@ -1 +0,0 @@ -^m4/guile.m4 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 723666ea4d..300f98ee2b 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -427,29 +427,6 @@ driver is provided as `devel/git-abidiff-gnutls`. See the comment in the file for the instruction. -# Guile bindings: - - Parts of the Guile bindings, such as types (aka. "SMOBs"), enum values, -constants, are automatically generated. This is handled by the modules -under `guile/modules/gnutls/build/'; these modules are only used at -build-time and are not installed. - -The Scheme variables they generate (e.g., constants, type predicates, -etc.) are exported to user programs through `gnutls.scm' and -`gnutls/extra.scm', both of which are installed. - -For instance, when adding/removing/renaming enumerates or constants, -two things must be done: - - 1. Update the enum list in `build/enums.scm' (currently dependencies - are not tracked, so you have to run "make clean all" in `guile/' - after). - - 2. Update the export list of `gnutls.scm' (or `extra.scm'). - -Note that, for constants and enums, "schemefied" names are used, as -noted under the "Guile API Conventions" node of the manual. - # Automated testing GnuTLS primarily relies on gitlab-ci which is configured in .gitlab-ci.yml diff --git a/Makefile.am b/Makefile.am index cf94c616a0..2b5a9a0f96 100644 --- a/Makefile.am +++ b/Makefile.am @@ -23,9 +23,6 @@ DISTCHECK_CONFIGURE_FLAGS = \ --enable-doc \ --enable-gtk-doc \ --disable-valgrind-tests \ - --with-guile-site-dir='$$(datarootdir)/guile/site/$$(GUILE_EFFECTIVE_VERSION)' \ - --with-guile-site-ccache-dir='$$(libdir)/guile/$$(GUILE_EFFECTIVE_VERSION)/site-ccache' \ - --with-guile-extension-dir='$$(libdir)/guile/$$(GUILE_EFFECTIVE_VERSION)/extensions' \ AUTOGEN=false SUBDIRS = gl lib extra @@ -45,10 +42,6 @@ if ENABLE_TESTS SUBDIRS += tests fuzz endif -if HAVE_GUILE -SUBDIRS += guile -endif - if ENABLE_MANPAGES SUBDIRS += doc/manpages endif @@ -189,7 +182,6 @@ files-update: @echo "******************************************************************************************" dist-hook: - $(PKG_CONFIG) --atleast-version=2.2.0 guile-2.2 if test -d "$(top_srcdir)/devel";then \ $(MAKE) -C $(top_srcdir) symbol-check && \ $(MAKE) -C $(top_srcdir) abi-check-latest; \ @@ -7,6 +7,10 @@ See the end for copying conditions. * Version 3.8.0 (unreleased ????-??-??) +** guile: Guile-bindings removed. +They have been extracted into a separate project to reduce complexity +and to simplify maintenance, see <https://gitlab.com/gnutls/guile/>. + ** libgnutls: GNUTLS_NO_STATUS_REQUEST flag and %NO_STATUS_REQUEST priority modifier have been added to allow disabling of the status_request TLS extension in the client side. @@ -33,7 +33,6 @@ We require several tools to check out and build the software, including: * [Git](https://git-scm.com/) * [Perl](https://www.cpan.org/) * [Nettle](https://www.lysator.liu.se/~nisse/nettle/) -* [Guile](https://www.gnu.org/software/guile/) * [p11-kit](https://p11-glue.github.io/p11-glue/p11-kit.html) * [gperf](https://www.gnu.org/software/gperf/) * [libtasn1](https://www.gnu.org/software/libtasn1/) (optional) @@ -60,7 +59,7 @@ Debian/Ubuntu: ``` apt-get install -y dash git-core autoconf libtool gettext autopoint apt-get install -y automake python3 nettle-dev libp11-kit-dev libtspi-dev libunistring-dev -apt-get install -y guile-2.2-dev libtasn1-bin libtasn1-6-dev libidn2-0-dev gawk gperf +apt-get install -y libtasn1-bin libtasn1-6-dev libidn2-0-dev gawk gperf apt-get install -y libtss2-dev libunbound-dev dns-root-data bison gtk-doc-tools apt-get install -y texinfo texlive texlive-generic-recommended texlive-extra-utils ``` @@ -72,7 +71,7 @@ Fedora/RHEL: ``` yum install -y dash git autoconf libtool gettext-devel automake patch yum install -y nettle-devel p11-kit-devel libunistring-devel -yum install -y tpm2-tss-devel trousers-devel guile22-devel libtasn1-devel libidn2-devel gawk gperf +yum install -y tpm2-tss-devel trousers-devel libtasn1-devel libidn2-devel gawk gperf yum install -y libtasn1-tools unbound-devel bison gtk-doc texinfo texlive ``` @@ -46,7 +46,7 @@ VC_LIST_ALWAYS_EXCLUDE_REGEX = ^maint.mk|gtk-doc.make|m4/pkg|doc/fdl-1.3.texi|sr # Explicit syntax-check exceptions. exclude_file_name_regexp--sc_copyright_check = ^./gnulib/.*$$ -exclude_file_name_regexp--sc_error_message_uppercase = ^doc/examples/ex-cxx.cpp|guile/src/core.c|src/certtool.c|src/ocsptool.c|src/crywrap/crywrap.c|tests/pkcs12_encode.c$$ +exclude_file_name_regexp--sc_error_message_uppercase = ^doc/examples/ex-cxx.cpp|src/certtool.c|src/ocsptool.c|src/crywrap/crywrap.c|tests/pkcs12_encode.c$$ exclude_file_name_regexp--sc_file_system = ^doc/doxygen/Doxyfile exclude_file_name_regexp--sc_prohibit_cvs_keyword = ^lib/nettle/.*$$ exclude_file_name_regexp--sc_prohibit_undesirable_word_seq = ^tests/nist-pkits/gnutls-nist-tests.html$$ @@ -126,9 +126,6 @@ web: sed 's/\@VERSION\@/$(VERSION)/g' -i $(htmldir)/manual/html_node/*.html $(htmldir)/manual/gnutls.html -cd doc && $(MAKE) gnutls.epub && cp gnutls.epub ../$(htmldir)/manual/ cd doc/latex && $(MAKE) gnutls.pdf && cp gnutls.pdf ../../$(htmldir)/manual/ - $(MAKE) -C doc gnutls-guile.html gnutls-guile.pdf - cd doc && makeinfo --html --split=node -o ../$(htmldir)/manual/gnutls-guile/ --css-include=./texinfo.css gnutls-guile.texi - cd doc && cp gnutls-guile.pdf gnutls-guile.html ../$(htmldir)/manual/ -cp -v doc/reference/html/*.html doc/reference/html/*.png doc/reference/html/*.devhelp* doc/reference/html/*.css $(htmldir)/reference/ ASM_SOURCES_XXX := \ diff --git a/configure.ac b/configure.ac index 4c5c0c9b43..b9cd6234c5 100644 --- a/configure.ac +++ b/configure.ac @@ -1143,118 +1143,6 @@ if test "x$with_default_blocklist_file" != x; then ["$with_default_blocklist_file"], [use the given certificate blocklist file]) fi -dnl Guile bindings. -AC_MSG_CHECKING([whether building Guile bindings]) -AC_ARG_ENABLE(guile, - AS_HELP_STRING([--disable-guile], [don't build GNU Guile bindings]), - [opt_guile_bindings=$enableval], [opt_guile_bindings=yes]) -AC_MSG_RESULT($opt_guile_bindings) - -AC_ARG_WITH([guile-site-dir], AS_HELP_STRING([--with-guile-site-dir=DIR], - [guile site directory for gnutls, default is guile system settings]), - [guilesitedir="${withval}"], [guilesitedir='$(GUILE_SITE)']) -AC_ARG_WITH([guile-site-ccache-dir], AS_HELP_STRING([--with-guile-site-ccache-dir=DIR], - [guile ccache directory for gnutls, default is guile system settings]), - [guilesiteccachedir="${withval}"], [guilesiteccachedir='$(GUILE_SITE_CCACHE)']) -AC_ARG_WITH([guile-extension-dir], AS_HELP_STRING([--with-guile-extension-dir=DIR], - [guile extension directory for gnutls, default is guile system settings]), - [guileextensiondir="${withval}"], [guileextensiondir='$(GUILE_EXTENSION)']) -AC_SUBST([guilesitedir]) -AC_SUBST([guilesiteccachedir]) -AC_SUBST([guileextensiondir]) -maybe_guileextensiondir="\"$guileextensiondir\"" - -if test "$opt_guile_bindings" = "yes"; then - AC_MSG_RESULT([*** -*** Detecting GNU Guile... -]) - - AC_PATH_PROG([guile_snarf], [guile-snarf]) - if test "x$guile_snarf" = "x"; then - AC_MSG_WARN([`guile-snarf' from Guile not found. Guile bindings not built.]) - opt_guile_bindings=no - else - dnl Check for 'guild', which can be used to compile Scheme code - dnl on Guile 2.x. - AC_PATH_PROG([GUILD], [guild]) - AC_SUBST([GUILD]) - - GUILE_PKG([3.0 2.2 2.0]) - GUILE_PROGS - GUILE_SITE_DIR - GUILE_FLAGS - - # Backward compatibility with <guile-2.2 m4 macro that is used - # due to autreconf of several CI machine. - # We need to guess the locations of ccache and extension - if test -z "${GUILE_SITE_CCACHE}"; then - AC_MSG_NOTICE([Found <guile-2.2 m4, macro emulating]) - - AC_MSG_CHECKING([for GUILE_SITE_CCACHE via pkg-config]) - GUILE_SITE_CCACHE=`$PKG_CONFIG --variable=siteccachedir guile-$GUILE_EFFECTIVE_VERSION` - AC_MSG_RESULT([${GUILE_SITE_CCACHE}]) - if test -z "${GUILE_SITE_CCACHE}"; then - AC_MSG_CHECKING([for GUILE_SITE_CCACHE via guile]) - GUILE_SITE_CCACHE=`$GUILE -c "(display (if (defined? '%site-ccache-dir) (%site-ccache-dir) \"\"))"` - AC_MSG_RESULT([${GUILE_SITE_CCACHE}]) - fi - AC_SUBST([GUILE_SITE_CCACHE]) - - AC_MSG_CHECKING([for GUILE_EXTENSION]) - GUILE_EXTENSION=`$PKG_CONFIG --print-errors --variable=extensiondir guile-$GUILE_EFFECTIVE_VERSION` - AC_MSG_RESULT([${GUILE_EXTENSION}]) - AC_SUBST([GUILE_EXTENSION]) - fi - - save_CFLAGS="$CFLAGS" - save_LIBS="$LIBS" - CFLAGS="$CFLAGS $GUILE_CFLAGS" - LIBS="$LIBS $GUILE_LDFLAGS" - AC_MSG_CHECKING([whether GNU Guile is recent enough]) - AC_LINK_IFELSE([AC_LANG_PROGRAM([#include <libguile.h>], [scm_from_locale_string ("")])], - [], [opt_guile_bindings=no]) - CFLAGS="$save_CFLAGS" - LIBS="$save_LIBS" - - if test "$opt_guile_bindings" = "yes"; then - AC_MSG_RESULT([yes]) - AC_MSG_CHECKING([whether gcc supports -fgnu89-inline]) - _gcc_cflags_save="$CFLAGS" - CFLAGS="${CFLAGS} -fgnu89-inline" - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([])], - gnu89_inline=yes, gnu89_inline=no) - AC_MSG_RESULT($gnu89_inline) - CFLAGS="$_gcc_cflags_save" - - # Optional Guile functions. - save_CFLAGS="$CFLAGS" - save_LIBS="$LIBS" - CFLAGS="$CFLAGS $GUILE_CFLAGS" - LIBS="$LIBS $GUILE_LDFLAGS" - AC_CHECK_FUNCS([scm_gc_malloc_pointerless]) - CFLAGS="$save_CFLAGS" - LIBS="$save_LIBS" - - # Do we need to hard-code $guileextensiondir in gnutls.scm? - # This is not necessary when $guileextensiondir is equal to - # Guile's 'extensiondir' as specified in 'guile-MAJOR.MINOR.pc'. - if test "$guileextensiondir" = "`$PKG_CONFIG guile-$GUILE_EFFECTIVE_VERSION --variable extensiondir`" \ - || test "$guileextensiondir" = '$(GUILE_EXTENSION)'; then - maybe_guileextensiondir='#f' - fi - else - AC_MSG_RESULT([no]) - AC_MSG_WARN([A sufficiently recent GNU Guile not found. Guile bindings not built.]) - opt_guile_bindings=no - fi - fi -fi - -AC_SUBST([maybe_guileextensiondir]) -AM_CONDITIONAL([HAVE_GUILE], [test "$opt_guile_bindings" = "yes"]) -AM_CONDITIONAL([HAVE_GUILD], [test "x$GUILD" != "x"]) -AM_CONDITIONAL([CROSS_COMPILING], [test "x$cross_compiling" = "xyes"]) - LIBGNUTLS_LIBS="-L${libdir} -lgnutls $LIBS" LIBGNUTLS_CFLAGS="-I${includedir}" AC_SUBST(LIBGNUTLS_LIBS) @@ -1338,7 +1226,6 @@ AC_DEFINE([INI_STOP_ON_FIRST_ERROR], 1, [whether to stop on first error]) AC_DEFINE_UNQUOTED([INI_INLINE_COMMENT_PREFIXES], [";#"], [The inline comment prefixes]) AC_DEFINE_UNQUOTED([INI_START_COMMENT_PREFIXES], [";#"], [The comment prefixes]) -AC_CONFIG_FILES([guile/pre-inst-guile], [chmod +x guile/pre-inst-guile]) AC_CONFIG_FILES([ Makefile doc/Makefile @@ -1358,8 +1245,6 @@ AC_CONFIG_FILES([ libdane/includes/Makefile libdane/gnutls-dane.pc gl/Makefile - guile/Makefile - guile/src/Makefile lib/Makefile lib/accelerated/Makefile lib/accelerated/x86/Makefile @@ -1456,7 +1341,6 @@ if features are disabled) AC_MSG_NOTICE([Optional libraries: - Guile wrappers: $opt_guile_bindings C++ library: $use_cxx DANE library: $enable_dane OpenSSL compat: $enable_openssl diff --git a/devel/release-steps.md b/devel/release-steps.md index 4a765893f7..27b6eae418 100644 --- a/devel/release-steps.md +++ b/devel/release-steps.md @@ -14,12 +14,10 @@ `make abi-dump-latest`, and push any changes to the [abi-dump repository]; then do `make abi-check` 1. Create a distribution tarball: note that this requires - the documentation (not only the library docs but also the Guile binding - docs) to be generated. See the `doc-dist.Fedora` job in + the documentation to be generated. See the `doc-dist.Fedora` job in [.gitlab-ci.yml](.gitlab-ci.yml), which does the same thing in the CI: ```console - # Install necesarry packages for documentation and Guile bindings, set - # environment variables such as GUILE, GUILD, and guile_snarf, and then: + # Install necesarry packages for documentation, and then: make distcheck ``` 1. Create a detached GPG signature: diff --git a/doc/.gitignore b/doc/.gitignore index c7bc1196ed..ced69e5901 100644 --- a/doc/.gitignore +++ b/doc/.gitignore @@ -1,31 +1,4 @@ -gnutls-guile.aux -gnutls-guile.cp -gnutls-guile.cps -gnutls-guile.fn -gnutls-guile.fns -gnutls-guile.info -gnutls-guile.ky -gnutls-guile.log -gnutls-guile.pdf -gnutls-guile.pg -gnutls-guile.toc -gnutls-guile.tp -gnutls-guile.vr -gnutls-guile.vrs gnutls.ltx -guile.aux -guile.cp -guile.cps -guile.fn -guile.fns -guile.info -guile.ky -guile.log -guile.pg -guile.toc -guile.tp -guile.vr -guile.vrs alerts.texi alert-printlist latex/alerts.tex diff --git a/doc/Makefile.am b/doc/Makefile.am index 3a4151036c..e3e48c8903 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -21,7 +21,7 @@ EXTRA_DIST = TODO certtool.cfg gnutls.html \ doxygen/Doxyfile.in doxygen/Doxyfile.orig texinfo.css \ - gnutls-guile.html stamp_enums stamp_functions \ + stamp_enums stamp_functions \ doc.mk COPYING COPYING.LESSER IMAGES = \ @@ -175,7 +175,7 @@ invoke-tpmtool.texi: $(top_srcdir)/src/tpmtool-options.json $< $@ -info_TEXINFOS = gnutls.texi gnutls-guile.texi +info_TEXINFOS = gnutls.texi gnutls_TEXINFOS = gnutls.texi fdl-1.3.texi \ cha-bib.texi cha-cert-auth.texi cha-cert-auth2.texi \ cha-ciphersuites.texi cha-copying.texi cha-functions.texi \ @@ -511,40 +511,6 @@ compare-makefile: enums.texi .PHONY: compare-makefile compare-exported -# Guile texinfos. - -guile_texi = core.c.texi -BUILT_SOURCES = $(guile_texi) -MAINTAINERCLEANFILES += $(guile_texi) -EXTRA_DIST += $(guile_texi) extract-guile-c-doc.scm -guile_TEXINFOS = gnutls-guile.texi $(guile_texi) - -if HAVE_GUILE - -GUILE_FOR_BUILD = \ - GUILE_AUTO_COMPILE=0 \ - $(GUILE) -q -L $(top_srcdir)/guile/modules - -SNARF_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \ - -I$(top_srcdir)/lib/includes -I$(top_builddir)/lib/includes \ - -I$(top_srcdir)/extra/includes \ - -I$(top_srcdir)/guile/src -I$(top_builddir)/guile/src \ - $(GUILE_CFLAGS) - -core.c.texi: $(top_srcdir)/guile/src/core.c - $(MAKE) -C ../guile/src built-sources && \ - $(GUILE_FOR_BUILD) -l "$(srcdir)/extract-guile-c-doc.scm" \ - -e '(apply main (cdr (command-line)))' \ - -- "$^" "$(CPP)" "$(SNARF_CPPFLAGS) $(CPPFLAGS)" \ - > "$@" - -else !HAVE_GUILE - -core.c.texi: - echo "(Guile not available, documentation not generated.)" > $@ - -endif !HAVE_GUILE - gnutls.xml: epub.texi makeinfo --docbook $< $(SED) -i 's/\&\#8226;//g' $@ diff --git a/doc/doxygen/Doxyfile.in b/doc/doxygen/Doxyfile.in index 6b7a1a7537..516766adb0 100644 --- a/doc/doxygen/Doxyfile.in +++ b/doc/doxygen/Doxyfile.in @@ -577,7 +577,7 @@ EXCLUDE_SYMLINKS = NO # against the file with absolute path, so to exclude all test directories # for example use the pattern */test/* -EXCLUDE_PATTERNS = */config.h */doc/* */build-aux/* */gl/* */src/*-gaa.? */src/cfg/* */tests/* */guile/* *.cpp */gnutlsxx.h */lib/minitasn1/* *openssl* +EXCLUDE_PATTERNS = */config.h */doc/* */build-aux/* */gl/* */src/*-gaa.? */src/cfg/* */tests/* *.cpp */gnutlsxx.h */lib/minitasn1/* *openssl* # The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names # (namespaces, classes, functions, etc.) that should be excluded from the diff --git a/doc/extract-guile-c-doc.scm b/doc/extract-guile-c-doc.scm deleted file mode 100644 index 3a310abba4..0000000000 --- a/doc/extract-guile-c-doc.scm +++ /dev/null @@ -1,69 +0,0 @@ -;;; extract-c-doc.scm -- Output Texinfo from "snarffed" C files. -;;; -;;; Copyright 2006-2012 Free Software Foundation, Inc. -;;; -;;; -;;; 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 3 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 - -;;; Written by Ludovic Courtès <ludo@chbouib.org>. - -(use-modules (system documentation c-snarf) - (system documentation output) - - (srfi srfi-1)) - -(define (main file cpp+args cpp-flags . procs) - ;; Arguments: - ;; - ;; 1. C file to be processed; - ;; 2. how to invoke the CPP (e.g., "cpp -E"); - ;; 3. additional CPP flags (e.g., "-I /usr/local/include"); - ;; 4. optionally, a list of Scheme procedure names whose documentation is - ;; to be output. If no such list is passed, then documentation for - ;; all the Scheme functions available in the C source file is issued. - ;; - (let* ((cpp+args (string-tokenize cpp+args)) - (cpp (car cpp+args)) - (cpp-flags (append (cdr cpp+args) - (string-tokenize cpp-flags) - (list "-DSCM_MAGIC_SNARF_DOCS ")))) - ;;(format (current-error-port) "cpp-flags: ~a~%" cpp-flags) - (format (current-error-port) "extracting Texinfo doc from `~a'... " - file) - - ;; Don't mention the name of C functions. - (*document-c-functions?* #f) - - (let ((proc-doc-list - (run-cpp-and-extract-snarfing file cpp cpp-flags))) - (display "@c Automatically generated, do not edit.\n") - (display (string-concatenate - (map procedure-texi-documentation - (if (null? procs) - proc-doc-list - (filter (lambda (proc-doc) - (let ((proc-name - (assq-ref proc-doc - 'scheme-name))) - (member proc-name procs))) - proc-doc-list)))))) - (format (current-error-port) "done.~%") - (exit 0))) - - -;;; Local Variables: -;;; mode: scheme -;;; coding: latin-1 -;;; End: diff --git a/doc/gnutls-guile.texi b/doc/gnutls-guile.texi deleted file mode 100644 index d0cd1eb48b..0000000000 --- a/doc/gnutls-guile.texi +++ /dev/null @@ -1,566 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@comment %**start of header -@setfilename gnutls-guile.info -@include version-guile.texi -@settitle GnuTLS-Guile @value{VERSION} - -@c don't indent the paragraphs. -@paragraphindent 0 - -@c Unify some of the indices. -@syncodeindex tp fn -@syncodeindex pg cp - -@comment %**end of header -@finalout -@copying -This manual is last updated @value{UPDATED} for version -@value{VERSION} of GnuTLS. - -Copyright @copyright{} 2001-2012, 2014, 2016, 2019, 2022 Free Software Foundation, Inc. - -@quotation -Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.3 or -any later version published by the Free Software Foundation; with no -Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A -copy of the license is included in the section entitled ``GNU Free -Documentation License''. -@end quotation -@end copying - -@dircategory Software libraries -@direntry -* GnuTLS-Guile: (gnutls-guile). GNU Transport Layer Security Library. Guile bindings. -@end direntry - -@titlepage -@title GnuTLS-Guile -@subtitle Guile binding for GNU TLS -@subtitle for version @value{VERSION}, @value{UPDATED} -@sp 7 -@image{gnutls-logo,6cm,6cm} -@page -@vskip 0pt plus 1filll -@insertcopying -@end titlepage - -@macro xcite{ref} -[\ref\] (@pxref{Bibliography}) -@end macro - -@contents - -@node Top -@top GnuTLS-Guile - -@insertcopying - -@menu -* Preface:: Preface. -* Guile Preparations:: Note on installation and environment. -* Guile API Conventions:: Naming conventions and other idiosyncrasies. -* Guile Examples:: Quick start. -* Guile Reference:: The Scheme GnuTLS programming interface. - -* Copying Information:: You can copy and modify this manual. -* Procedure Index:: -* Concept Index:: -@end menu - -@node Preface -@chapter Preface - -This manual describes the @uref{https://www.gnu.org/software/guile/, -GNU Guile} Scheme programming interface to GnuTLS, which is distributed -as part of @uref{https://gnutls.org,GnuTLS}. The reader is -assumed to have basic knowledge of the protocol and library. Details -missing from this chapter may be found in Function reference, -of the C API reference. - -At this stage, not all the C functions are available from Scheme, but -a large subset thereof is available. - -@c ********************************************************************* -@node Guile Preparations -@chapter Guile Preparations - -The GnuTLS Guile bindings are available for the Guile 3.0 and 2.2 -series, as well as the legacy 2.0 series. - -By default they are installed under the GnuTLS installation directory, -typically @file{/usr/local/share/guile/site/}). Normally Guile -will not find the module there without help. You may experience -something like this: - -@example -$ guile -@dots{} -scheme@@(guile-user)> (use-modules (gnutls)) -ERROR: no code for module (gnutls) -@end example - -There are two ways to solve this. The first is to make sure that when -building GnuTLS, the Guile bindings will be installed in the same -place where Guile looks. You may do this by using the -@code{--with-guile-site-dir} parameter as follows: - -@example -$ ./configure --with-guile-site-dir=no -@end example - -This will instruct GnuTLS to attempt to install the Guile bindings -where Guile will look for them. It will use @code{guile-config info -pkgdatadir} to learn the path to use. - -If Guile was installed into @code{/usr}, you may also install GnuTLS -using the same prefix: - -@example -$ ./configure --prefix=/usr -@end example - -If you want to specify the path to install the Guile bindings you can -also specify the path directly: - -@example -$ ./configure --with-guile-site-dir=/opt/guile/share/guile/site -@end example - -The second solution requires some more work but may be easier to use -if you do not have system administrator rights to your machine. You -need to instruct Guile so that it finds the GnuTLS Guile bindings. -Either use the @code{GUILE_LOAD_PATH} environment variable as follows: - -@example -$ GUILE_LOAD_PATH="/usr/local/share/guile/site:$GUILE_LOAD_PATH" guile -scheme@@(guile-user)> (use-modules (gnutls)) -scheme@@(guile-user)> -@end example - -Alternatively, you can modify Guile's @code{%load-path} variable -(@pxref{Build Config, Guile's run-time options,, guile, The GNU Guile -Reference Manual}). - -At this point, you might get an error regarding -@file{guile-gnutls-v-2} similar to: - -@example -gnutls.scm:361:1: In procedure dynamic-link in expression (load-extension "guile-gnutls-v-2" "scm_init_gnutls"): -gnutls.scm:361:1: file: "guile-gnutls-v-2", message: "guile-gnutls-v-2.so: cannot open shared object file: No such file or directory" -@end example - -In this case, you will need to modify the run-time linker path, for -example as follows: - -@example -$ LD_LIBRARY_PATH=/usr/local/lib GUILE_LOAD_PATH=/usr/local/share/guile/site guile -scheme@@(guile-user)> (use-modules (gnutls)) -scheme@@(guile-user)> -@end example - -To check that you got the intended GnuTLS library version, you may -print the version number of the loaded library as follows: - -@example -$ guile -scheme@@(guile-user)> (use-modules (gnutls)) -scheme@@(guile-user)> (gnutls-version) -"@value{VERSION}" -scheme@@(guile-user)> -@end example - - -@c ********************************************************************* -@node Guile API Conventions -@chapter Guile API Conventions - -This chapter details the conventions used by Guile API, as well as -specificities of the mapping of the C API to Scheme. - -@menu -* Enumerates and Constants:: Representation of C-side constants. -* Procedure Names:: Naming conventions. -* Representation of Binary Data:: Binary data buffers. -* Input and Output:: Input and output. -* Exception Handling:: Exceptions. -@end menu - -@node Enumerates and Constants -@section Enumerates and Constants - -@cindex enumerate -@cindex constant - -Lots of enumerates and constants are used in the GnuTLS C API. For -each C enumerate type, a disjoint Scheme type is used---thus, -enumerate values and constants are not represented by Scheme symbols -nor by integers. This makes it impossible to use an enumerate value -of the wrong type on the Scheme side: such errors are automatically -detected by type-checking. - -The enumerate values are bound to variables exported by the -@code{(gnutls)} module. These variables -are named according to the following convention: - -@itemize -@item All variable names are lower-case; the underscore @code{_} -character used in the C API is replaced by hyphen @code{-}. -@item All variable names are prepended by the name of the enumerate -type and the slash @code{/} character. -@item In some cases, the variable name is made more explicit than the -one of the C API, e.g., by avoid abbreviations. -@end itemize - -Consider for instance this C-side enumerate: - -@example -typedef enum -@{ - GNUTLS_CRD_CERTIFICATE = 1, - GNUTLS_CRD_ANON, - GNUTLS_CRD_SRP, - GNUTLS_CRD_PSK -@} gnutls_credentials_type_t; -@end example - -The corresponding Scheme values are bound to the following variables -exported by the @code{(gnutls)} module: - -@example -credentials/certificate -credentials/anonymous -credentials/srp -credentials/psk -@end example - -Hopefully, most variable names can be deduced from this convention. - -Scheme-side ``enumerate'' values can be compared using @code{eq?} -(@pxref{Equality, equality predicates,, guile, The GNU Guile Reference -Manual}). Consider the following example: - -@findex session-cipher - -@example -(let ((session (make-session connection-end/client))) - - ;; - ;; ... - ;; - - ;; Check the ciphering algorithm currently used by SESSION. - (if (eq? cipher/arcfour (session-cipher session)) - (format #t "We're using the ARCFOUR algorithm"))) -@end example - -In addition, all enumerate values can be converted to a human-readable -string, in a type-specific way. For instance, @code{(cipher->string -cipher/arcfour)} yields @code{"ARCFOUR 128"}, while -@code{(key-usage->string key-usage/digital-signature)} yields -@code{"digital-signature"}. Note that these strings may not be -sufficient for use in a user interface since they are fairly concise -and not internationalized. - - -@node Procedure Names -@section Procedure Names - -Unlike C functions in GnuTLS, the corresponding Scheme procedures are -named in a way that is close to natural English. Abbreviations are -also avoided. For instance, the Scheme procedure corresponding to -@code{gnutls_certificate_set_dh_params} is named -@code{set-certificate-credentials-dh-parameters!}. The @code{gnutls_} -prefix is always omitted from variable names since a similar effect -can be achieved using Guile's nifty binding renaming facilities, -should it be needed (@pxref{Using Guile Modules,,, guile, The GNU -Guile Reference Manual}). - -Often Scheme procedure names differ from C function names in a way -that makes it clearer what objects they operate on. For example, the -Scheme procedure named @code{set-session-transport-port!} corresponds -to @code{gnutls_transport_set_ptr}, making it clear that this -procedure applies to session. - -@node Representation of Binary Data -@section Representation of Binary Data - -Many procedures operate on binary data. For instance, -@code{pkcs3-import-dh-parameters} expects binary data as input. - -@cindex bytevectors -@cindex SRFI-4 -@cindex homogeneous vector -Binary data is represented on the Scheme side using bytevectors -(@pxref{Bytevectors,,, guile, The GNU Guile Reference Manual}). -Homogeneous vectors such as SRFI-4 @code{u8vector}s can also be -used@footnote{Historically, SRFI-4 @code{u8vector}s are the closest -thing to bytevectors that Guile 1.8 and earlier supported.}. - -As an example, generating and then exporting Diffie-Hellman parameters -in the PEM format can be done as follows: - -@findex make-dh-parameters -@findex pkcs3-export-dh-parameters -@vindex x509-certificate-format/pem - -@example -(let* ((dh (make-dh-parameters 1024)) - (pem (pkcs3-export-dh-parameters dh - x509-certificate-format/pem))) - (call-with-output-file "some-file.pem" - (lambda (port) - (uniform-vector-write pem port)))) -@end example - - -@node Input and Output -@section Input and Output - -@findex set-session-transport-port! -@findex set-session-transport-fd! - -The underlying transport of a TLS session can be any Scheme -input/output port (@pxref{Ports and File Descriptors,,, guile, The GNU -Guile Reference Manual}). This has to be specified using -@code{set-session-transport-port!}. - -However, for better performance, a raw file descriptor can be -specified, using @code{set-session-transport-fd!}. For instance, if -the transport layer is a socket port over an OS-provided socket, you -can use the @code{port->fdes} or @code{fileno} procedure to obtain the -underlying file descriptor and pass it to -@code{set-session-transport-fd!} (@pxref{Ports and File Descriptors, -@code{port->fdes} and @code{fileno},, guile, The GNU Guile Reference -Manual}). This would work as follows: - -@example -(let ((socket (socket PF_INET SOCK_STREAM 0)) - (session (make-session connection-end/client))) - - ;; - ;; Establish a TCP connection... - ;; - - ;; Use the file descriptor that underlies SOCKET. - (set-session-transport-fd! session (fileno socket))) -@end example - -@findex session-record-port - -Once a TLS session is established, data can be communicated through it -(i.e., @emph{via} the TLS record layer) using the port returned by -@code{session-record-port}: - -@example -(let ((session (make-session connection-end/client))) - - ;; - ;; Initialize the various parameters of SESSION, set up - ;; a network connection, etc. - ;; - - (let ((i/o (session-record-port session))) - (display "Hello peer!" i/o) - (let ((greetings (read i/o))) - - ;; @dots{} - - (bye session close-request/rdwr)))) -@end example - -@c See <https://bugs.gnu.org/22966> for details. -@cindex buffering -Note that each write to the session record port leads to the -transmission of an encrypted TLS ``Application Data'' packet. In the -above example, we create an Application Data packet for the 11 bytes for -the string that we write. This is not efficient both in terms of CPU -usage and bandwidth (each packet adds at least 5 bytes of overhead and -can lead to one @code{write} system call), so we recommend that -applications do their own buffering. - -@findex record-send -@findex record-receive! - -A lower-level I/O API is provided by @code{record-send} and -@code{record-receive!} which take a bytevector (or a SRFI-4 vector) to -represent the data sent or received. While it might improve -performance, it is much less convenient than the session record port and -should rarely be needed. - - -@node Exception Handling -@section Exception Handling - -@cindex exceptions -@cindex errors -@cindex @code{gnutls-error} -@findex error->string - -GnuTLS errors are implemented as Scheme exceptions (@pxref{Exceptions, -exceptions in Guile,, guile, The GNU Guile Reference Manual}). Each -time a GnuTLS function returns an error, an exception with key -@code{gnutls-error} is raised. The additional arguments that are -thrown include an error code and the name of the GnuTLS procedure that -raised the exception. The error code is pretty much like an enumerate -value: it is one of the @code{error/} variables exported by the -@code{(gnutls)} module (@pxref{Enumerates and Constants}). Exceptions -can be turned into error messages using the @code{error->string} -procedure. - -The following examples illustrates how GnuTLS exceptions can be -handled: - -@example -(let ((session (make-session connection-end/server))) - - ;; - ;; ... - ;; - - (catch 'gnutls-error - (lambda () - (handshake session)) - (lambda (key err function . currently-unused) - (format (current-error-port) - "a GnuTLS error was raised by `~a': ~a~%" - function (error->string err))))) -@end example - -Again, error values can be compared using @code{eq?}: - -@example - ;; `gnutls-error' handler. - (lambda (key err function . currently-unused) - (if (eq? err error/fatal-alert-received) - (format (current-error-port) - "a fatal alert was caught!~%") - (format (current-error-port) - "something bad happened: ~a~%" - (error->string err)))) -@end example - -Note that the @code{catch} handler is currently passed only 3 -arguments but future versions might provide it with additional -arguments. Thus, it must be prepared to handle more than 3 arguments, -as in this example. - - -@c ********************************************************************* -@node Guile Examples -@chapter Guile Examples - -This chapter provides examples that illustrate common use cases. - -@menu -* Anonymous Authentication Guile Example:: Simplest client and server. -@end menu - -@node Anonymous Authentication Guile Example -@section Anonymous Authentication Guile Example - -@dfn{Anonymous authentication} is very easy to use. No certificates -are needed by the communicating parties. Yet, it allows them to -benefit from end-to-end encryption and integrity checks. - -The client-side code would look like this (assuming @var{some-socket} -is bound to an open socket port): - -@vindex connection-end/client -@vindex kx/anon-dh -@vindex close-request/rdwr - -@example -;; Client-side. - -(let ((client (make-session connection-end/client))) - ;; Use the default settings. - (set-session-default-priority! client) - - ;; Don't use certificate-based authentication. - (set-session-certificate-type-priority! client '()) - - ;; Request the "anonymous Diffie-Hellman" key exchange method. - (set-session-kx-priority! client (list kx/anon-dh)) - - ;; Specify the underlying socket. - (set-session-transport-fd! client (fileno some-socket)) - - ;; Create anonymous credentials. - (set-session-credentials! client - (make-anonymous-client-credentials)) - - ;; Perform the TLS handshake with the server. - (handshake client) - - ;; Send data over the TLS record layer. - (write "hello, world!" (session-record-port client)) - - ;; Terminate the TLS session. - (bye client close-request/rdwr)) -@end example - -The corresponding server would look like this (again, assuming -@var{some-socket} is bound to a socket port): - -@vindex connection-end/server - -@example -;; Server-side. - -(let ((server (make-session connection-end/server))) - (set-session-default-priority! server) - (set-session-certificate-type-priority! server '()) - (set-session-kx-priority! server (list kx/anon-dh)) - - ;; Specify the underlying transport socket. - (set-session-transport-fd! server (fileno some-socket)) - - ;; Create anonymous credentials. - (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)) - - ;; Perform the TLS handshake with the client. - (handshake server) - - ;; Receive data over the TLS record layer. - (let ((message (read (session-record-port server)))) - (format #t "received the following message: ~a~%" - message) - - (bye server close-request/rdwr))) -@end example - -This is it! - - -@c ********************************************************************* -@node Guile Reference -@chapter Guile Reference - -This chapter lists the GnuTLS Scheme procedures exported by the -@code{(gnutls)} module (@pxref{The Guile module system,,, guile, The -GNU Guile Reference Manual}). - -@include core.c.texi - -@c Local Variables: -@c ispell-local-dictionary: "american" -@c End: - -@include cha-copying.texi - -@node Procedure Index -@unnumbered Procedure Index - -@printindex fn - -@node Concept Index -@unnumbered Concept Index - -@printindex cp - -@bye diff --git a/fuzz/README.md b/fuzz/README.md index 189d234ada..d945dd8385 100644 --- a/fuzz/README.md +++ b/fuzz/README.md @@ -38,7 +38,7 @@ export CC=clang export CXX=clang++ export CFLAGS="-O1 -g -fno-omit-frame-pointer -gline-tables-only -DFUZZING_BUILD_MODE_UNSAFE_FOR_PRODUCTION -fsanitize=undefined,integer,nullability,bool,alignment,null,enum,address,leak,nonnull-attribute -fno-sanitize-recover=all -fsanitize-recover=unsigned-integer-overflow -fsanitize-address-use-after-scope -fsanitize=fuzzer-no-link" export CXXFLAGS="$CFLAGS" -./configure --disable-guile --enable-fuzzer-target --enable-static --disable-doc --disable-gcc-warnings --disable-hardware-acceleration +./configure --enable-fuzzer-target --enable-static --disable-doc --disable-gcc-warnings --disable-hardware-acceleration make clean make cd fuzz @@ -55,7 +55,7 @@ export ASAN_SYMBOLIZER_PATH=/usr/bin/llvm-symbolizer Use the following commands on top dir: ``` -$ CC=afl-clang-fast ./configure --disable-doc --enable-fuzzer-target --disable-guile +$ CC=afl-clang-fast ./configure --disable-doc --enable-fuzzer-target $ make -j$(nproc) clean all $ cd fuzz $ ./run-afl.sh gnutls_base64_decoder_fuzzer @@ -66,7 +66,7 @@ $ ./run-afl.sh gnutls_base64_decoder_fuzzer Use the following commands on top dir: ``` -$ CC=afl-gcc ./configure --disable-doc --enable-fuzzer-target --disable-guile +$ CC=afl-gcc ./configure --disable-doc --enable-fuzzer-target $ make -j$(nproc) clean all $ cd fuzz $ ./run-afl.sh gnutls_base64_decoder_fuzzer diff --git a/guile/.dir-locals.el b/guile/.dir-locals.el deleted file mode 100644 index 54091ccaa5..0000000000 --- a/guile/.dir-locals.el +++ /dev/null @@ -1,12 +0,0 @@ -;; Per-directory local variables for GNU Emacs 23 and later. - -((nil - . ((fill-column . 78) - (tab-width . 8))) - (c-mode . ((c-file-style . "gnu"))) - (scheme-mode - . - ((indent-tabs-mode . nil) - (eval . (put 'with-child-process 'scheme-indent-function 1)))) - (texinfo-mode . ((indent-tabs-mode . nil) - (fill-column . 72)))) diff --git a/guile/.gitignore b/guile/.gitignore deleted file mode 100644 index ac6d07a897..0000000000 --- a/guile/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -*.x -*.i.c -smobs.h -enums.h -extra-smobs.h -extra-enums.h -pre-inst-guile diff --git a/guile/Makefile.am b/guile/Makefile.am deleted file mode 100644 index 1b9c03a93a..0000000000 --- a/guile/Makefile.am +++ /dev/null @@ -1,132 +0,0 @@ -# GnuTLS --- Guile bindings for GnuTLS. -# Copyright (C) 2007-2012, 2016, 2019, 2022 Free Software Foundation, Inc. -# -# 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 - -# First of all, built the DSO. We cannot compile the Scheme code until this -# is done. -SUBDIRS = src - - -EXTRA_DIST = .dir-locals.el - -guilesitesubdir = $(guilesitedir)/gnutls - -nodist_guilesite_DATA = modules/gnutls.scm -dist_guilesitesub_DATA = modules/gnutls/extra.scm - -documentation_modules = \ - modules/system/documentation/README \ - modules/system/documentation/c-snarf.scm \ - modules/system/documentation/output.scm - -helper_modules = \ - modules/gnutls/build/enums.scm \ - modules/gnutls/build/smobs.scm \ - modules/gnutls/build/utils.scm \ - modules/gnutls/build/tests.scm - -EXTRA_DIST += modules/gnutls.in $(helper_modules) $(documentation_modules) - -CLEANFILES = modules/gnutls.scm - -.in.scm: - $(AM_V_GEN)$(MKDIR_P) "`dirname "$@"`" ; cat "$^" | \ - $(SED) -e's|[@]maybe_guileextensiondir[@]|$(maybe_guileextensiondir)|g' \ - > "$@.tmp" - $(AM_V_at)mv "$@.tmp" "$@" - - -# -# Scheme code compilation. -# - -if HAVE_GUILD - -guilesiteccachesubdir = $(guilesiteccachedir)/gnutls -nodist_guilesiteccache_DATA = modules/gnutls.go -nodist_guilesiteccachesub_DATA = modules/gnutls/extra.go - -GOBJECTS = \ - $(nodist_guilesiteccache_DATA) \ - $(nodist_guilesiteccachesub_DATA) - -CLEANFILES += $(GOBJECTS) - -AM_V_GUILEC = $(AM_V_GUILEC_$(V)) -AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) -AM_V_GUILEC_0 = @echo " GUILEC " $@; - -if CROSS_COMPILING -CROSS_COMPILING_VARIABLE = GNUTLS_GUILE_CROSS_COMPILING=yes -else -CROSS_COMPILING_VARIABLE = -endif - -# Make sure 'gnutls.scm' is built first. -# Unset 'GUILE_LOAD_COMPILED_PATH' so we can be sure that any .go file that we -# load comes from the build directory. -# XXX: Use the C locale for when Guile lacks -# <https://git.sv.gnu.org/cgit/guile.git/commit/?h=stable-2.0&id=e2c6bf3866d1186c60bacfbd4fe5037087ee5e3f>. -%.go: %.scm modules/gnutls.scm - $(AM_V_GUILEC)$(MKDIR_P) "`dirname "$@"`" ; \ - $(AM_V_P) && out=1 || out=- ; \ - unset GUILE_LOAD_COMPILED_PATH ; LC_ALL=C \ - GUILE_AUTO_COMPILE=0 $(CROSS_COMPILING_VARIABLE) \ - GNUTLS_GUILE_EXTENSION_DIR="$(abs_top_builddir)/guile/src" \ - $(GUILD) compile --target="$(host)" \ - -L "$(top_builddir)/guile/modules" \ - -L "$(top_srcdir)/guile/modules" \ - -Wformat -Wunbound-variable -Warity-mismatch \ - -o "$@" "$<" >&$$out - -SUFFIXES = .go - -endif HAVE_GUILD - - -# -# Tests. -# - -TESTS = \ - tests/anonymous-auth.scm \ - tests/session-record-port.scm \ - tests/pkcs-import-export.scm \ - tests/errors.scm \ - tests/x509-certificates.scm \ - tests/x509-auth.scm \ - tests/reauth.scm \ - tests/premature-termination.scm \ - tests/priorities.scm - -if ENABLE_SRP -TESTS += \ - tests/srp-base64.scm -endif - -TESTS_ENVIRONMENT = \ - GUILE_AUTO_COMPILE=0 \ - GUILE_WARN_DEPRECATED=detailed - -LOG_COMPILER = $(top_builddir)/guile/pre-inst-guile -L $(srcdir)/tests - - -EXTRA_DIST += \ - $(TESTS) \ - tests/rsa-parameters.pem \ - tests/dh-parameters.pem \ - tests/x509-certificate.pem \ - tests/x509-key.pem diff --git a/guile/modules/gnutls.in b/guile/modules/gnutls.in deleted file mode 100644 index 67f0a29a02..0000000000 --- a/guile/modules/gnutls.in +++ /dev/null @@ -1,616 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012, 2014, 2015, 2016, 2019, 2021-2022 Free Software -;;; Foundation, Inc. -;;; -;;; 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@gnu.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 reauthenticate - 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! - set-session-server-name! - - ;; 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-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 - - ;; priorities - set-session-priorities! - set-session-default-priority! - - ;; DH - set-session-dh-prime-bits! - make-dh-parameters dh-parameters? - pkcs3-import-dh-parameters pkcs3-export-dh-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 - x509-certificate-fingerprint import-x509-private-key - pkcs8-import-x509-private-key - - ;; record layer - record-send record-receive! - session-record-port - set-session-record-port-close! - - ;; 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 connection-flag->string - alert-level->string - alert-description->string handshake-description->string - certificate-status->string certificate-request->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 server-name-type->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 - digest/sha256 - compression-method/null - compression-method/deflate - compression-method/lzo - connection-end/server - connection-end/client - connection-flag/datagram - connection-flag/nonblock - connection-flag/no-extensions - connection-flag/no-replay-protection - connection-flag/no-signal - connection-flag/allow-id-change - connection-flag/enable-false-start - connection-flag/force-client-cert - connection-flag/no-tickets - connection-flag/key-share-top - connection-flag/key-share-top2 - connection-flag/key-share-top3 - connection-flag/post-handshake-auth - connection-flag/no-auto-rekey - connection-flag/safe-padding-check - connection-flag/enable-early-start - connection-flag/enable-rawpk - connection-flag/auto-reauth - connection-flag/enable-early-data - 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-psk-identity - 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-status/not-activated - certificate-status/expired - certificate-status/signature-failure - certificate-status/revocation-data-superseded - certificate-status/unexpected-owner - certificate-status/revocation-data-issued-in-future - certificate-status/signer-constraints-failed - certificate-status/mismatch - certificate-status/purpose-mismatch - certificate-status/missing-ocsp-status - certificate-status/invalid-ocsp-status - certificate-status/unknown-crit-extensions - 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 - server-name-type/dns - - ;; FIXME: Automate this: - ;; grep '^#define GNUTLS_E_' ../../lib/includes/gnutls/gnutls.h.in | \ - ;; sed -r -e 's|^#define GNUTLS_E_([^ ]+).*$|error/\1|' | tr A-Z_ a-z- - error/success - error/unsupported-version-packet - error/tls-packet-decoding-error - 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/decryption-failed - error/memory-error - error/decompression-failed - error/compression-failed - error/again - error/expired - error/db-error - error/srp-pwd-error - error/keyfile-error - error/insufficient-credentials - error/insuficient-credentials - error/insufficient-cred - error/insuficient-cred - error/hash-failed - error/base64-decoding-error - 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/too-many-handshake-packets - error/received-disallowed-name - error/certificate-required - error/no-temporary-rsa-params - 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/keyfile-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-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/unknown-algorithm - error/unsupported-signature-algorithm - error/safe-renegotiation-failed - error/unsafe-renegotiation-denied - error/unknown-srp-username - error/premature-termination - error/malformed-cidr - 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/base64-unexpected-header-error - error/openpgp-subkey-error - error/crypto-already-registered - error/already-registered - error/handshake-too-large - error/cryptodev-ioctl-error - error/cryptodev-device-error - error/channel-binding-not-available - error/bad-cookie - error/openpgp-preferred-key-error - error/incompat-dsa-key-with-tls-protocol - error/insufficient-security - error/heartbeat-pong-received - error/heartbeat-ping-received - error/unrecognized-name - error/pkcs11-error - error/pkcs11-load-error - error/parsing-error - error/pkcs11-pin-error - error/pkcs11-slot-error - error/locking-error - error/pkcs11-attribute-error - error/pkcs11-device-error - error/pkcs11-data-error - error/pkcs11-unsupported-feature-error - error/pkcs11-key-error - error/pkcs11-pin-expired - error/pkcs11-pin-locked - error/pkcs11-session-error - error/pkcs11-signature-error - error/pkcs11-token-error - error/pkcs11-user-error - error/crypto-init-failed - error/timedout - error/user-error - error/ecc-no-supported-curves - error/ecc-unsupported-curve - error/pkcs11-requested-object-not-availble - error/certificate-list-unsorted - error/illegal-parameter - error/no-priorities-were-set - error/x509-unsupported-extension - error/session-eof - error/tpm-error - error/tpm-key-password-error - error/tpm-srk-password-error - error/tpm-session-error - error/tpm-key-not-found - error/tpm-uninitialized - error/tpm-no-lib - error/no-certificate-status - error/ocsp-response-error - error/random-device-error - error/auth-error - error/no-application-protocol - error/sockets-init-error - error/key-import-failed - error/inappropriate-fallback - error/certificate-verification-error - error/privkey-verification-error - error/unexpected-extensions-length - error/asn1-embedded-null-in-string - error/self-test-error - error/no-self-test - error/lib-in-error-state - error/pk-generation-error - error/idna-error - error/need-fallback - error/session-user-id-changed - error/handshake-during-false-start - error/unavailable-during-handshake - error/pk-invalid-pubkey - error/pk-invalid-privkey - error/not-yet-activated - error/invalid-utf8-string - error/no-embedded-data - error/invalid-utf8-email - error/invalid-password-string - error/certificate-time-error - error/record-overflow - error/asn1-time-error - error/incompatible-sig-with-key - error/pk-invalid-pubkey-params - error/pk-no-validation-params - error/ocsp-mismatch-with-certs - error/no-common-key-share - error/reauth-request - error/too-many-matches - error/crl-verification-error - error/missing-extension - error/db-entry-exists - error/early-data-rejected - error/unimplemented-feature - error/int-ret-0 - error/int-check-again - error/application-error-max - error/application-error-min - - fatal-error? - - ;; OpenPGP keys (formerly in GnuTLS-extra) - openpgp-certificate? openpgp-private-key? - import-openpgp-certificate import-openpgp-private-key - openpgp-certificate-id openpgp-certificate-id! - openpgp-certificate-fingerprint openpgp-certificate-fingerprint! - openpgp-certificate-name openpgp-certificate-names - openpgp-certificate-algorithm openpgp-certificate-version - openpgp-certificate-usage - - ;; OpenPGP keyrings - openpgp-keyring? import-openpgp-keyring - openpgp-keyring-contains-key-id? - - ;; certificate credentials - set-certificate-credentials-openpgp-keys! - - ;; enum->string functions - openpgp-certificate-format->string - - ;; enum values - openpgp-certificate-format/raw - openpgp-certificate-format/base64)) - -(eval-when (expand load eval) - (define %libdir - (or (getenv "GNUTLS_GUILE_EXTENSION_DIR") - - ;; The .scm file is supposed to be architecture-independent. Thus, - ;; save 'extensiondir' only if it's different from what Guile expects. - @maybe_guileextensiondir@)) - - (unless (getenv "GNUTLS_GUILE_CROSS_COMPILING") - (load-extension (if %libdir - (string-append %libdir "/guile-gnutls-v-2") - "guile-gnutls-v-2") - "scm_init_gnutls"))) - -(define-syntax define-deprecated - (lambda (s) - "Define a deprecated variable or procedure, along these lines: - - (define-deprecated variable alias) - -This defines 'variable' as an alias for 'alias', and emits a warning when -'variable' is used." - (syntax-case s () - ((_ variable) - (with-syntax ((alias (datum->syntax - #'variable - (symbol-append - '% (syntax->datum #'variable))))) - #'(define-deprecated variable alias))) - ((_ variable alias) - (identifier? #'variable) - #`(define-syntax variable - (lambda (s) - (issue-deprecation-warning - (format #f "GnuTLS variable '~a' is deprecated" - (syntax->datum #'variable))) - (syntax-case s () - ((_ args (... ...)) - #'(alias args (... ...))) - (id - (identifier? #'id) - #'alias)))))))) - - -;; 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) - -;; Deprecated OpenPGP bindings. -(define-deprecated certificate-type/openpgp) -(define-deprecated error/openpgp-getkey-failed) -(define-deprecated error/openpgp-uid-revoked) -(define-deprecated error/openpgp-fingerprint-unsupported) -(define-deprecated error/openpgp-keyring-error) -(define-deprecated error/openpgp-subkey-error) -(define-deprecated error/openpgp-preferred-key-error) -(define-deprecated openpgp-private-key?) -(define-deprecated import-openpgp-certificate) -(define-deprecated import-openpgp-private-key) -(define-deprecated openpgp-certificate-id) -(define-deprecated openpgp-certificate-id!) -(define-deprecated openpgp-certificate-fingerprint) -(define-deprecated openpgp-certificate-fingerprint!) -(define-deprecated openpgp-certificate-name) -(define-deprecated openpgp-certificate-names) -(define-deprecated openpgp-certificate-algorithm) -(define-deprecated openpgp-certificate-version) -(define-deprecated openpgp-certificate-usage) -(define-deprecated openpgp-keyring?) -(define-deprecated import-openpgp-keyring) -(define-deprecated openpgp-keyring-contains-key-id?) -(define-deprecated set-certificate-credentials-openpgp-keys!) - -;; XXX: The following bindings should be marked as deprecated as well, but due -;; to the way binding names are constructed for enums and smobs, it's -;; complicated. Oh well. -;; -;; (define-deprecated openpgp-certificate?) -;; (define-deprecated openpgp-certificate-format->string) -;; (define-deprecated openpgp-certificate-format/raw) -;; (define-deprecated openpgp-certificate-format/base64) - -;;; 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 deleted file mode 100644 index 4bfbb45549..0000000000 --- a/guile/modules/gnutls/build/enums.scm +++ /dev/null @@ -1,730 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012, 2014, 2019 Free Software Foundation, Inc. -;;; -;;; 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)) - -;;; -;;; 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 sha256) - #f - "GNUTLS_DIG_")) - -(define %compression-method-enum - (make-enum-type 'compression-method "gnutls_compression_method_t" - '(null deflate) - "gnutls_compression_get_name" - "GNUTLS_COMP_")) - -(define %connection-end-enum - (make-enum-type 'connection-end "gnutls_connection_end_t" - '(server client) - #f - "GNUTLS_")) - -(define %connection-flag-enum - (make-enum-type 'connection-flag "gnutls_init_flags_t" - '(datagram - nonblock - no-extensions - no-replay-protection - no-signal - allow-id-change - enable-false-start - force-client-cert - no-tickets - key-share-top - key-share-top2 - key-share-top3 - post-handshake-auth - no-auto-rekey - safe-padding-check - enable-early-start - enable-rawpk - auto-reauth - enable-early-data) - #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-psk-identity) - #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 not-activated expired - signature-failure revocation-data-superseded - unexpected-owner revocation-data-issued-in-future - signer-constraints-failure mismatch purpose-mismatch - missing-ocsp-status invalid-ocsp-status - unknown-crit-extensions) - #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" - '( -;; FIXME: Automate this: -;; grep '^#define GNUTLS_E_' ../../../lib/includes/gnutls/gnutls.h.in \ -;; | sed -r -e 's/^#define GNUTLS_E_([^ ]+).*$/\1/' | tr A-Z_ a-z- -success -unsupported-version-packet -tls-packet-decoding-error -unexpected-packet-length -invalid-session -fatal-alert-received -unexpected-packet -warning-alert-received -error-in-finished-packet -unexpected-handshake-packet -decryption-failed -memory-error -decompression-failed -compression-failed -again -expired -db-error -srp-pwd-error -keyfile-error -insufficient-credentials -insuficient-credentials -insufficient-cred -insuficient-cred -hash-failed -base64-decoding-error -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 -too-many-handshake-packets -received-disallowed-name -certificate-required -no-temporary-rsa-params -no-compression-algorithms -no-cipher-suites -openpgp-getkey-failed -pk-sig-verify-failed -illegal-srp-username -srp-pwd-parsing-error -keyfile-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-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 -unknown-algorithm -unsupported-signature-algorithm -safe-renegotiation-failed -unsafe-renegotiation-denied -unknown-srp-username -premature-termination -malformed-cidr -base64-encoding-error -incompatible-gcrypt-library -incompatible-crypto-library -incompatible-libtasn1-library -openpgp-keyring-error -x509-unsupported-oid -random-failed -base64-unexpected-header-error -openpgp-subkey-error -crypto-already-registered -already-registered -handshake-too-large -cryptodev-ioctl-error -cryptodev-device-error -channel-binding-not-available -bad-cookie -openpgp-preferred-key-error -incompat-dsa-key-with-tls-protocol -insufficient-security -heartbeat-pong-received -heartbeat-ping-received -unrecognized-name -pkcs11-error -pkcs11-load-error -parsing-error -pkcs11-pin-error -pkcs11-slot-error -locking-error -pkcs11-attribute-error -pkcs11-device-error -pkcs11-data-error -pkcs11-unsupported-feature-error -pkcs11-key-error -pkcs11-pin-expired -pkcs11-pin-locked -pkcs11-session-error -pkcs11-signature-error -pkcs11-token-error -pkcs11-user-error -crypto-init-failed -timedout -user-error -ecc-no-supported-curves -ecc-unsupported-curve -pkcs11-requested-object-not-availble -certificate-list-unsorted -illegal-parameter -no-priorities-were-set -x509-unsupported-extension -session-eof -tpm-error -tpm-key-password-error -tpm-srk-password-error -tpm-session-error -tpm-key-not-found -tpm-uninitialized -tpm-no-lib -no-certificate-status -ocsp-response-error -random-device-error -auth-error -no-application-protocol -sockets-init-error -key-import-failed -inappropriate-fallback -certificate-verification-error -privkey-verification-error -unexpected-extensions-length -asn1-embedded-null-in-string -self-test-error -no-self-test -lib-in-error-state -pk-generation-error -idna-error -need-fallback -session-user-id-changed -handshake-during-false-start -unavailable-during-handshake -pk-invalid-pubkey -pk-invalid-privkey -not-yet-activated -invalid-utf8-string -no-embedded-data -invalid-utf8-email -invalid-password-string -certificate-time-error -record-overflow -asn1-time-error -incompatible-sig-with-key -pk-invalid-pubkey-params -pk-no-validation-params -ocsp-mismatch-with-certs -no-common-key-share -reauth-request -too-many-matches -crl-verification-error -missing-extension -db-entry-exists -early-data-rejected -unimplemented-feature -int-ret-0 -int-check-again -application-error-max -application-error-min -) - "gnutls_strerror" - "GNUTLS_E_")) - - -(define %openpgp-certificate-format-enum - (make-enum-type 'openpgp-certificate-format "gnutls_openpgp_crt_fmt_t" - '(raw base64) - #f - "GNUTLS_OPENPGP_FMT_")) - -(define %server-name-type-enum - (make-enum-type 'server-name-type "gnutls_server_name_type_t" - '(dns) - #f - "GNUTLS_NAME_")) - -(define %gnutls-enums - ;; All enums. - (list %cipher-enum %kx-enum %params-enum %credentials-enum %mac-enum - %digest-enum %compression-method-enum - %connection-end-enum %connection-flag-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 %server-name-type-enum - %psk-key-format-enum %key-usage-enum %certificate-verify-enum - %error-enum - - %openpgp-certificate-format-enum)) - -;;; Local Variables: -;;; mode: scheme -;;; coding: latin-1 -;;; End: - -;;; arch-tag: 9e3eb6bb-61a5-4e85-861f-1914ab9677b0 diff --git a/guile/modules/gnutls/build/smobs.scm b/guile/modules/gnutls/build/smobs.scm deleted file mode 100644 index 96129223b3..0000000000 --- a/guile/modules/gnutls/build/smobs.scm +++ /dev/null @@ -1,231 +0,0 @@ -;;; Help produce Guile wrappers for GnuTLS types. -;;; -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012, 2014 Free Software Foundation, Inc. -;;; -;;; 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)) - - -;;; -;;; 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 %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-certificate-smob - (make-smob-type "gnutls_openpgp_crt_t" 'openpgp-certificate - "gnutls_openpgp_crt_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 - %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 - - %openpgp-certificate-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/tests.scm b/guile/modules/gnutls/build/tests.scm deleted file mode 100644 index 7dd79919b1..0000000000 --- a/guile/modules/gnutls/build/tests.scm +++ /dev/null @@ -1,93 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2011-2012, 2016, 2021-2022 Free Software Foundation, Inc. -;;; -;;; 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@gnu.org>. - -(define-module (gnutls build tests) - #:export (run-test - with-child-process)) - -(define (run-test thunk) - "Call `(exit (THUNK))'. If THUNK raises an exception, then call `(exit 1)' and -display a backtrace. Otherwise, return THUNK's return value." - (exit - (catch #t - thunk - (lambda (key . args) - ;; Never reached. - (exit 1)) - (lambda (key . args) - (dynamic-wind ;; to be on the safe side - (lambda () #t) - (lambda () - (format (current-error-port) - "~%throw to `~a' with args ~s [PID ~a]~%" - key args (getpid)) - (display-backtrace (make-stack #t) (current-output-port))) - (lambda () - (exit 1))) - (exit 1))))) - -(define (call-with-child-process child parent) - "Run thunk CHILD in a child process and invoke PARENT from the parent -process, passing it the PID of the child process. Make sure the child -process exits upon failure." - (let ((pid (primitive-fork))) - (if (zero? pid) - (dynamic-wind - (const #t) - (lambda () - (primitive-exit (if (child) 0 1))) - (lambda () - (primitive-exit 2))) - (parent pid)))) - -(use-modules (rnrs io ports) - (rnrs bytevectors) - (ice-9 match)) - -(define-syntax-rule (define-replacement (name args ...) body ...) - ;; Define a compatibility replacement for NAME, if needed. - (define-public name - (if (module-defined? the-scm-module 'name) - (module-ref the-scm-module 'name) - (lambda (args ...) - body ...)))) - -;; 'uniform-vector-read!' and 'uniform-vector-write' are deprecated in 2.0 -;; and absent in 2.2. -;; TODO: Switch to the R6RS bytevector and I/O interface. - -(define-replacement (uniform-vector-read! buf port) - (match (get-bytevector-n! port buf - 0 (bytevector-length buf)) - ((? eof-object?) 0) - ((? integer? n) n))) - -(define-replacement (uniform-vector-write buf port) - (put-bytevector port buf)) - -(define-syntax-rule (with-child-process pid parent child) - "Fork and evaluate expression PARENT in the current process, with PID bound -to the PID of its child process; the child process evaluated CHILD." - (call-with-child-process - (lambda () child) - (lambda (pid) parent))) - -;;; Local Variables: -;;; eval: (put 'define-replacement 'scheme-indent-function 1) -;;; End: diff --git a/guile/modules/gnutls/build/utils.scm b/guile/modules/gnutls/build/utils.scm deleted file mode 100644 index b547aa8cd7..0000000000 --- a/guile/modules/gnutls/build/utils.scm +++ /dev/null @@ -1,46 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012 Free Software Foundation, Inc. -;;; -;;; 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 deleted file mode 100644 index 4191c5a33a..0000000000 --- a/guile/modules/gnutls/extra.scm +++ /dev/null @@ -1,83 +0,0 @@ -;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA. -;;; Copyright (C) 2007-2012 Free Software Foundation, Inc. -;;; -;;; 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 3 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@gnu.org> - -(define-module (gnutls extra) - - :use-module (gnutls) - - :re-export (;; OpenPGP keys - openpgp-certificate? openpgp-private-key? - import-openpgp-certificate import-openpgp-private-key - openpgp-certificate-id openpgp-certificate-id! - openpgp-certificate-fingerprint openpgp-certificate-fingerprint! - openpgp-certificate-name openpgp-certificate-names - openpgp-certificate-algorithm openpgp-certificate-version - openpgp-certificate-usage - - ;; OpenPGP keyrings - openpgp-keyring? import-openpgp-keyring - openpgp-keyring-contains-key-id? - - ;; certificate credentials - set-certificate-credentials-openpgp-keys! - - ;; enum->string functions - openpgp-certificate-format->string - - ;; enum values - openpgp-certificate-format/raw - openpgp-certificate-format/base64)) - - - -;;; -;;; This module will be removed in a future version. -;;; - -(issue-deprecation-warning - "The (gnutls extra) module is deprecated; use (gnutls) instead") - - -;;; -;;; Aliases kept for backward compatibility with GnuTLS 2.0.x. These aliases -;;; are deprecated in 2.2 and should be removed in 2.4.x. -;;; - -(define-public openpgp-public-key? openpgp-certificate?) -(define-public import-openpgp-public-key import-openpgp-certificate) -(define-public openpgp-public-key-id openpgp-certificate-id) -(define-public openpgp-public-key-id! openpgp-certificate-id!) -(define-public openpgp-public-key-fingerprint openpgp-certificate-fingerprint) -(define-public openpgp-public-key-fingerprint! openpgp-certificate-fingerprint!) -(define-public openpgp-public-key-name openpgp-certificate-name) -(define-public openpgp-public-key-names openpgp-certificate-names) -(define-public openpgp-public-key-algorithm openpgp-certificate-algorithm) -(define-public openpgp-public-key-version openpgp-certificate-version) -(define-public openpgp-public-key-usage openpgp-certificate-usage) - -(define-public openpgp-key-format->string openpgp-certificate-format->string) -(define-public openpgp-key-format/raw openpgp-certificate-format/raw) -(define-public openpgp-key-format/base64 openpgp-certificate-format/base64) - - -;;; Local Variables: -;;; mode: scheme -;;; coding: latin-1 -;;; End: diff --git a/guile/modules/system/documentation/README b/guile/modules/system/documentation/README deleted file mode 100644 index d8dba12983..0000000000 --- a/guile/modules/system/documentation/README +++ /dev/null @@ -1,15 +0,0 @@ -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: - - https://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 deleted file mode 100644 index 5e54da30a7..0000000000 --- a/guile/modules/system/documentation/c-snarf.scm +++ /dev/null @@ -1,210 +0,0 @@ -;;; c-snarf.scm -- Parsing documentation "snarffed" from C files. -;;; -;;; Copyright 2006-2012 Free Software Foundation, Inc. -;;; -;;; -;;; 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 3 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)) - -;;; 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 cpp-flags) - (let ((pipe (apply open-pipe* OPEN_READ - (cons cpp (append cpp-flags (list file)))))) - (parse-snarfing pipe))) - - -;;; -;;; Parsing magic-snarffed CPP output. -;;; - -(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))))) - - (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 be a complete \"^^ { ... ^^ }\" sequence." - (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." - (define start-marker "^^ {") - (define end-marker "^^ }") - - (define (read-snarf-lines start) - ;; Read the snarf lines that follow START until and end marker is found. - (let loop ((line start) - (result '())) - (cond ((eof-object? line) - ;; EOF in the middle of a "^^ { ... ^^ }" sequence; shouldn't - ;; happen. - line) - ((string-contains line end-marker) - => - (lambda (end) - (let ((result (cons (string-take line (+ 3 end)) - result))) - (string-concatenate-reverse result)))) - ((string-prefix? "#" line) - ;; Presumably a "# LINENUM" directive; skip it. - (loop (read-line port) result)) - (else - (loop (read-line port) - (cons line result)))))) - - (let loop ((line (read-line port)) - (result '())) - (cond ((eof-object? line) - result) - ((string-contains line start-marker) - => - (lambda (start) - (let ((line - (read-snarf-lines (string-drop line start)))) - (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 deleted file mode 100644 index d60fe44bd8..0000000000 --- a/guile/modules/system/documentation/output.scm +++ /dev/null @@ -1,176 +0,0 @@ -;;; output.scm -- Output documentation "snarffed" from C files in Texi/GDF. -;;; -;;; Copyright 2006-2012 Free Software Foundation, Inc. -;;; -;;; -;;; 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 3 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 c-file cpp 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 deleted file mode 100644 index 9dd409dbbc..0000000000 --- a/guile/pre-inst-guile.in +++ /dev/null @@ -1,32 +0,0 @@ -#!/bin/sh - -# Copyright (C) 2007-2012 Free Software Foundation, Inc. -# -# 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 3 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" -GUILE_LOAD_PATH="@abs_top_builddir@/guile/modules:$GUILE_LOAD_PATH" -export GUILE_LOAD_PATH - -GNUTLS_GUILE_EXTENSION_DIR="@abs_top_builddir@/guile/src" -export GNUTLS_GUILE_EXTENSION_DIR - -exec @abs_top_builddir@/libtool --mode=execute \ - -dlopen "@abs_top_builddir@/guile/src/guile-gnutls-v-2.la" \ - @GUILE@ "$@" diff --git a/guile/src/Makefile.am b/guile/src/Makefile.am deleted file mode 100644 index 78f0143b27..0000000000 --- a/guile/src/Makefile.am +++ /dev/null @@ -1,124 +0,0 @@ -# GnuTLS --- Guile bindings for GnuTLS. -# Copyright (C) 2007-2014, 2016 Free Software Foundation, Inc. -# -# 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_AUTO_COMPILE=0 $(GUILE) -L $(top_srcdir)/guile/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 - -# Files generated by the (gnutls build ...) modules. -GENERATED_BINDINGS = \ - enum-map.i.c smob-types.i.c enums.h smobs.h - -BUILT_SOURCES = \ - $(GENERATED_BINDINGS) \ - core.x errors.x - -CLEANFILES = $(BUILT_SOURCES) - -guileextension_LTLIBRARIES = guile-gnutls-v-2.la - -# Use '-module' to build a "dlopenable module", in Libtool terms. -# Use '-undefined' to placate Libtool on Windows; see -# <https://lists.gnutls.org/pipermail/gnutls-devel/2014-December/007294.html>. -guile_gnutls_v_2_la_LDFLAGS = -module -no-undefined - -# Linking against GnuTLS. -GNUTLS_CORE_LIBS = $(top_builddir)/lib/libgnutls.la - -# Linking against Gnulib modules. -GNULIB_LIBS = $(top_builddir)/gl/libgnu.la -GNULIB_CFLAGS = -I$(top_builddir)/gl -I$(top_srcdir)/gl - - -guile_gnutls_v_2_la_SOURCES = core.c errors.c utils.c -guile_gnutls_v_2_la_CFLAGS = \ - $(AM_CFLAGS) $(GNULIB_CFLAGS) $(GUILE_CFLAGS) -guile_gnutls_v_2_la_LIBADD = \ - $(GNUTLS_CORE_LIBS) $(GNULIB_LIBS) \ - $(GUILE_LDFLAGS) - -AM_CPPFLAGS = \ - -I$(top_srcdir)/lib/includes \ - -I$(top_builddir)/lib/includes \ - -I$(top_srcdir)/extra/includes \ - -I$(top_builddir) \ - -I$(builddir) - -if HAVE_GCC - -AM_CFLAGS = -Wall -Wextra - -# Generated `.x' files and Guile's `scm_c_define_gsubr ()' require -# `-Wno-strict-prototypes'. This trick makes sure `-Wno-s-p' appears -# after `-Ws-p'. -AM_CFLAGS += -Wno-strict-prototypes - -# Functions generated from 'SCM_SMOB_PRINT' & co. typically have -# unused parameters. -AM_CFLAGS += -Wno-unused-parameter - -# The `-fgnu89-inline' option appeared in GCC 4.1.3. -if HAVE_GCC_GNU89_INLINE_OPTION - -# Guile and GMP currently rely on GNU inline semantics, not C99 inline. -AM_CFLAGS += -fgnu89-inline - -endif HAVE_GCC_GNU89_INLINE_OPTION - -endif HAVE_GCC - - -enums.h: $(srcdir)/make-enum-header.scm - $(AM_V_GEN)$(GUILE_FOR_BUILD) "$^" > "$@.tmp" - $(AM_V_at)mv "$@.tmp" "$@" - -enum-map.i.c: $(srcdir)/make-enum-map.scm - $(AM_V_GEN)$(GUILE_FOR_BUILD) "$^" > "$@.tmp" - $(AM_V_at)mv "$@.tmp" "$@" - -smobs.h: $(srcdir)/make-smob-header.scm - $(AM_V_GEN)$(GUILE_FOR_BUILD) "$^" > "$@.tmp" - $(AM_V_at)mv "$@.tmp" "$@" - -smob-types.i.c: $(srcdir)/make-smob-types.scm - $(AM_V_GEN)$(GUILE_FOR_BUILD) "$^" > "$@.tmp" - $(AM_V_at)mv "$@.tmp" "$@" - - -# C file snarfing. - -# `$(GUILE_CFLAGS)' may contain a series of `-I' switches so it must be -# included here, even though we'd really want `$(GUILE_CPPFLAGS)'. -snarfcppopts = $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ - $(CFLAGS) $(guile_gnutls_v_2_la_CFLAGS) - -# Note: we cannot use the portable ".c.x" form, since that leads -# prerequisites to be ignored: -# <https://lists.gnutls.org/pipermail/gnutls-devel/2013-September/006453.html>. -%.x: %.c $(GENERATED_BINDINGS) - $(AM_V_GEN)$(guile_snarf) -o $@ $< $(snarfcppopts) - -# Target used by doc/Makefile, to create all built sources necessary -# for generating the manual. - -.PHONY: built-sources -built-sources: $(BUILT_SOURCES) diff --git a/guile/src/core.c b/guile/src/core.c deleted file mode 100644 index 6a35caecdf..0000000000 --- a/guile/src/core.c +++ /dev/null @@ -1,3531 +0,0 @@ -/* GnuTLS --- Guile bindings for GnuTLS. - Copyright (C) 2007-2014, 2016, 2019, 2020, 2021 Free Software Foundation, Inc. - - 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@gnu.org>. */ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <stdio.h> -#include <stdint.h> -#include <string.h> -#include <gnutls/gnutls.h> -#include <gnutls/openpgp.h> -#include <libguile.h> - -#include <alloca.h> -#include <assert.h> - -#include "enums.h" -#include "smobs.h" -#include "errors.h" -#include "utils.h" - - -#ifndef HAVE_SCM_GC_MALLOC_POINTERLESS -# define scm_gc_malloc_pointerless scm_gc_malloc -#endif - -/* Maximum size allowed for 'alloca'. */ -#define ALLOCA_MAX_SIZE 1024U - -/* Allocate SIZE bytes, either on the C stack or on the GC-managed heap. */ -#define FAST_ALLOC(size) \ - (((size) <= ALLOCA_MAX_SIZE) \ - ? alloca (size) \ - : scm_gc_malloc_pointerless ((size), "gnutls-alloc")) - -/* Maximum size, in bytes, of the hash data returned by a digest algorithm. */ -#define MAX_HASH_SIZE 64 - -/* 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)) - - -/* Weak-key hash table. */ -static SCM weak_refs; - -/* Register a weak reference from @FROM to @TO, such that the lifetime of TO is - greater than or equal to that of FROM. TO is added to the list of weak - references of FROM. */ -static void -register_weak_reference (SCM from, SCM to) -{ - SCM refs = scm_cons (to, scm_hashq_ref (weak_refs, from, SCM_EOL)); - scm_hashq_set_x (weak_refs, from, refs); -} - - - - -/* 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, 1, - (SCM end, SCM flags), - "Return a new session for connection end @var{end}, either " - "@code{connection-end/server} or @code{connection-end/client}. " - "The optional @var{flags} arguments are @code{connection-flag} " - "values such as @code{connection-flag/auto-reauth}.") -#define FUNC_NAME s_scm_gnutls_make_session -{ - int err, i; - gnutls_session_t c_session; - gnutls_connection_end_t c_end; - gnutls_init_flags_t c_flags = 0; - SCM session_data; - - c_end = scm_to_gnutls_connection_end (end, 1, FUNC_NAME); - - session_data = SCM_GNUTLS_MAKE_SESSION_DATA (); - for (i = 2; scm_is_pair (flags); flags = scm_cdr (flags), i++) - c_flags |= scm_to_gnutls_connection_flag (scm_car (flags), i, FUNC_NAME); - - err = gnutls_init (&c_session, c_end | c_flags); - - 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_reauthenticate, "reauthenticate", 1, 0, 0, - (SCM session), "Perform a re-authentication step for @var{session}.") -#define FUNC_NAME s_scm_gnutls_reauthenticate -{ - int err; - gnutls_session_t c_session; - - c_session = scm_to_gnutls_session (session, 1, FUNC_NAME); - - /* FIXME: Allow flags as an argument. */ - err = gnutls_reauth (c_session, 0); - 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_request_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. */ - -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_session_priorities_x, - "set-session-priorities!", 2, 0, 0, - (SCM session, SCM priorities), - "Have @var{session} use the given @var{priorities} for " - "the ciphers, key exchange methods, MACs and compression " - "methods. @var{priorities} must be a string (@pxref{" - "Priority Strings,,, gnutls, GnuTLS@comma{} Transport Layer " - "Security Library for the GNU system}). When @var{priorities} " - "cannot be parsed, an @code{error/invalid-request} error " - "is raised, with an extra argument indication the position " - "of the error.\n") -#define FUNC_NAME s_scm_gnutls_set_session_priorities_x -{ - int err; - char *c_priorities; - const char *err_pos; - gnutls_session_t c_session; - size_t pos; - - c_session = scm_to_gnutls_session (session, 1, FUNC_NAME); - c_priorities = scm_to_locale_string (priorities); /* XXX: to_latin1_string */ - - err = gnutls_priority_set_direct (c_session, c_priorities, &err_pos); - if (err == GNUTLS_E_INVALID_REQUEST) - pos = err_pos - c_priorities; - - free (c_priorities); - - switch (err) - { - case GNUTLS_E_SUCCESS: - break; - case GNUTLS_E_INVALID_REQUEST: - { - scm_gnutls_error_with_args (err, FUNC_NAME, - scm_list_1 (scm_from_size_t (pos))); - break; - } - default: - scm_gnutls_error (err, FUNC_NAME); - } - - 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); - } -#ifdef ENABLE_SRP - 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); - } -#endif - 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); - else - register_weak_reference (session, cred); - - return SCM_UNSPECIFIED; -} - -#undef FUNC_NAME - -SCM_DEFINE (scm_gnutls_set_session_server_name_x, "set-session-server-name!", - 3, 0, 0, - (SCM session, SCM type, SCM name), - "For a client, this procedure provides a way to inform " - "the server that it is known under @var{name}, @i{via} the " - "@code{SERVER NAME} TLS extension. @var{type} must be " - "a @code{server-name-type} value, @var{server-name-type/dns} " - "for DNS names.") -#define FUNC_NAME s_scm_gnutls_set_session_server_name_x -{ - int err; - gnutls_session_t c_session; - gnutls_server_name_type_t c_type; - char *c_name; - - c_session = scm_to_gnutls_session (session, 1, FUNC_NAME); - c_type = scm_to_gnutls_server_name_type (type, 2, FUNC_NAME); - SCM_VALIDATE_STRING (3, name); - - c_name = scm_to_locale_string (name); - - err = gnutls_server_name_set (c_session, c_type, c_name, - strlen (c_name)); - free (c_name); - - if (EXPECT_FALSE (err != GNUTLS_E_SUCCESS)) - 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 - - -/* Whether we're using Guile < 2.2. */ -#define USING_GUILE_BEFORE_2_2 \ - (SCM_MAJOR_VERSION < 2 \ - || (SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION == 0)) - -/* The session record port type. Guile 2.1.4 introduced a brand new port API, - so we have a separate implementation for these newer versions. */ -#if USING_GUILE_BEFORE_2_2 -static scm_t_bits session_record_port_type; - -/* Hint for the `scm_gc_' functions. */ -static const char session_record_port_gc_hint[] = - "gnutls-session-record-port"; -#else -static scm_t_port_type *session_record_port_type; -#endif - -/* Return the session associated with PORT. */ -#define SCM_GNUTLS_SESSION_RECORD_PORT_SESSION(_port) \ - (SCM_CAR (SCM_PACK (SCM_STREAM (_port)))) - -/* Return the 'close' procedure associated with PORT or #f if there is - none. */ -#define SCM_GNUTLS_SESSION_RECORD_PORT_CLOSE_PROCEDURE(_port) \ - (SCM_CDR (SCM_PACK (SCM_STREAM (_port)))) - -/* Set PROC as the 'close' procedure of PORT. */ -#define SCM_GNUTLS_SET_SESSION_RECORD_PORT_CLOSE(_port, _proc) \ - (SCM_SETCDR (SCM_PACK (SCM_STREAM (_port)), (_proc))) - -#if !USING_GUILE_BEFORE_2_2 - -/* Return true if PORT is a session record port. */ -# define SCM_GNUTLS_SESSION_RECORD_PORT_P(_port) \ - (SCM_PORTP (_port) \ - && SCM_PORT_TYPE (_port) == session_record_port_type) - -#else /* USING_GUILE_BEFORE_2_2 */ - -# define SCM_GNUTLS_SESSION_RECORD_PORT_P(_port) \ - (SCM_PORTP (_port) \ - && SCM_TYP16 (_port) == session_record_port_type) - -#endif - -/* Raise a wrong-type-arg exception if PORT is not a session record port. */ -#define SCM_VALIDATE_SESSION_RECORD_PORT(pos, port) \ - SCM_MAKE_VALIDATE_MSG (pos, port, GNUTLS_SESSION_RECORD_PORT_P, \ - "session record port") - -/* Size of a session port's input buffer. */ -#define SCM_GNUTLS_SESSION_RECORD_PORT_BUFFER_SIZE 4096 - - -#if USING_GUILE_BEFORE_2_2 - -/* 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; - - /* We can get GNUTLS_E_AGAIN due to a "short read", which does _not_ - correspond to an actual EAGAIN from read(2) since the underlying file - descriptor is blocking. Thus, we can safely loop right away. */ - do - result = gnutls_record_recv (args->c_session, - c_port->read_buf, c_port->read_buf_size); - while (result == GNUTLS_E_AGAIN || result == GNUTLS_E_INTERRUPTED); - - 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 || result == GNUTLS_E_PREMATURE_TERMINATION) - chr = EOF; - else - scm_gnutls_error (result, "fill_session_record_port_input"); - - return ((void *) (uintptr_t) 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 = (intptr_t) scm_without_guile (do_fill_port, &c_args); - else - /* SESSION's underlying transport is a port, so don't leave "Guile - mode". */ - chr = (intptr_t) 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)) - { - if (c_result != GNUTLS_E_AGAIN && c_result != GNUTLS_E_INTERRUPTED) - scm_gnutls_error (c_result, FUNC_NAME); - } - else - c_sent += c_result; - } -} - -#undef FUNC_NAME - -/* Return a new session port for SESSION. */ -static 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_pointerless (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 (scm_cons (session, SCM_BOOL_F))); - - 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); -} - -#else /* !USING_GUILE_BEFORE_2_2 */ - -static size_t -read_from_session_record_port (SCM port, SCM dst, size_t start, size_t count) -#define FUNC_NAME "read_from_session_record_port" -{ - SCM session; - gnutls_session_t c_session; - char *read_buf; - ssize_t result; - - session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port); - c_session = scm_to_gnutls_session (session, 1, FUNC_NAME); - - read_buf = (char *) SCM_BYTEVECTOR_CONTENTS (dst) + start; - - /* We can get GNUTLS_E_AGAIN due to a "short read", which does _not_ - correspond to an actual EAGAIN from read(2) if the underlying file - descriptor is blocking--e.g., from 'get_last_packet', returning - GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE. - - If SESSION is backed by a file descriptor, return -1 to indicate that - we'd better poll; otherwise loop, which is good enough if the underlying - port is blocking. */ - do - result = gnutls_record_recv (c_session, read_buf, count); - while (result == GNUTLS_E_INTERRUPTED - || (result == GNUTLS_E_AGAIN - && !SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session))); - - if (result == GNUTLS_E_AGAIN - && SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session)) - /* Tell Guile that reading would block. */ - return (size_t) -1; - - if (result == GNUTLS_E_PREMATURE_TERMINATION) - /* Treat premature termination as EOF instead of throwing an exception - that users of the port may not be prepared to handle. */ - result = 0; - else if (EXPECT_FALSE (result < 0)) - scm_gnutls_error (result, FUNC_NAME); - - return result; -} -#undef FUNC_NAME - -/* Return the file descriptor that backs PORT. This function is called upon a - blocking read--i.e., 'read_from_session_record_port' or - 'write_to_session_record_port' returned -1. */ -static int -session_record_port_fd (SCM port) -{ - SCM session; - gnutls_session_t c_session; - - session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port); - c_session = scm_to_gnutls_session (session, 1, __func__); - - assert (SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session)); - - return gnutls_transport_get_int (c_session); -} - -static size_t -write_to_session_record_port (SCM port, SCM src, size_t start, size_t count) -#define FUNC_NAME "write_to_session_record_port" -{ - SCM session; - gnutls_session_t c_session; - char *data; - ssize_t result; - - session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port); - c_session = scm_to_gnutls_session (session, 1, FUNC_NAME); - data = (char *) SCM_BYTEVECTOR_CONTENTS (src) + start; - - do - result = gnutls_record_send (c_session, data, count); - while (result == GNUTLS_E_INTERRUPTED - || (result == GNUTLS_E_AGAIN - && !SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session))); - - if (result == GNUTLS_E_AGAIN - && SCM_GNUTLS_SESSION_TRANSPORT_IS_FD (c_session)) - /* Tell Guile that reading would block. */ - return (size_t) -1; - - if (EXPECT_FALSE (result < 0)) - scm_gnutls_error (result, FUNC_NAME); - - return result; -} -#undef FUNC_NAME - -/* Return a new session port for SESSION. */ -static SCM -make_session_record_port (SCM session) -{ - return scm_c_make_port (session_record_port_type, - SCM_OPN | SCM_RDNG | SCM_WRTNG | SCM_BUF0, - SCM_UNPACK (scm_cons (session, SCM_BOOL_F))); -} - -#endif /* !USING_GUILE_BEFORE_2_2 */ - -/* Call PORT's close procedure, if any. */ -static -#if USING_GUILE_BEFORE_2_2 -int -#else -void -#endif -close_session_record_port (SCM port) -{ - SCM session = SCM_GNUTLS_SESSION_RECORD_PORT_SESSION (port); - SCM close = SCM_GNUTLS_SESSION_RECORD_PORT_CLOSE_PROCEDURE (port); - - if (!scm_is_false (close)) - scm_call_1 (close, port); - - /* When called during finalization (as opposed to a 'close-port' call), - SESSION might be finalized already. Check whether this is the case. */ - if (scm_is_true (scm_gnutls_session_p (session))) - { - /* Detach SESSION from PORT. */ - gnutls_session_t c_session; - c_session = scm_to_gnutls_session (session, 1, __func__); - SCM_GNUTLS_SET_SESSION_RECORD_PORT (c_session, SCM_BOOL_F); - } - -#if USING_GUILE_BEFORE_2_2 - return 0; -#endif -} - -SCM_DEFINE (scm_gnutls_session_record_port, "session-record-port", 1, 1, 0, - (SCM session, SCM close), - "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?}).\n\n" - "If @var{close} is provided, it must be a one-argument " - "procedure, and it will be called when the returned port is " - "closed. This is equivalent to setting it by calling " - "@code{set-session-record-port-close!}.") -#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); - } - - if (!scm_is_eq (close, SCM_UNDEFINED)) - SCM_GNUTLS_SET_SESSION_RECORD_PORT_CLOSE (port, close); - - return (port); -} - -#undef FUNC_NAME - -SCM_DEFINE (scm_gnutls_set_session_record_port_close_x, - "set-session-record-port-close!", 2, 0, 0, - (SCM port, SCM close), - "Set @var{close}, a one-argument procedure, as the procedure " - "called when @var{port} is closed. @var{close} will be passed " - "@var{port}. It may be called when @code{close-port} is " - "called on @var{port}, or when @var{port} is garbage-collected. " - "It is a useful way to free resources associated with @var{port} " - "such as the session's transport file descriptor or port.") -#define FUNC_NAME s_scm_gnutls_set_session_record_port_close_x -{ - SCM_VALIDATE_SESSION_RECORD_PORT (1, port); - SCM_VALIDATE_PROC (2, close); - - SCM_GNUTLS_SET_SESSION_RECORD_PORT_CLOSE (port, close); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -/* Create the session port type. */ -static void -scm_init_gnutls_session_record_port_type (void) -{ - session_record_port_type = - scm_make_port_type ("gnutls-session-port", -#if USING_GUILE_BEFORE_2_2 - fill_session_record_port_input, -#else - read_from_session_record_port, -#endif - write_to_session_record_port); - - scm_set_port_close (session_record_port_type, - close_session_record_port); - -#if !USING_GUILE_BEFORE_2_2 - /* Invoke the user-provided 'close' procedure on GC. */ - scm_set_port_needs_close_on_gc (session_record_port_type, 1); -#endif - -#if !USING_GUILE_BEFORE_2_2 - scm_set_port_read_wait_fd (session_record_port_type, - session_record_port_fd); -#endif -} - - -/* 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) (intptr_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); - register_weak_reference (cred, dh_params); - - return SCM_UNSPECIFIED; -} - -#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 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 = FAST_ALLOC (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); - register_weak_reference (cred, dh_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 = FAST_ALLOC (c_cert_file_len + 1); - - c_key_file_len = scm_c_string_length (key_file); - c_key_file = FAST_ALLOC (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 = FAST_ALLOC (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); - else - { - register_weak_reference (cred, privkey); - register_weak_reference (cred, scm_list_copy (certs)); - } - - 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); - MATCH_STATUS (GNUTLS_CERT_NOT_ACTIVATED); - MATCH_STATUS (GNUTLS_CERT_EXPIRED); - MATCH_STATUS (GNUTLS_CERT_SIGNATURE_FAILURE); - MATCH_STATUS (GNUTLS_CERT_REVOCATION_DATA_SUPERSEDED); - MATCH_STATUS (GNUTLS_CERT_UNEXPECTED_OWNER); - MATCH_STATUS (GNUTLS_CERT_REVOCATION_DATA_ISSUED_IN_FUTURE); - MATCH_STATUS (GNUTLS_CERT_SIGNER_CONSTRAINTS_FAILURE); - MATCH_STATUS (GNUTLS_CERT_MISMATCH); - MATCH_STATUS (GNUTLS_CERT_PURPOSE_MISMATCH); - MATCH_STATUS (GNUTLS_CERT_MISSING_OCSP_STATUS); - MATCH_STATUS (GNUTLS_CERT_INVALID_OCSP_STATUS); - MATCH_STATUS (GNUTLS_CERT_UNKNOWN_CRIT_EXTENSIONS); - - 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. */ - -#ifdef ENABLE_SRP -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 = FAST_ALLOC (c_password_file_len + 1); - c_password_conf_file = FAST_ALLOC (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 = FAST_ALLOC (c_username_len + 1); - c_password = FAST_ALLOC (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 = FAST_ALLOC (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 = FAST_ALLOC (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 = FAST_ALLOC (c_result_len + 1); - - 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 -#endif /* ENABLE_SRP */ - - -/* 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 = FAST_ALLOC (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 = FAST_ALLOC (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 = FAST_ALLOC (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 = FAST_ALLOC (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{" - "https://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_stringn (c_oid, \ - c_oid_actual_len); \ - } \ - \ - 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{https://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 = FAST_ALLOC (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; - uint8_t *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; - uint8_t *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; - uint8_t *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 - -SCM_DEFINE (scm_gnutls_x509_certificate_fingerprint, - "x509-certificate-fingerprint", - 2, 0, 0, - (SCM cert, SCM algo), - "Return the fingerprint (a u8vector) of the certificate " - "@var{cert}, computed using the digest algorithm @var{algo}.") -#define FUNC_NAME s_scm_gnutls_x509_certificate_fingerprint -{ - int err; - SCM result; - gnutls_x509_crt_t c_cert; - gnutls_digest_algorithm_t c_algo; - uint8_t c_fpr[MAX_HASH_SIZE]; - size_t c_fpr_len = MAX_HASH_SIZE; - scm_t_array_handle c_handle; - - c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME); - c_algo = scm_to_gnutls_digest (algo, 1, FUNC_NAME); - - err = gnutls_x509_crt_get_fingerprint (c_cert, c_algo, &c_fpr, &c_fpr_len); - if (EXPECT_FALSE (err)) - scm_gnutls_error (err, FUNC_NAME); - - result = scm_make_u8vector (scm_from_uint(c_fpr_len), SCM_INUM0); - scm_array_get_handle (result, &c_handle); - memcpy (scm_array_handle_u8_writable_elements (&c_handle), &c_fpr, - c_fpr_len); - scm_array_handle_release (&c_handle); - - return result; -} - -#undef FUNC_NAME - - -/* 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_certificate, - "%import-openpgp-certificate", 2, 0, 0, (SCM data, SCM format), - "Return a new OpenPGP certificate object resulting from the " - "import of @var{data} (a uniform array) according to " - "@var{format}.") -#define FUNC_NAME s_scm_gnutls_import_openpgp_certificate -{ - int err; - gnutls_openpgp_crt_t c_key; - gnutls_openpgp_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_openpgp_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_openpgp_crt_init (&c_key); - if (EXPECT_FALSE (err)) - { - scm_gnutls_release_array (&c_data_handle); - scm_gnutls_error (err, FUNC_NAME); - } - - err = gnutls_openpgp_crt_import (c_key, &c_data_d, c_format); - scm_gnutls_release_array (&c_data_handle); - - if (EXPECT_FALSE (err)) - { - gnutls_openpgp_crt_deinit (c_key); - scm_gnutls_error (err, FUNC_NAME); - } - - return (scm_from_gnutls_openpgp_certificate (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_crt_fmt_t 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_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 = FAST_ALLOC (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_certificate_id, "%openpgp-certificate-id", - 1, 0, 0, - (SCM key), - "Return the ID (an 8-element u8vector) of certificate " - "@var{key}.") -#define FUNC_NAME s_scm_gnutls_openpgp_certificate_id -{ - int err; - unsigned char *c_id; - gnutls_openpgp_crt_t c_key; - - c_key = scm_to_gnutls_openpgp_certificate (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_crt_get_key_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_certificate_id_x, "%openpgp-certificate-id!", - 2, 0, 0, - (SCM key, SCM id), - "Store the ID (an 8 byte sequence) of certificate " - "@var{key} in @var{id} (a u8vector).") -#define FUNC_NAME s_scm_gnutls_openpgp_certificate_id_x -{ - int err; - char *c_id; - scm_t_array_handle c_id_handle; - size_t c_id_size; - gnutls_openpgp_crt_t c_key; - - c_key = scm_to_gnutls_openpgp_certificate (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_crt_get_key_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_certificate_fingerpint_x, - "%openpgp-certificate-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_certificate_fingerpint_x -{ - int err; - gnutls_openpgp_crt_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_certificate (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_crt_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_certificate_fingerprint, - "%openpgp-certificate-fingerprint", - 1, 0, 0, - (SCM key), - "Return a new u8vector denoting the fingerprint of " "@var{key}.") -#define FUNC_NAME s_scm_gnutls_openpgp_certificate_fingerprint -{ - int err; - gnutls_openpgp_crt_t c_key; - unsigned char *c_fpr; - size_t c_fpr_len, c_actual_len; - - c_key = scm_to_gnutls_openpgp_certificate (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_crt_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_certificate_name, "%openpgp-certificate-name", - 2, 0, 0, - (SCM key, SCM index), - "Return the @var{index}th name of @var{key}.") -#define FUNC_NAME s_scm_gnutls_openpgp_certificate_name -{ - int err; - gnutls_openpgp_crt_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_certificate (key, 1, FUNC_NAME); - c_index = scm_to_int (index); - - err = gnutls_openpgp_crt_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_certificate_names, "%openpgp-certificate-names", - 1, 0, 0, (SCM key), "Return the list of names for @var{key}.") -#define FUNC_NAME s_scm_gnutls_openpgp_certificate_names -{ - int err; - SCM result = SCM_EOL; - gnutls_openpgp_crt_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_certificate (key, 1, FUNC_NAME); - - do - { - err = gnutls_openpgp_crt_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_certificate_algorithm, - "%openpgp-certificate-algorithm", - 1, 0, 0, - (SCM key), - "Return two values: the certificate algorithm used by " - "@var{key} and the number of bits used.") -#define FUNC_NAME s_scm_gnutls_openpgp_certificate_algorithm -{ - gnutls_openpgp_crt_t c_key; - unsigned int c_bits; - gnutls_pk_algorithm_t c_algo; - - c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME); - c_algo = gnutls_openpgp_crt_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_certificate_version, - "%openpgp-certificate-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_certificate_version -{ - int c_version; - gnutls_openpgp_crt_t c_key; - - c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME); - c_version = gnutls_openpgp_crt_get_version (c_key); - - return (scm_from_int (c_version)); -} - -#undef FUNC_NAME - -SCM_DEFINE (scm_gnutls_openpgp_certificate_usage, "%openpgp-certificate-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_certificate_usage -{ - int err; - unsigned int c_usage = 0; - gnutls_openpgp_crt_t c_key; - - c_key = scm_to_gnutls_openpgp_certificate (key, 1, FUNC_NAME); - - err = gnutls_openpgp_crt_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_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_openpgp_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_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 - - -/* OpenPGP 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 certificate @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_crt_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_certificate (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 - - - -/* 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.x" - - (void) gnutls_global_init (); - - scm_gnutls_define_enums (); - - scm_init_gnutls_error (); - - scm_init_gnutls_session_record_port_type (); - - weak_refs = scm_make_weak_key_hash_table (scm_from_int (42)); - weak_refs = scm_permanent_object (weak_refs); -} diff --git a/guile/src/errors.c b/guile/src/errors.c deleted file mode 100644 index a78f2ffef8..0000000000 --- a/guile/src/errors.c +++ /dev/null @@ -1,74 +0,0 @@ -/* GnuTLS --- Guile bindings for GnuTLS. - Copyright (C) 2007-2012, 2019 Free Software Foundation, Inc. - - 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>. */ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <libguile.h> -#include <gnutls/gnutls.h> - -#include "errors.h" -#include "enums.h" - -SCM_SYMBOL (gnutls_error_key, "gnutls-error"); - -void -scm_gnutls_error_with_args (int c_err, const char *c_func, SCM args) -{ - 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_cons2 (err, func, args)); - - /* 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_gnutls_error (int c_err, const char *c_func) -{ - scm_gnutls_error_with_args (c_err, c_func, SCM_EOL); -} - -SCM_DEFINE (scm_gnutls_fatal_error_p, "fatal-error?", 1, 0, 0, - (SCM err), - "Return true if @var{error} is fatal.") -#define FUNC_NAME s_scm_gnutls_fatal_error_p -{ - int c_err = scm_to_gnutls_error (err, 1, FUNC_NAME); - return scm_from_bool (gnutls_error_is_fatal (c_err)); -} -#undef FUNC_NAME - - - -void -scm_init_gnutls_error (void) -{ -#include "errors.x" -} - -/* arch-tag: 48f07ecf-65c4-480c-b043-a51eab592d6b - */ diff --git a/guile/src/errors.h b/guile/src/errors.h deleted file mode 100644 index a2fad2ea0e..0000000000 --- a/guile/src/errors.h +++ /dev/null @@ -1,33 +0,0 @@ -/* GnuTLS --- Guile bindings for GnuTLS. - Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. - - 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_with_args (int, const char *, SCM) - NO_RETURN; - -SCM_API void scm_gnutls_error (int, const char *) - NO_RETURN; - -SCM_API void scm_init_gnutls_error (void); - -#endif diff --git a/guile/src/make-enum-header.scm b/guile/src/make-enum-header.scm deleted file mode 100644 index 5b22d40023..0000000000 --- a/guile/src/make-enum-header.scm +++ /dev/null @@ -1,58 +0,0 @@ -;;; Help produce Guile wrappers for GnuTLS types. -;;; -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. -;;; -;;; 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@gnu.org>. - - -(use-modules (gnutls build enums)) - - -;;; -;;; The program. -;;; - -(define (main . args) - (let ((port (current-output-port)) - (enums %gnutls-enums)) - (format port "/* Automatically generated, do not edit. */~%~%") - (format port "#ifndef GUILE_GNUTLS_ENUMS_H~%") - (format port "#define GUILE_GNUTLS_ENUMS_H~%") - - (format port "#ifdef HAVE_CONFIG_H~%") - (format port "# include <config.h>~%") - (format port "#endif~%~%") - (format port "#include <gnutls/gnutls.h>~%") - (format port "#include <gnutls/x509.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 deleted file mode 100644 index faa808dd6d..0000000000 --- a/guile/src/make-enum-map.scm +++ /dev/null @@ -1,45 +0,0 @@ -;;; Help produce Guile wrappers for GnuTLS types. -;;; -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. -;;; -;;; 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 %gnutls-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-smob-header.scm b/guile/src/make-smob-header.scm deleted file mode 100644 index 7c4fa516e9..0000000000 --- a/guile/src/make-smob-header.scm +++ /dev/null @@ -1,50 +0,0 @@ -;;; Help produce Guile wrappers for GnuTLS types. -;;; -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. -;;; -;;; 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)) - (enums %gnutls-smobs)) - (format port "/* Automatically generated, do not edit. */~%~%") - (format port "#ifndef GUILE_GNUTLS_SMOBS_H~%") - (format port "#define GUILE_GNUTLS_SMOBS_H~%") - (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 deleted file mode 100644 index 22132ec7d6..0000000000 --- a/guile/src/make-smob-types.scm +++ /dev/null @@ -1,44 +0,0 @@ -;;; Help produce Guile wrappers for GnuTLS types. -;;; -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc. -;;; -;;; 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)) - %gnutls-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 deleted file mode 100644 index 88db96386b..0000000000 --- a/guile/src/utils.c +++ /dev/null @@ -1,67 +0,0 @@ -/* GnuTLS --- Guile bindings for GnuTLS. - Copyright (C) 2007-2012, 2019 Free Software Foundation, Inc. - - 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>. */ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "utils.h" - -#include <gnutls/gnutls.h> -#include <libguile.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, __func__); - -#undef MATCH_USAGE - - return usage; -} - -/* arch-tag: a55fe230-ead7-495d-ab11-dfe18452ca2a - */ diff --git a/guile/src/utils.h b/guile/src/utils.h deleted file mode 100644 index 8e04f726d3..0000000000 --- a/guile/src/utils.h +++ /dev/null @@ -1,117 +0,0 @@ -/* GnuTLS --- Guile bindings for GnuTLS. - Copyright (C) 2007-2010, 2012 Free Software Foundation, Inc. - - 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 <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/anonymous-auth.scm b/guile/tests/anonymous-auth.scm deleted file mode 100644 index e9010bc554..0000000000 --- a/guile/tests/anonymous-auth.scm +++ /dev/null @@ -1,93 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2013, 2016 Free Software Foundation, Inc. -;;; -;;; 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) - (gnutls build tests) - (srfi srfi-4)) - - -;; TLS session settings. -(define priorities - "NONE:+VERS-TLS1.2:+CIPHER-ALL:+MAC-ALL:+SIGN-ALL:+COMP-ALL:+ANON-DH") - -;; Message sent by the client. -(define %message (apply u8vector (iota 256))) - -(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-dh-params file) - (import-something pkcs3-import-dh-parameters file - x509-certificate-format/pem)) - -;; Debugging. -;; (set-log-level! 100) -;; (set-log-procedure! (lambda (level str) -;; (format #t "[~a|~a] ~a" (getpid) level str))) - -(run-test - (lambda () - (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))) - (with-child-process pid - ;; server-side - (let ((server (make-session connection-end/server))) - (set-session-priorities! server priorities) - - (set-session-transport-fd! server (port->fdes (cdr socket-pair))) - (let ((cred (make-anonymous-server-credentials)) - (dh-params (import-dh-params "dh-parameters.pem"))) - ;; 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) - (and (zero? (cdr (waitpid pid))) - (= amount (u8vector-length %message)) - (equal? buf %message)))) - - ;; client-side (child process) - (let ((client (make-session connection-end/client))) - (set-session-priorities! client priorities) - (set-session-server-name! client - server-name-type/dns (gethostname)) - (set-session-transport-fd! client (port->fdes (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) - - (primitive-exit)))))) - -;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0 diff --git a/guile/tests/dh-parameters.pem b/guile/tests/dh-parameters.pem deleted file mode 100644 index 9a824c34e2..0000000000 --- a/guile/tests/dh-parameters.pem +++ /dev/null @@ -1,5 +0,0 @@ ------BEGIN DH PARAMETERS----- -MIGGAoGAtkxw2jlsVCsrfLqxrN+IrF/3W8vVFvDzYbLmxi2GQv9s/PQGWP1d9i22 -P2DprfcJknWt7KhCI1SaYseOQIIIAYP78CfyIpGScW/vS8khrw0rlQiyeCvQgF3O -GeGOEywcw+oQT4SmFOD7H0smJe2CNyjYpexBXQ/A0mbTF9QKm1cCAQU= ------END DH PARAMETERS----- diff --git a/guile/tests/errors.scm b/guile/tests/errors.scm deleted file mode 100644 index b8d46234ab..0000000000 --- a/guile/tests/errors.scm +++ /dev/null @@ -1,44 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012, 2019 Free Software Foundation, Inc. -;;; -;;; 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) - (gnutls build tests)) - -(run-test - (lambda () - (and (fatal-error? error/hash-failed) - (not (fatal-error? error/reauth-request)) - - (let ((s (make-session connection-end/server))) - (catch 'gnutls-error - (lambda () - (handshake s)) - (lambda (key err function . currently-unused) - (and (eq? key 'gnutls-error) - err - (fatal-error? err) - (string? (error->string err)) - (eq? function 'handshake)))))))) - -;;; arch-tag: 73ed6229-378d-4a12-a5c6-4c2586c6e3a2 diff --git a/guile/tests/pkcs-import-export.scm b/guile/tests/pkcs-import-export.scm deleted file mode 100644 index 014f43a3da..0000000000 --- a/guile/tests/pkcs-import-export.scm +++ /dev/null @@ -1,52 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012 Free Software Foundation, Inc. -;;; -;;; 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) - (gnutls build tests) - (srfi srfi-4)) - -(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-dh-params file) - (import-something pkcs3-import-dh-parameters file - x509-certificate-format/pem)) - -(run-test - (lambda () - (let* ((dh-params (import-dh-params "dh-parameters.pem")) - (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)))))) - -;;; arch-tag: adff0f07-479e-421e-b47f-8956e06b9902 diff --git a/guile/tests/premature-termination.scm b/guile/tests/premature-termination.scm deleted file mode 100644 index 4c17da3ded..0000000000 --- a/guile/tests/premature-termination.scm +++ /dev/null @@ -1,92 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2022 Free Software Foundation, Inc. -;;; -;;; 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 handling of premature session termination on the client side while -;;; reading from a session record port. -;;; - -(use-modules (gnutls) - (gnutls build tests) - (srfi srfi-4)) - -;; TLS session settings. -(define priorities - "NONE:+VERS-TLS1.2:+CIPHER-ALL:+MAC-ALL:+SIGN-ALL:+COMP-ALL:+ANON-DH") - -;; Message sent by the client. -(define %message (apply u8vector (iota 256))) - -(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-dh-params file) - (import-something pkcs3-import-dh-parameters file - x509-certificate-format/pem)) - -;; Debugging. -;; (set-log-level! 100) -;; (set-log-procedure! (lambda (level str) -;; (format #t "[~a|~a] ~a" (getpid) level str))) - -(run-test - (lambda () - (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))) - (with-child-process pid - ;; server-side - (let ((server (make-session connection-end/server))) - (close-port (car socket-pair)) ;close the client end - (set-session-priorities! server priorities) - (set-session-transport-fd! server (fileno (cdr socket-pair))) - (let ((cred (make-anonymous-server-credentials)) - (dh-params (import-dh-params "dh-parameters.pem"))) - ;; 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) - - (alarm 60) ;time out after a while - (close-port (cdr socket-pair)) ;close prematurely - (zero? (cdr (waitpid pid)))) - - ;; client-side (child process) - (let ((client (make-session connection-end/client))) - (close-port (cdr socket-pair)) ;close the server end - (set-session-priorities! client priorities) - (set-session-server-name! client - server-name-type/dns (gethostname)) - (set-session-transport-fd! client (port->fdes (car socket-pair))) - (set-session-credentials! client (make-anonymous-client-credentials)) - (set-session-dh-prime-bits! client 1024) - - (handshake client) - - ;; Read from the session record port: instead of getting an - ;; 'error/premature-termination' exception, we expect to get EOF. - (let* ((port (session-record-port client)) - (read (read port))) - (format #t "client received ~s~%" read) - (primitive-exit (if (eof-object? read) 0 1)))))))) diff --git a/guile/tests/priorities.scm b/guile/tests/priorities.scm deleted file mode 100644 index 6e837294de..0000000000 --- a/guile/tests/priorities.scm +++ /dev/null @@ -1,70 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS -;;; Copyright (C) 2011-2012 Free Software Foundation, Inc. -;;; -;;; GnuTLS 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 3 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 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@gnu.org>. - - -;;; -;;; Exercise the priority API of GnuTLS. -;;; - -(use-modules (gnutls) - (gnutls build tests) - (srfi srfi-1) - (srfi srfi-26)) - -(define %valid-priority-strings - ;; Valid priority strings (from the manual). - '("NONE:+VERS-TLS1.2:+MAC-ALL:+RSA:+AES-128-CBC:+SIGN-ALL:+COMP-NULL" - "NORMAL:-ARCFOUR-128" - "SECURE128:-VERS-SSL3.0:+COMP-NULL" - "NONE:+VERS-TLS1.2:+AES-128-CBC:+RSA:+SHA1:+COMP-NULL:+SIGN-RSA-SHA1")) - -(define %invalid-priority-strings - ;; Invalid strings: the prefix and the suffix that leads to a parse error. - '(("" . "THIS-DOES-NOT-WORK") - ("NORMAL:" . "FAIL-HERE") - ("SECURE128:-VERS-SSL3.0:" . "+FAIL-HERE") - ("NONE:+VERS-TLS1.2:+AES-128-CBC:" - . "+FAIL-HERE:+SHA1:+COMP-NULL:+SIGN-RSA-SHA1"))) - -(run-test - - (lambda () - (let ((s (make-session connection-end/client))) - ;; We shouldn't have any exception with the valid priority strings. - (for-each (cut set-session-priorities! s <>) - %valid-priority-strings) - - (every (lambda (prefix+suffix) - (let* ((prefix (car prefix+suffix)) - (suffix (cdr prefix+suffix)) - (pos (string-length prefix)) - (string (string-append prefix suffix))) - (catch 'gnutls-error - (lambda () - (let ((s (make-session connection-end/client))) - ;; The following call should raise an exception. - (set-session-priorities! s string) - #f)) - (lambda (key err function error-location . unused) - (and (eq? key 'gnutls-error) - (eq? err error/invalid-request) - (eq? function 'set-session-priorities!) - (= error-location pos)))))) - %invalid-priority-strings)))) diff --git a/guile/tests/reauth.scm b/guile/tests/reauth.scm deleted file mode 100644 index 0f768e514e..0000000000 --- a/guile/tests/reauth.scm +++ /dev/null @@ -1,121 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2019 Free Software Foundation, Inc. -;;; -;;; 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 TLS 1.3 re-authentication requests. -;;; - -(use-modules (gnutls) - (gnutls build tests) - (srfi srfi-4)) - - -;; TLS session settings. -(define priorities - "NORMAL:+VERS-TLS1.3") - -;; 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-dh-params file) - (import-something pkcs3-import-dh-parameters file - x509-certificate-format/pem)) - -;; Debugging. -;; (set-log-level! 5) -;; (set-log-procedure! (lambda (level str) -;; (format #t "[~a|~a] ~a" (getpid) level str))) - -(run-test - (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"))) - (with-child-process pid - - ;; server-side - (let ((server (make-session connection-end/server - connection-flag/post-handshake-auth)) - (dh (import-dh-params "dh-parameters.pem"))) - (set-session-priorities! server "NORMAL:+VERS-TLS1.3") - (set-session-transport-fd! server (port->fdes (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-x509-keys! cred (list pub) sec) - (set-certificate-credentials-x509-trust-file! cred - trust-file - trust-fmt) - (set-session-credentials! server cred)) - - (handshake server) - (let ((msg (read (session-record-port server))) - (auth-type (session-authentication-type server))) - (set-server-session-certificate-request! server - certificate-request/request) - - ;; Request a post-handshake reauthentication. - (reauthenticate server) - - (write msg (session-record-port server)) - (bye server close-request/rdwr) - (and (zero? (cdr (waitpid pid))) - (eq? auth-type credentials/certificate) - (equal? msg %message)))) - - ;; client-side (child process) - (let ((client (make-session connection-end/client - connection-flag/post-handshake-auth - connection-flag/auto-reauth)) - (cred (make-certificate-credentials))) - (set-session-priorities! client - "NORMAL:-VERS-ALL:+VERS-TLS1.3:+VERS-TLS1.2:+VERS-TLS1.0") - (set-certificate-credentials-x509-keys! cred (list pub) sec) - (set-session-credentials! client cred) - - (set-session-transport-fd! client (port->fdes (car socket-pair))) - - (handshake client) - (write %message (session-record-port client)) - - ;; In the middle of the 'read' call, we receive a post-handshake - ;; reauthentication request that should be automatically handled, - ;; thanks to CONNECTION-FLAG/AUTO-REAUTH. - (let ((msg (read (session-record-port client)))) - (unless (equal? msg %message) - (error "wrong message" msg))) - (bye client close-request/rdwr) - - (primitive-exit)))))) diff --git a/guile/tests/rsa-parameters.pem b/guile/tests/rsa-parameters.pem deleted file mode 100644 index b1cd7db3f5..0000000000 --- a/guile/tests/rsa-parameters.pem +++ /dev/null @@ -1,15 +0,0 @@ ------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 deleted file mode 100644 index 6a7ec035d0..0000000000 --- a/guile/tests/session-record-port.scm +++ /dev/null @@ -1,134 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012, 2014, 2016, 2022 Free Software Foundation, Inc. -;;; -;;; 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) - (gnutls build tests) - (srfi srfi-4)) - -;; TLS session settings. -(define priorities - "NONE:+VERS-TLS1.2:+CIPHER-ALL:+MAC-ALL:+SIGN-ALL:+COMP-ALL:+ANON-DH") - -;; Message sent by the client. -(define %message (apply u8vector (iota 256))) - -(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-dh-params file) - (import-something pkcs3-import-dh-parameters file - x509-certificate-format/pem)) - -;; Debugging. -;; (set-log-level! 100) -;; (set-log-procedure! (lambda (level str) -;; (format #t "[~a|~a] ~a" (getpid) level str))) - -(run-test - (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 with 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))) - (with-child-process pid - - ;; server-side - (let ((server (make-session connection-end/server))) - (set-session-priorities! server priorities) - - (set-session-transport-fd! server (fileno (cdr socket-pair))) - (let ((cred (make-anonymous-server-credentials)) - (dh-params (import-dh-params "dh-parameters.pem"))) - ;; 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. - (and (eq? (session-record-port server) - (session-record-port server)) - (zero? (cdr (waitpid pid))) - (= amount (u8vector-length %message)) - (equal? buf %message) - (eof-object? - (read-char (session-record-port server))) - - ;; Close the port and make sure its 'close' procedure is - ;; called. - (let* ((closed? #f) - (port (session-record-port server)) - (close (lambda (p) - (format #t "closing port ~s~%" p) - (set! closed? (eq? p port))))) - (set-session-record-port-close! port close) - (close-port port) - closed?)))) - - ;; client-side (child process) - (let ((client (make-session connection-end/client))) - (set-session-priorities! client priorities) - - (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) - - (primitive-exit)))))) - -;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2 diff --git a/guile/tests/srp-base64.scm b/guile/tests/srp-base64.scm deleted file mode 100644 index 2ad0221700..0000000000 --- a/guile/tests/srp-base64.scm +++ /dev/null @@ -1,42 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012 Free Software Foundation, Inc. -;;; -;;; 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) - (gnutls build tests)) - -(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.") - -(run-test - (lambda () - (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 deleted file mode 100644 index 21f192fa54..0000000000 --- a/guile/tests/x509-auth.scm +++ /dev/null @@ -1,110 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2014, 2016 Free Software Foundation, Inc. -;;; -;;; 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) - (gnutls build tests) - (srfi srfi-4)) - -;; TLS session settings. -(define priorities - "NORMAL") - -;; 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-dh-params file) - (import-something pkcs3-import-dh-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))) - -(run-test - (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"))) - (with-child-process pid - - ;; server-side - (let ((server (make-session connection-end/server)) - (dh (import-dh-params "dh-parameters.pem"))) - (set-session-priorities! server priorities) - (set-server-session-certificate-request! server - certificate-request/require) - - (set-session-transport-fd! server (port->fdes (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-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) - (and (zero? (cdr (waitpid pid))) - (eq? auth-type credentials/certificate) - (equal? msg %message)))) - - ;; client-side (child process) - (let ((client (make-session connection-end/client)) - (cred (make-certificate-credentials))) - (set-session-priorities! client priorities) - (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 (port->fdes (car socket-pair))) - - (handshake client) - (write %message (session-record-port client)) - (bye client close-request/rdwr) - - (primitive-exit)))))) - -;;; arch-tag: 1f88f835-a5c8-4fd6-94b6-5a13571ba03d diff --git a/guile/tests/x509-certificate.pem b/guile/tests/x509-certificate.pem deleted file mode 100644 index f6f4bed1a4..0000000000 --- a/guile/tests/x509-certificate.pem +++ /dev/null @@ -1,32 +0,0 @@ ------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 deleted file mode 100644 index 874c8ac5ea..0000000000 --- a/guile/tests/x509-certificates.scm +++ /dev/null @@ -1,99 +0,0 @@ -;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007-2012, 2021 Free Software Foundation, Inc. -;;; -;;; 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) - (gnutls build tests) - (srfi srfi-4) - (srfi srfi-11) - (ice-9 format)) - -(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 %sha1-fingerprint - ;; The certificate's SHA-1 fingerprint. - "7c55df47de718869d55998ee1e9301331ccd0601") - -(define %sha256-fingerprint - ;; The certificate's SHA-256 fingerprint. - "0db40a5ee20169d25f090e4d165d87266b1a04722cddec4da36692c81c3096f6") - - -(define (file-size file) - (stat:size (stat file))) - -(define (u8vector->hex-string u8vector) - (string-join (map (lambda (u8) (format #f "~2,'0x" u8)) - (u8vector->list u8vector)) - "")) - - -(run-test - (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))) - - (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)))) - (equal? (u8vector->hex-string - (x509-certificate-fingerprint cert digest/sha1)) - %sha1-fingerprint) - (equal? (u8vector->hex-string - (x509-certificate-fingerprint cert digest/sha256)) - %sha256-fingerprint)))))) - -;;; arch-tag: eef09b52-30e8-472a-8b93-cb636434f6eb diff --git a/guile/tests/x509-key.pem b/guile/tests/x509-key.pem deleted file mode 100644 index 1e80b2e55e..0000000000 --- a/guile/tests/x509-key.pem +++ /dev/null @@ -1,15 +0,0 @@ ------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----- diff --git a/m4/guile.m4 b/m4/guile.m4 deleted file mode 100644 index 48642f027f..0000000000 --- a/m4/guile.m4 +++ /dev/null @@ -1,397 +0,0 @@ -## Autoconf macros for working with Guile. -## -## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013, 2014, 2020 Free Software Foundation, Inc. -## -## This library is free software; you can redistribute it and/or -## modify it under the terms of the GNU Lesser General Public License -## as published by the Free Software Foundation; either version 3 of -## the License, or (at your option) any later version. -## -## This library is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -## Lesser General Public License for more details. -## -## You should have received a copy of the GNU Lesser General Public -## License along with this library; if not, write to the Free Software -## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -## 02110-1301 USA - -# serial 11 - -## Index -## ----- -## -## GUILE_PKG -- find Guile development files -## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs -## GUILE_FLAGS -- set flags for compiling and linking with Guile -## GUILE_SITE_DIR -- find path to Guile "site" directories -## GUILE_CHECK -- evaluate Guile Scheme code and capture the return value -## GUILE_MODULE_CHECK -- check feature of a Guile Scheme module -## GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module -## GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable -## GUILE_MODULE_EXPORTS -- check if a module exports a variable -## GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable - -## Code -## ---- - -## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged -## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory). - -# GUILE_PKG -- find Guile development files -# -# Usage: GUILE_PKG([VERSIONS]) -# -# This macro runs the @code{pkg-config} tool to find development files -# for an available version of Guile. -# -# By default, this macro will search for the latest stable version of -# Guile (e.g. 3.0), falling back to the previous stable version -# (e.g. 2.2) if it is available. If no guile-@var{VERSION}.pc file is -# found, an error is signalled. The found version is stored in -# @var{GUILE_EFFECTIVE_VERSION}. -# -# If @code{GUILE_PROGS} was already invoked, this macro ensures that the -# development files have the same effective version as the Guile -# program. -# -# @var{GUILE_EFFECTIVE_VERSION} is marked for substitution, as by -# @code{AC_SUBST}. -# -AC_DEFUN([GUILE_PKG], - [AC_REQUIRE([PKG_PROG_PKG_CONFIG]) - if test "x$PKG_CONFIG" = x; then - AC_MSG_ERROR([pkg-config is missing, please install it]) - fi - _guile_versions_to_search="m4_default([$1], [3.0 2.2 2.0])" - if test -n "$GUILE_EFFECTIVE_VERSION"; then - _guile_tmp="" - for v in $_guile_versions_to_search; do - if test "$v" = "$GUILE_EFFECTIVE_VERSION"; then - _guile_tmp=$v - fi - done - if test -z "$_guile_tmp"; then - AC_MSG_FAILURE([searching for guile development files for versions $_guile_versions_to_search, but previously found $GUILE version $GUILE_EFFECTIVE_VERSION]) - fi - _guile_versions_to_search=$GUILE_EFFECTIVE_VERSION - fi - GUILE_EFFECTIVE_VERSION="" - _guile_errors="" - for v in $_guile_versions_to_search; do - if test -z "$GUILE_EFFECTIVE_VERSION"; then - AC_MSG_NOTICE([checking for guile $v]) - PKG_CHECK_EXISTS([guile-$v], [GUILE_EFFECTIVE_VERSION=$v], []) - fi - done - - if test -z "$GUILE_EFFECTIVE_VERSION"; then - AC_MSG_ERROR([ -No Guile development packages were found. - -Please verify that you have Guile installed. If you installed Guile -from a binary distribution, please verify that you have also installed -the development packages. If you installed it yourself, you might need -to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more. -]) - fi - AC_MSG_NOTICE([found guile $GUILE_EFFECTIVE_VERSION]) - AC_SUBST([GUILE_EFFECTIVE_VERSION]) - ]) - -# GUILE_FLAGS -- set flags for compiling and linking with Guile -# -# Usage: GUILE_FLAGS -# -# This macro runs the @code{pkg-config} tool to find out how to compile -# and link programs against Guile. It sets four variables: -# @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, and -# @var{GUILE_LTLIBS}. -# -# @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that -# uses Guile header files. This is almost always just one or more @code{-I} -# flags. -# -# @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program -# against Guile. This includes @code{-lguile-@var{VERSION}} for the -# Guile library itself, and may also include one or more @code{-L} flag -# to tell the compiler where to find the libraries. But it does not -# include flags that influence the program's runtime search path for -# libraries, and will therefore lead to a program that fails to start, -# unless all necessary libraries are installed in a standard location -# such as @file{/usr/lib}. -# -# @var{GUILE_LIBS} and @var{GUILE_LTLIBS}: flags to pass to the compiler or to -# libtool, respectively, to link a program against Guile. It includes flags -# that augment the program's runtime search path for libraries, so that shared -# libraries will be found at the location where they were during linking, even -# in non-standard locations. @var{GUILE_LIBS} is to be used when linking the -# program directly with the compiler, whereas @var{GUILE_LTLIBS} is to be used -# when linking the program is done through libtool. -# -# The variables are marked for substitution, as by @code{AC_SUBST}. -# -AC_DEFUN([GUILE_FLAGS], - [AC_REQUIRE([GUILE_PKG]) - PKG_CHECK_MODULES(GUILE, [guile-$GUILE_EFFECTIVE_VERSION]) - - dnl GUILE_CFLAGS and GUILE_LIBS are already defined and AC_SUBST'd by - dnl PKG_CHECK_MODULES. But GUILE_LIBS to pkg-config is GUILE_LDFLAGS - dnl to us. - - GUILE_LDFLAGS=$GUILE_LIBS - - dnl Determine the platform dependent parameters needed to use rpath. - dnl AC_LIB_LINKFLAGS_FROM_LIBS is defined in gnulib/m4/lib-link.m4 and needs - dnl the file gnulib/build-aux/config.rpath. - AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LIBS], [$GUILE_LDFLAGS], []) - GUILE_LIBS="$GUILE_LDFLAGS $GUILE_LIBS" - AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LTLIBS], [$GUILE_LDFLAGS], [yes]) - GUILE_LTLIBS="$GUILE_LDFLAGS $GUILE_LTLIBS" - - AC_SUBST([GUILE_EFFECTIVE_VERSION]) - AC_SUBST([GUILE_CFLAGS]) - AC_SUBST([GUILE_LDFLAGS]) - AC_SUBST([GUILE_LIBS]) - AC_SUBST([GUILE_LTLIBS]) - ]) - -# GUILE_SITE_DIR -- find path to Guile site directories -# -# Usage: GUILE_SITE_DIR -# -# This looks for Guile's "site" directories. The variable @var{GUILE_SITE} will -# be set to Guile's "site" directory for Scheme source files (usually something -# like PREFIX/share/guile/site). @var{GUILE_SITE_CCACHE} will be set to the -# directory for compiled Scheme files also known as @code{.go} files -# (usually something like -# PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/site-ccache). -# @var{GUILE_EXTENSION} will be set to the directory for compiled C extensions -# (usually something like -# PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/extensions). The latter two -# are set to blank if the particular version of Guile does not support -# them. Note that this macro will run the macros @code{GUILE_PKG} and -# @code{GUILE_PROGS} if they have not already been run. -# -# The variables are marked for substitution, as by @code{AC_SUBST}. -# -AC_DEFUN([GUILE_SITE_DIR], - [AC_REQUIRE([GUILE_PKG]) - AC_REQUIRE([GUILE_PROGS]) - AC_MSG_CHECKING(for Guile site directory) - GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir guile-$GUILE_EFFECTIVE_VERSION` - AC_MSG_RESULT($GUILE_SITE) - if test "$GUILE_SITE" = ""; then - AC_MSG_FAILURE(sitedir not found) - fi - AC_SUBST(GUILE_SITE) - AC_MSG_CHECKING([for Guile site-ccache directory using pkgconfig]) - GUILE_SITE_CCACHE=`$PKG_CONFIG --variable=siteccachedir guile-$GUILE_EFFECTIVE_VERSION` - if test "$GUILE_SITE_CCACHE" = ""; then - AC_MSG_RESULT(no) - AC_MSG_CHECKING([for Guile site-ccache directory using interpreter]) - GUILE_SITE_CCACHE=`$GUILE -c "(display (if (defined? '%site-ccache-dir) (%site-ccache-dir) \"\"))"` - if test $? != "0" -o "$GUILE_SITE_CCACHE" = ""; then - AC_MSG_RESULT(no) - GUILE_SITE_CCACHE="" - AC_MSG_WARN([siteccachedir not found]) - fi - fi - AC_MSG_RESULT($GUILE_SITE_CCACHE) - AC_SUBST([GUILE_SITE_CCACHE]) - AC_MSG_CHECKING(for Guile extensions directory) - GUILE_EXTENSION=`$PKG_CONFIG --print-errors --variable=extensiondir guile-$GUILE_EFFECTIVE_VERSION` - AC_MSG_RESULT($GUILE_EXTENSION) - if test "$GUILE_EXTENSION" = ""; then - GUILE_EXTENSION="" - AC_MSG_WARN(extensiondir not found) - fi - AC_SUBST(GUILE_EXTENSION) - ]) - -# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs -# -# Usage: GUILE_PROGS([VERSION]) -# -# This macro looks for programs @code{guile} and @code{guild}, setting -# variables @var{GUILE} and @var{GUILD} to their paths, respectively. -# The macro will attempt to find @code{guile} with the suffix of -# @code{-X.Y}, followed by looking for it with the suffix @code{X.Y}, and -# then fall back to looking for @code{guile} with no suffix. If -# @code{guile} is still not found, signal an error. The suffix, if any, -# that was required to find @code{guile} will be used for @code{guild} -# as well. -# -# By default, this macro will search for the latest stable version of -# Guile (e.g. 3.0). x.y or x.y.z versions can be specified. If an older -# version is found, the macro will signal an error. -# -# The effective version of the found @code{guile} is set to -# @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective -# version is compatible with the result of a previous invocation of -# @code{GUILE_FLAGS}, if any. -# -# As a legacy interface, it also looks for @code{guile-config} and -# @code{guile-tools}, setting @var{GUILE_CONFIG} and @var{GUILE_TOOLS}. -# -# The variables are marked for substitution, as by @code{AC_SUBST}. -# -AC_DEFUN([GUILE_PROGS], - [_guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" - if test -z "$_guile_required_version"; then - _guile_required_version=3.0 - fi - - _guile_candidates=guile - _tmp= - for v in `echo "$_guile_required_version" | tr . ' '`; do - if test -n "$_tmp"; then _tmp=$_tmp.; fi - _tmp=$_tmp$v - _guile_candidates="guile-$_tmp guile$_tmp $_guile_candidates" - done - - AC_PATH_PROGS(GUILE,[$_guile_candidates]) - if test -z "$GUILE"; then - AC_MSG_ERROR([guile required but not found]) - fi - - _guile_suffix=`echo "$GUILE" | sed -e 's,^.*/guile\(.*\)$,\1,'` - _guile_effective_version=`$GUILE -c "(display (effective-version))"` - if test -z "$GUILE_EFFECTIVE_VERSION"; then - GUILE_EFFECTIVE_VERSION=$_guile_effective_version - elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_effective_version"; then - AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_effective_version]) - fi - - _guile_major_version=`$GUILE -c "(display (major-version))"` - _guile_minor_version=`$GUILE -c "(display (minor-version))"` - _guile_micro_version=`$GUILE -c "(display (micro-version))"` - _guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version" - - AC_MSG_CHECKING([for Guile version >= $_guile_required_version]) - _major_version=`echo $_guile_required_version | cut -d . -f 1` - _minor_version=`echo $_guile_required_version | cut -d . -f 2` - _micro_version=`echo $_guile_required_version | cut -d . -f 3` - if test "$_guile_major_version" -gt "$_major_version"; then - true - elif test "$_guile_major_version" -eq "$_major_version"; then - if test "$_guile_minor_version" -gt "$_minor_version"; then - true - elif test "$_guile_minor_version" -eq "$_minor_version"; then - if test -n "$_micro_version"; then - if test "$_guile_micro_version" -lt "$_micro_version"; then - AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) - fi - fi - elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then - # Allow prereleases that have the right effective version. - true - else - as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 - fi - elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then - # Allow prereleases that have the right effective version. - true - else - AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) - fi - AC_MSG_RESULT([$_guile_prog_version]) - - AC_PATH_PROG(GUILD,[guild$_guile_suffix]) - AC_SUBST(GUILD) - - AC_PATH_PROG(GUILE_CONFIG,[guile-config$_guile_suffix]) - AC_SUBST(GUILE_CONFIG) - if test -n "$GUILD"; then - GUILE_TOOLS=$GUILD - else - AC_PATH_PROG(GUILE_TOOLS,[guile-tools$_guile_suffix]) - fi - AC_SUBST(GUILE_TOOLS) - ]) - -# GUILE_CHECK -- evaluate Guile Scheme code and capture the return value -# -# Usage: GUILE_CHECK_RETVAL(var,check) -# -# @var{var} is a shell variable name to be set to the return value. -# @var{check} is a Guile Scheme expression, evaluated with "$GUILE -c", and -# returning either 0 or non-#f to indicate the check passed. -# Non-0 number or #f indicates failure. -# Avoid using the character "#" since that confuses autoconf. -# -AC_DEFUN([GUILE_CHECK], - [AC_REQUIRE([GUILE_PROGS]) - $GUILE -c "$2" > /dev/null 2>&1 - $1=$? - ]) - -# GUILE_MODULE_CHECK -- check feature of a Guile Scheme module -# -# Usage: GUILE_MODULE_CHECK(var,module,featuretest,description) -# -# @var{var} is a shell variable name to be set to "yes" or "no". -# @var{module} is a list of symbols, like: (ice-9 common-list). -# @var{featuretest} is an expression acceptable to GUILE_CHECK, q.v. -# @var{description} is a present-tense verb phrase (passed to AC_MSG_CHECKING). -# -AC_DEFUN([GUILE_MODULE_CHECK], - [AC_MSG_CHECKING([if $2 $4]) - GUILE_CHECK($1,(use-modules $2) (exit ((lambda () $3)))) - if test "$$1" = "0" ; then $1=yes ; else $1=no ; fi - AC_MSG_RESULT($$1) - ]) - -# GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module -# -# Usage: GUILE_MODULE_AVAILABLE(var,module) -# -# @var{var} is a shell variable name to be set to "yes" or "no". -# @var{module} is a list of symbols, like: (ice-9 common-list). -# -AC_DEFUN([GUILE_MODULE_AVAILABLE], - [GUILE_MODULE_CHECK($1,$2,0,is available) - ]) - -# GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable -# -# Usage: GUILE_MODULE_REQUIRED(symlist) -# -# @var{symlist} is a list of symbols, WITHOUT surrounding parens, -# like: ice-9 common-list. -# -AC_DEFUN([GUILE_MODULE_REQUIRED], - [GUILE_MODULE_AVAILABLE(ac_guile_module_required, ($1)) - if test "$ac_guile_module_required" = "no" ; then - AC_MSG_ERROR([required guile module not found: ($1)]) - fi - ]) - -# GUILE_MODULE_EXPORTS -- check if a module exports a variable -# -# Usage: GUILE_MODULE_EXPORTS(var,module,modvar) -# -# @var{var} is a shell variable to be set to "yes" or "no". -# @var{module} is a list of symbols, like: (ice-9 common-list). -# @var{modvar} is the Guile Scheme variable to check. -# -AC_DEFUN([GUILE_MODULE_EXPORTS], - [GUILE_MODULE_CHECK($1,$2,$3,exports `$3') - ]) - -# GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable -# -# Usage: GUILE_MODULE_REQUIRED_EXPORT(module,modvar) -# -# @var{module} is a list of symbols, like: (ice-9 common-list). -# @var{modvar} is the Guile Scheme variable to check. -# -AC_DEFUN([GUILE_MODULE_REQUIRED_EXPORT], - [GUILE_MODULE_EXPORTS(guile_module_required_export,$1,$2) - if test "$guile_module_required_export" = "no" ; then - AC_MSG_ERROR([module $1 does not export $2; required]) - fi - ]) - -## guile.m4 ends here |