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
doc/gnutls-extra-api.texi
doc/gnutls.fn
doc/gnutls.fns
-doc/gnutls-guile.html
doc/gnutls.html
doc/gnutls.info*
doc/gnutls.ky
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
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
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
- 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)
- 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
- 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)
- 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
- 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)
- 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
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=""
--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
- 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=""
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=""
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=""
- 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=""
- 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
- 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
# - .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
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=""
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=""
# 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
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=""
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:
+++ /dev/null
-^m4/guile.m4
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
--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
SUBDIRS += tests fuzz
endif
-if HAVE_GUILE
-SUBDIRS += guile
-endif
-
if ENABLE_MANPAGES
SUBDIRS += doc/manpages
endif
@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; \
* 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.
* [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)
```
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
```
```
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
```
# 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$$
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 := \
["$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)
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
libdane/includes/Makefile
libdane/gnutls-dane.pc
gl/Makefile
- guile/Makefile
- guile/src/Makefile
lib/Makefile
lib/accelerated/Makefile
lib/accelerated/x86/Makefile
AC_MSG_NOTICE([Optional libraries:
- Guile wrappers: $opt_guile_bindings
C++ library: $use_cxx
DANE library: $enable_dane
OpenSSL compat: $enable_openssl
`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:
-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
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 = \
$< $@
-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 \
.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' $@
# 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
+++ /dev/null
-;;; 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:
+++ /dev/null
-\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
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
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
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
+++ /dev/null
-;; 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))))
+++ /dev/null
-*.x
-*.i.c
-smobs.h
-enums.h
-extra-smobs.h
-extra-enums.h
-pre-inst-guile
+++ /dev/null
-# 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" "$@"
-
-\f
-#
-# 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
-
-\f
-#
-# 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
+++ /dev/null
-;;; 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
+++ /dev/null
-;;; 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.
-;;;
-
-\f
-;;;
-;;; Enumeration tools.
-;;;
-
-(define-record-type <enum-type>
- (%make-enum-type subsystem c-type enum-map get-name value-prefix)
- enum-type?
- (subsystem enum-type-subsystem)
- (enum-map enum-type-value-alist)
- (c-type enum-type-c-type)
- (get-name enum-type-get-name-function)
- (value-prefix enum-type-value-prefix))
-
-
-(define (make-enum-type subsystem c-type values get-name . value-prefix)
- ;; Return a new enumeration type.
- (let ((value-prefix (if (null? value-prefix)
- #f
- (car value-prefix))))
- (%make-enum-type subsystem c-type
- (make-enum-map subsystem values value-prefix)
- get-name value-prefix)))
-
-
-(define (make-enum-map subsystem values value-prefix)
- ;; Return an alist mapping C enum values (strings) to Scheme symbols.
- (define (value-symbol->string value)
- (string-upcase (scheme-symbol->c-name value)))
-
- (define (make-c-name value)
- (case value-prefix
- ((#f)
- ;; automatically derive the C value name.
- (string-append "GNUTLS_" (string-upcase (symbol->string subsystem))
- "_" (value-symbol->string value)))
- (else
- (string-append value-prefix (value-symbol->string value)))))
-
- (map (lambda (value)
- (cons (make-c-name value) value))
- values))
-
-(define (enum-type-smob-name enum)
- ;; Return the C name of the smob type for ENUM.
- (string-append "scm_tc16_gnutls_"
- (scheme-symbol->c-name (enum-type-subsystem enum))
- "_enum"))
-
-(define (enum-type-smob-list enum)
- ;; Return the name of the C variable holding a list of value (SMOBs) for
- ;; ENUM. This list is used when converting from C to Scheme.
- (string-append "scm_gnutls_"
- (scheme-symbol->c-name (enum-type-subsystem enum))
- "_enum_values"))
-
-(define (enum-type-to-c-function enum)
- ;; Return the name of the C `scm_to_' function for ENUM.
- (string-append "scm_to_gnutls_"
- (scheme-symbol->c-name (enum-type-subsystem enum))))
-
-(define (enum-type-from-c-function enum)
- ;; Return the name of the C `scm_from_' function for ENUM.
- (string-append "scm_from_gnutls_"
- (scheme-symbol->c-name (enum-type-subsystem enum))))
-
-(define (enum-type-automatic-get-name-function enum)
- ;; Return the name of an automatically-generated C function that returns a
- ;; string describing the given enum value of type ENUM.
- (string-append "scm_gnutls_"
- (scheme-symbol->c-name (enum-type-subsystem enum))
- "_to_c_string"))
-
-\f
-;;;
-;;; C code generation.
-;;;
-
-(define (output-enum-smob-definitions enum port)
- (let ((smob (enum-type-smob-name enum))
- (get-name (enum-type-get-name-function enum)))
- (format port "SCM_GLOBAL_SMOB (~a, \"~a\", 0);~%"
- smob (enum-type-subsystem enum))
- (format port "SCM ~a = SCM_EOL;~%"
- (enum-type-smob-list enum))
-
- (if (not (string? get-name))
- ;; Generate a "get name" function.
- (output-enum-get-name-function enum port))
-
- ;; Generate the printer and `->string' function.
- (let ((get-name (or get-name
- (enum-type-automatic-get-name-function enum))))
- (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
- ;; SMOB printer.
- (format port "SCM_SMOB_PRINT (~a, ~a_print, obj, port, pstate)~%{~%"
- smob subsystem)
- (format port " scm_puts (\"#<gnutls-~a-enum \", port);~%"
- (enum-type-subsystem enum))
- (format port " scm_puts (~a (~a (obj, 1, \"~a_print\")), port);~%"
- get-name (enum-type-to-c-function enum) subsystem)
- (format port " scm_puts (\">\", port);~%")
- (format port " return 1;~%")
- (format port "}~%")
-
- ;; Enum-to-string.
- (format port "SCM_DEFINE (scm_gnutls_~a_to_string, \"~a->string\", "
- subsystem (enum-type-subsystem enum))
- (format port "1, 0, 0,~%")
- (format port " (SCM enumval),~%")
- (format port " \"Return a string describing ")
- (format port "@var{enumval}, a @code{~a} value.\")~%"
- (enum-type-subsystem enum))
- (format port "#define FUNC_NAME s_scm_gnutls_~a_to_string~%"
- subsystem)
- (format port "{~%")
- (format port " ~a c_enum;~%"
- (enum-type-c-type enum))
- (format port " const char *c_string;~%")
- (format port " c_enum = ~a (enumval, 1, FUNC_NAME);~%"
- (enum-type-to-c-function enum))
- (format port " c_string = ~a (c_enum);~%"
- get-name)
- (format port " return (scm_from_locale_string (c_string));~%")
- (format port "}~%")
- (format port "#undef FUNC_NAME~%")))))
-
-(define (output-enum-definitions enum port)
- ;; Output to PORT the Guile C code that defines the values of ENUM-ALIST.
- (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
- (format port " enum_values = SCM_EOL;~%")
- (for-each (lambda (c+scheme)
- (format port " SCM_NEWSMOB (enum_smob, ~a, "
- (enum-type-smob-name enum))
- (format port "(scm_t_bits) ~a);~%"
- (car c+scheme))
- (format port " enum_values = scm_cons (enum_smob, ")
- (format port "enum_values);~%")
- (format port " scm_c_define (\"~a\", enum_smob);~%"
- (symbol-append (enum-type-subsystem enum) '/
- (cdr c+scheme))))
- (enum-type-value-alist enum))
- (format port " ~a = scm_permanent_object (enum_values);~%"
- (enum-type-smob-list enum))))
-
-(define (output-enum-declarations enum port)
- ;; Issue header file declarations needed for the inline functions that
- ;; handle ENUM values.
- (format port "SCM_API scm_t_bits ~a;~%"
- (enum-type-smob-name enum))
- (format port "SCM_API SCM ~a;~%"
- (enum-type-smob-list enum)))
-
-(define (output-enum-definition-function enums port)
- ;; Output a C function that does all the `scm_c_define ()' for the enums
- ;; listed in ENUMS.
- (format port "static inline void~%scm_gnutls_define_enums (void)~%{~%")
- (format port " SCM enum_values, enum_smob;~%")
- (for-each (lambda (enum)
- (output-enum-definitions enum port))
- enums)
- (format port "}~%"))
-
-(define (output-c->enum-converter enum port)
- ;; Output a C->Scheme converted for ENUM. This works by walking the list
- ;; of available enum values (SMOBs) for ENUM and then returning the
- ;; matching SMOB, so that users can then compare enums using `eq?'. While
- ;; this may look inefficient, this shouldn't be a problem since (i)
- ;; conversion in that direction is rarely needed and (ii) the number of
- ;; values per enum is expected to be small.
- (format port "static inline SCM~%~a (~a c_obj)~%{~%"
- (enum-type-from-c-function enum)
- (enum-type-c-type enum))
- (format port " SCM pair, result = SCM_BOOL_F;~%")
- (format port " for (pair = ~a; scm_is_pair (pair); "
- (enum-type-smob-list enum))
- (format port "pair = SCM_CDR (pair))~%")
- (format port " {~%")
- (format port " SCM enum_smob;~%")
- (format port " enum_smob = SCM_CAR (pair);~%")
- (format port " if ((~a) SCM_SMOB_DATA (enum_smob) == c_obj)~%"
- (enum-type-c-type enum))
- (format port " {~%")
- (format port " result = enum_smob;~%")
- (format port " break;~%")
- (format port " }~%")
- (format port " }~%")
- (format port " return result;~%")
- (format port "}~%"))
-
-(define (output-enum->c-converter enum port)
- (let* ((c-type-name (enum-type-c-type enum))
- (subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
-
- (format port
- "static inline ~a~%~a (SCM obj, unsigned pos, const char *func)~%"
- c-type-name (enum-type-to-c-function enum))
- (format port "#define FUNC_NAME func~%")
- (format port "{~%")
- (format port " SCM_VALIDATE_SMOB (pos, obj, ~a);~%"
- (string-append "gnutls_" subsystem "_enum"))
- (format port " return ((~a) SCM_SMOB_DATA (obj));~%"
- c-type-name)
- (format port "}~%")
- (format port "#undef FUNC_NAME~%")))
-
-(define (output-enum-get-name-function enum port)
- ;; Output a C function that, when passed a C ENUM value, returns a C string
- ;; representing that value.
- (let ((function (enum-type-automatic-get-name-function enum)))
- (format port
- "static const char *~%~a (~a c_obj)~%"
- function (enum-type-c-type enum))
- (format port "{~%")
- (format port " static const struct ")
- (format port "{ ~a value; const char *name; } "
- (enum-type-c-type enum))
- (format port "table[] =~%")
- (format port " {~%")
- (for-each (lambda (c+scheme)
- (format port " { ~a, \"~a\" },~%"
- (car c+scheme) (cdr c+scheme)))
- (enum-type-value-alist enum))
- (format port " };~%")
- (format port " unsigned i;~%")
- (format port " const char *name = NULL;~%")
- (format port " for (i = 0; i < ~a; i++)~%"
- (length (enum-type-value-alist enum)))
- (format port " {~%")
- (format port " if (table[i].value == c_obj)~%")
- (format port " {~%")
- (format port " name = table[i].name;~%")
- (format port " break;~%")
- (format port " }~%")
- (format port " }~%")
- (format port " return (name);~%")
- (format port "}~%")))
-
-\f
-;;;
-;;; Actual enumerations.
-;;;
-
-(define %cipher-enum
- (make-enum-type 'cipher "gnutls_cipher_algorithm_t"
- '(null arcfour 3des-cbc aes-128-cbc aes-256-cbc
- arcfour-40 rc2-40-cbc des-cbc)
- "gnutls_cipher_get_name"))
-
-(define %kx-enum
- (make-enum-type 'kx "gnutls_kx_algorithm_t"
- '(rsa dhe-dss dhe-rsa anon-dh srp rsa-export
- srp-rsa srp-dss psk dhe-dss)
- "gnutls_kx_get_name"))
-
-(define %params-enum
- (make-enum-type 'params "gnutls_params_type_t"
- '(rsa-export dh)
- #f))
-
-(define %credentials-enum
- (make-enum-type 'credentials "gnutls_credentials_type_t"
- '(certificate anon srp psk ia)
- #f
- "GNUTLS_CRD_"))
-
-(define %mac-enum
- (make-enum-type 'mac "gnutls_mac_algorithm_t"
- '(unknown null md5 sha1 rmd160 md2)
- "gnutls_mac_get_name"))
-
-(define %digest-enum
- (make-enum-type 'digest "gnutls_digest_algorithm_t"
- '(null md5 sha1 rmd160 md2 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
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; SMOB types.
-;;;
-
-(define-record-type <smob-type>
- (%make-smob-type c-name scm-name free-function)
- smob-type?
- (c-name smob-type-c-name)
- (scm-name smob-type-scheme-name)
- (free-function smob-type-free-function))
-
-(define (make-smob-type c-name scm-name . free-function)
- (%make-smob-type c-name scm-name
- (if (null? free-function)
- (string-append "gnutls_"
- (scheme-symbol->c-name scm-name)
- "_deinit")
- (car free-function))))
-
-(define (smob-type-tag type)
- ;; Return the name of the C variable holding the type tag for TYPE.
- (string-append "scm_tc16_gnutls_"
- (scheme-symbol->c-name (smob-type-scheme-name type))))
-
-(define (smob-type-predicate-scheme-name type)
- ;; Return a string denoting the Scheme name of TYPE's type predicate.
- (string-append (symbol->string (smob-type-scheme-name type)) "?"))
-
-(define (smob-type-to-c-function type)
- ;; Return the name of the C `scm_to_' function for SMOB.
- (string-append "scm_to_gnutls_"
- (scheme-symbol->c-name (smob-type-scheme-name type))))
-
-(define (smob-type-from-c-function type)
- ;; Return the name of the C `scm_from_' function for SMOB.
- (string-append "scm_from_gnutls_"
- (scheme-symbol->c-name (smob-type-scheme-name type))))
-
-\f
-;;;
-;;; C code generation.
-;;;
-
-(define (output-smob-type-definition type port)
- (format port "SCM_GLOBAL_SMOB (~a, \"~a\", 0);~%"
- (smob-type-tag type)
- (smob-type-scheme-name type))
-
- (format port "SCM_SMOB_FREE (~a, ~a_free, obj)~%{~%"
- (smob-type-tag type)
- (scheme-symbol->c-name (smob-type-scheme-name type)))
- (format port " ~a c_obj;~%"
- (smob-type-c-name type))
- (format port " c_obj = (~a) SCM_SMOB_DATA (obj);~%"
- (smob-type-c-name type))
- (format port " ~a (c_obj);~%"
- (smob-type-free-function type))
- (format port " return 0;~%")
- (format port "}~%"))
-
-(define (output-smob-type-declaration type port)
- ;; Issue a header file declaration for the SMOB type tag of TYPE.
- (format port "SCM_API scm_t_bits ~a;~%"
- (smob-type-tag type)))
-
-(define (output-smob-type-predicate type port)
- (define (texi-doc-string)
- (string-append "Return true if @var{obj} is of type @code{"
- (symbol->string (smob-type-scheme-name type))
- "}."))
-
- (let ((c-name (string-append "scm_gnutls_"
- (string-map (lambda (chr)
- (if (char=? chr #\-)
- #\_
- chr))
- (symbol->string
- (smob-type-scheme-name type)))
- "_p")))
- (format port "SCM_DEFINE (~a, \"~a\", 1, 0, 0,~%"
- c-name (smob-type-predicate-scheme-name type))
- (format port " (SCM obj),~%")
- (format port " \"~a\")~%"
- (texi-doc-string))
- (format port "#define FUNC_NAME s_~a~%"
- c-name)
- (format port "{~%")
- (format port " return (scm_from_bool (SCM_SMOB_PREDICATE (~a, obj)));~%"
- (smob-type-tag type))
- (format port "}~%#undef FUNC_NAME~%")))
-
-(define (output-c->smob-converter type port)
- (format port "static inline SCM~%~a (~a c_obj)~%{~%"
- (smob-type-from-c-function type)
- (smob-type-c-name type))
- (format port " SCM_RETURN_NEWSMOB (~a, (scm_t_bits) c_obj);~%"
- (smob-type-tag type))
- (format port "}~%"))
-
-(define (output-smob->c-converter type port)
- (format port "static inline ~a~%~a (SCM obj, "
- (smob-type-c-name type)
- (smob-type-to-c-function type))
- (format port "unsigned pos, const char *func)~%")
- (format port "#define FUNC_NAME func~%")
- (format port "{~%")
- (format port " SCM_VALIDATE_SMOB (pos, obj, ~a);~%"
- (string-append "gnutls_"
- (scheme-symbol->c-name (smob-type-scheme-name type))))
- (format port " return ((~a) SCM_SMOB_DATA (obj));~%"
- (smob-type-c-name type))
- (format port "}~%")
- (format port "#undef FUNC_NAME~%"))
-
-\f
-;;;
-;;; Actual SMOB types.
-;;;
-
-(define %session-smob
- (make-smob-type "gnutls_session_t" 'session
- "gnutls_deinit"))
-
-(define %anonymous-client-credentials-smob
- (make-smob-type "gnutls_anon_client_credentials_t" 'anonymous-client-credentials
- "gnutls_anon_free_client_credentials"))
-
-(define %anonymous-server-credentials-smob
- (make-smob-type "gnutls_anon_server_credentials_t" 'anonymous-server-credentials
- "gnutls_anon_free_server_credentials"))
-
-(define %dh-parameters-smob
- (make-smob-type "gnutls_dh_params_t" 'dh-parameters
- "gnutls_dh_params_deinit"))
-
-(define %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
+++ /dev/null
-;;; 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:
+++ /dev/null
-;;; 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.
-;;;
-
-\f
-;;;
-;;; Utilities.
-;;;
-
-(define (scheme-symbol->c-name sym)
- ;; Turn SYM, a symbol denoting a Scheme name, into a string denoting a C
- ;; name.
- (string-map (lambda (chr)
- (if (eq? chr #\-) #\_ chr))
- (symbol->string sym)))
-
-
-;;; Local Variables:
-;;; mode: scheme
-;;; coding: latin-1
-;;; End:
-
-;;; arch-tag: 56919ee1-7cce-46b9-b90f-ae6fbcfe4159
+++ /dev/null
-;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA.
-;;; Copyright (C) 2007-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))
-
-
-\f
-;;;
-;;; This module will be removed in a future version.
-;;;
-
-(issue-deprecation-warning
- "The (gnutls extra) module is deprecated; use (gnutls) instead")
-
-\f
-;;;
-;;; 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:
+++ /dev/null
-C Documentation Snarfing Modules
---------------------------------
-
-This modules provide allow the extraction of Texinfo documentation
-strings from C files---this is usually referred to as ``doc snarfing''
-in Guile terms.
-
-They were stolen from Guile-Reader 0.3:
-
- https://www.nongnu.org/guile-reader/
-
-It was only slightly modified.
-
-
-Ludovic Courtès <ludo@chbouib.org>.
+++ /dev/null
-;;; c-snarf.scm -- Parsing documentation "snarffed" from C files.
-;;;
-;;; Copyright 2006-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:
-
-
-\f
-;;;
-;;; 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)))
-
-\f
-;;;
-;;; 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
+++ /dev/null
-;;; 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:
-
-\f
-;;;
-;;; Utility.
-;;;
-
-(define (schemify-name str)
- "Turn @var{str}, a C variable or function name, into a more ``Schemey''
-form, e.g., one with dashed instead of underscores, etc."
- (string-map (lambda (chr)
- (if (eq? chr #\_)
- #\-
- chr))
- (if (string-suffix? "_p" str)
- (string-append (substring str 0
- (- (string-length str) 2))
- "?")
- str)))
-
-\f
-;;;
-;;; Issuing Texinfo and GDF-formatted doc (i.e., `guile-procedures.texi').
-;;; GDF = Guile Documentation Format
-;;;
-
-(define *document-c-functions?*
- ;; Whether to mention C function names along with Scheme procedure names.
- (make-parameter #t))
-
-(define (scheme-procedure-texi-line proc-name args
- required-args optional-args
- rest-arg?)
- "Return a Texinfo string describing the Scheme procedure named
-@var{proc-name}, whose arguments are listed in @var{args} (a list of strings)
-and whose signature is defined by @var{required-args}, @var{optional-args}
-and @var{rest-arg?}."
- (string-append "@deffn {Scheme Procedure} " proc-name " "
- (string-join (take args required-args) " ")
- (string-join (take (drop args required-args)
- (+ optional-args
- (if rest-arg? 1 0)))
- " [" 'prefix)
- (if rest-arg? "...]" "")
- (make-string optional-args #\])))
-
-(define (procedure-gdf-string proc-doc)
- "Issue a Texinfo/GDF docstring corresponding to @var{proc-doc}, a
-documentation alist as returned by @code{parse-snarfed-line}. To produce
-actual GDF-formatted doc, the resulting string must be processed by
-@code{makeinfo}."
- (let* ((proc-name (assq-ref proc-doc 'scheme-name))
- (args (assq-ref proc-doc 'arguments))
- (signature (assq-ref proc-doc 'signature))
- (required-args (assq-ref signature 'required))
- (optional-args (assq-ref signature 'optional))
- (rest-arg? (assq-ref signature 'rest?))
- (location (assq-ref proc-doc 'location))
- (file-name (car location))
- (line (cadr location))
- (documentation (assq-ref proc-doc 'documentation)))
- (string-append "\f" ;; form feed
- proc-name (string #\newline)
- (format #f "@c snarfed from ~a:~a~%"
- file-name line)
-
- (scheme-procedure-texi-line proc-name
- (map schemify-name args)
- required-args optional-args
- rest-arg?)
-
- (string #\newline)
- documentation (string #\newline)
- "@end deffn" (string #\newline))))
-
-(define (procedure-texi-documentation proc-doc)
- "Issue a Texinfo docstring corresponding to @var{proc-doc}, a documentation
-alist as returned by @var{parse-snarfed-line}. The resulting Texinfo string
-is meant for use in a manual since it also documents the corresponding C
-function."
- (let* ((proc-name (assq-ref proc-doc 'scheme-name))
- (c-name (assq-ref proc-doc 'c-name))
- (args (assq-ref proc-doc 'arguments))
- (signature (assq-ref proc-doc 'signature))
- (required-args (assq-ref signature 'required))
- (optional-args (assq-ref signature 'optional))
- (rest-arg? (assq-ref signature 'rest?))
- (location (assq-ref proc-doc 'location))
- (file-name (car location))
- (line (cadr location))
- (documentation (assq-ref proc-doc 'documentation)))
- (string-append (string #\newline)
- (format #f "@c snarfed from ~a:~a~%"
- file-name line)
-
- ;; document the Scheme procedure
- (scheme-procedure-texi-line proc-name
- (map schemify-name args)
- required-args optional-args
- rest-arg?)
- (string #\newline)
-
- (if (*document-c-functions?*)
- (string-append
- ;; document the C function
- "@deffnx {C Function} " c-name " ("
- (if (null? args)
- "void"
- (string-join (map (lambda (arg)
- (string-append "SCM " arg))
- args)
- ", "))
- ")" (string #\newline))
- "")
-
- documentation (string #\newline)
- "@end deffn" (string #\newline))))
-
-\f
-;;;
-;;; Very high-level interface.
-;;;
-
-(define (output-procedure-texi-documentation-from-c-file c-file cpp cflags
- port)
- (for-each (lambda (texi-string)
- (display texi-string port))
- (map procedure-texi-documentation
- (run-cpp-and-extract-snarfing c-file cpp cflags))))
-
-
-;;; output.scm ends here
-
-;;; Local Variables:
-;;; mode: scheme
-;;; coding: latin-1
-;;; End:
-
-;;; arch-tag: 20ca493a-6f1a-4d7f-9d24-ccce0d32df49
+++ /dev/null
-#!/bin/sh
-
-# Copyright (C) 2007-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@ "$@"
+++ /dev/null
-# 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)
+++ /dev/null
-/* 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"
-\f
-
-#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);
-}
-
-\f
-
-
-/* Bindings. */
-
-/* Mark the data associated with SESSION. */
-SCM_SMOB_MARK (scm_tc16_gnutls_session, mark_session, session)
-{
- gnutls_session_t c_session;
-
- c_session = scm_to_gnutls_session (session, 1, "mark_session");
-
- return (SCM_GNUTLS_SESSION_DATA (c_session));
-}
-
-SCM_DEFINE (scm_gnutls_version, "gnutls-version", 0, 0, 0,
- (void),
- "Return a string denoting the version number of the underlying "
- "GnuTLS library, e.g., @code{\"1.7.2\"}.")
-#define FUNC_NAME s_scm_gnutls_version
-{
- return (scm_from_locale_string (gnutls_check_version (NULL)));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_make_session, "make-session", 1, 0, 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'. */
-\f
-
-/* Session accessors. */
-
-SCM_DEFINE (scm_gnutls_session_cipher, "session-cipher", 1, 0, 0,
- (SCM session), "Return @var{session}'s cipher.")
-#define FUNC_NAME s_scm_gnutls_session_cipher
-{
- gnutls_session_t c_session;
- gnutls_cipher_algorithm_t c_cipher;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_cipher = gnutls_cipher_get (c_session);
-
- return (scm_from_gnutls_cipher (c_cipher));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_kx, "session-kx", 1, 0, 0,
- (SCM session), "Return @var{session}'s kx.")
-#define FUNC_NAME s_scm_gnutls_session_kx
-{
- gnutls_session_t c_session;
- gnutls_kx_algorithm_t c_kx;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_kx = gnutls_kx_get (c_session);
-
- return (scm_from_gnutls_kx (c_kx));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_mac, "session-mac", 1, 0, 0,
- (SCM session), "Return @var{session}'s MAC.")
-#define FUNC_NAME s_scm_gnutls_session_mac
-{
- gnutls_session_t c_session;
- gnutls_mac_algorithm_t c_mac;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_mac = gnutls_mac_get (c_session);
-
- return (scm_from_gnutls_mac (c_mac));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_compression_method,
- "session-compression-method", 1, 0, 0,
- (SCM session), "Return @var{session}'s compression method.")
-#define FUNC_NAME s_scm_gnutls_session_compression_method
-{
- gnutls_session_t c_session;
- gnutls_compression_method_t c_comp;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_comp = gnutls_compression_get (c_session);
-
- return (scm_from_gnutls_compression_method (c_comp));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_certificate_type,
- "session-certificate-type", 1, 0, 0,
- (SCM session), "Return @var{session}'s certificate type.")
-#define FUNC_NAME s_scm_gnutls_session_certificate_type
-{
- gnutls_session_t c_session;
- gnutls_certificate_type_t c_cert;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_cert = gnutls_certificate_type_get (c_session);
-
- return (scm_from_gnutls_certificate_type (c_cert));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_protocol, "session-protocol", 1, 0, 0,
- (SCM session), "Return the protocol used by @var{session}.")
-#define FUNC_NAME s_scm_gnutls_session_protocol
-{
- gnutls_session_t c_session;
- gnutls_protocol_t c_protocol;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_protocol = gnutls_protocol_get_version (c_session);
-
- return (scm_from_gnutls_protocol (c_protocol));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_authentication_type,
- "session-authentication-type",
- 1, 0, 0,
- (SCM session),
- "Return the authentication type (a @code{credential-type} value) "
- "used by @var{session}.")
-#define FUNC_NAME s_scm_gnutls_session_authentication_type
-{
- gnutls_session_t c_session;
- gnutls_credentials_type_t c_auth;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_auth = gnutls_auth_get_type (c_session);
-
- return (scm_from_gnutls_credentials (c_auth));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_server_authentication_type,
- "session-server-authentication-type",
- 1, 0, 0,
- (SCM session),
- "Return the server authentication type (a "
- "@code{credential-type} value) used in @var{session}.")
-#define FUNC_NAME s_scm_gnutls_session_server_authentication_type
-{
- gnutls_session_t c_session;
- gnutls_credentials_type_t c_auth;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_auth = gnutls_auth_server_get_type (c_session);
-
- return (scm_from_gnutls_credentials (c_auth));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_client_authentication_type,
- "session-client-authentication-type",
- 1, 0, 0,
- (SCM session),
- "Return the client authentication type (a "
- "@code{credential-type} value) used in @var{session}.")
-#define FUNC_NAME s_scm_gnutls_session_client_authentication_type
-{
- gnutls_session_t c_session;
- gnutls_credentials_type_t c_auth;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_auth = gnutls_auth_client_get_type (c_session);
-
- return (scm_from_gnutls_credentials (c_auth));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_peer_certificate_chain,
- "session-peer-certificate-chain",
- 1, 0, 0,
- (SCM session),
- "Return the a list of certificates in raw format (u8vectors) "
- "where the first one is the peer's certificate. In the case "
- "of OpenPGP, there is always exactly one certificate. In the "
- "case of X.509, subsequent certificates indicate form a "
- "certificate chain. Return the empty list if no certificate "
- "was sent.")
-#define FUNC_NAME s_scm_gnutls_session_peer_certificate_chain
-{
- SCM result;
- gnutls_session_t c_session;
- const gnutls_datum_t *c_cert;
- unsigned int c_list_size;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- c_cert = gnutls_certificate_get_peers (c_session, &c_list_size);
-
- if (EXPECT_FALSE (c_cert == NULL))
- result = SCM_EOL;
- else
- {
- SCM pair;
- unsigned int i;
-
- result = scm_make_list (scm_from_uint (c_list_size), SCM_UNSPECIFIED);
-
- for (i = 0, pair = result; i < c_list_size; i++, pair = SCM_CDR (pair))
- {
- unsigned char *c_cert_copy;
-
- c_cert_copy = (unsigned char *) malloc (c_cert[i].size);
- if (EXPECT_FALSE (c_cert_copy == NULL))
- scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
-
- memcpy (c_cert_copy, c_cert[i].data, c_cert[i].size);
-
- SCM_SETCAR (pair, scm_take_u8vector (c_cert_copy, c_cert[i].size));
- }
- }
-
- return result;
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_session_our_certificate_chain,
- "session-our-certificate-chain",
- 1, 0, 0,
- (SCM session),
- "Return our certificate chain for @var{session} (as sent to "
- "the peer) in raw format (a u8vector). In the case of OpenPGP "
- "there is exactly one certificate. Return the empty list "
- "if no certificate was used.")
-#define FUNC_NAME s_scm_gnutls_session_our_certificate_chain
-{
- SCM result;
- gnutls_session_t c_session;
- const gnutls_datum_t *c_cert;
- unsigned char *c_cert_copy;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
-
- /* XXX: Currently, the C function actually returns only one certificate.
- Future versions of the API may provide the full certificate chain, as
- for `gnutls_certificate_get_peers ()'. */
- c_cert = gnutls_certificate_get_ours (c_session);
-
- if (EXPECT_FALSE (c_cert == NULL))
- result = SCM_EOL;
- else
- {
- c_cert_copy = (unsigned char *) malloc (c_cert->size);
- if (EXPECT_FALSE (c_cert_copy == NULL))
- scm_gnutls_error (GNUTLS_E_MEMORY_ERROR, FUNC_NAME);
-
- memcpy (c_cert_copy, c_cert->data, c_cert->size);
-
- result = scm_list_1 (scm_take_u8vector (c_cert_copy, c_cert->size));
- }
-
- return result;
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_set_server_session_certificate_request_x,
- "set-server-session-certificate-request!",
- 2, 0, 0,
- (SCM session, SCM request),
- "Tell how @var{session}, a server-side session, should deal "
- "with certificate requests. @var{request} should be either "
- "@code{certificate-request/request} or "
- "@code{certificate-request/require}.")
-#define FUNC_NAME s_scm_gnutls_set_server_session_certificate_request_x
-{
- gnutls_session_t c_session;
- gnutls_certificate_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
-\f
-
-/* 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
-\f
-
-/* Record layer. */
-
-SCM_DEFINE (scm_gnutls_record_send, "record-send", 2, 0, 0,
- (SCM session, SCM array),
- "Send the record constituted by @var{array} through "
- "@var{session}.")
-#define FUNC_NAME s_scm_gnutls_record_send
-{
- SCM result;
- ssize_t c_result;
- gnutls_session_t c_session;
- scm_t_array_handle c_handle;
- const char *c_array;
- size_t c_len;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
- SCM_VALIDATE_ARRAY (2, array);
-
- c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
-
- c_result = gnutls_record_send (c_session, c_array, c_len);
-
- scm_gnutls_release_array (&c_handle);
-
- if (EXPECT_TRUE (c_result >= 0))
- result = scm_from_ssize_t (c_result);
- else
- scm_gnutls_error (c_result, FUNC_NAME);
-
- return (result);
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_record_receive_x, "record-receive!", 2, 0, 0,
- (SCM session, SCM array),
- "Receive data from @var{session} into @var{array}, a uniform "
- "homogeneous array. Return the number of bytes actually "
- "received.")
-#define FUNC_NAME s_scm_gnutls_record_receive_x
-{
- SCM result;
- ssize_t c_result;
- gnutls_session_t c_session;
- scm_t_array_handle c_handle;
- char *c_array;
- size_t c_len;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
- SCM_VALIDATE_ARRAY (2, array);
-
- c_array = scm_gnutls_get_writable_array (array, &c_handle, &c_len,
- FUNC_NAME);
-
- c_result = gnutls_record_recv (c_session, c_array, c_len);
-
- scm_gnutls_release_array (&c_handle);
-
- if (EXPECT_TRUE (c_result >= 0))
- result = scm_from_ssize_t (c_result);
- else
- scm_gnutls_error (c_result, FUNC_NAME);
-
- return (result);
-}
-
-#undef FUNC_NAME
-
-
-/* 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
-}
-\f
-
-/* Transport. */
-
-SCM_DEFINE (scm_gnutls_set_session_transport_fd_x,
- "set-session-transport-fd!", 2, 0, 0, (SCM session, SCM fd),
- "Use file descriptor @var{fd} as the underlying transport for "
- "@var{session}.")
-#define FUNC_NAME s_scm_gnutls_set_session_transport_fd_x
-{
- gnutls_session_t c_session;
- int c_fd;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
- c_fd = (int) scm_to_uint (fd);
-
- gnutls_transport_set_ptr (c_session,
- (gnutls_transport_ptr_t) (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
-\f
-
-/* Diffie-Hellman. */
-
-typedef int (*pkcs_export_function_t) (void *, gnutls_x509_crt_fmt_t,
- unsigned char *, size_t *);
-
-/* Hint for the `scm_gc' functions. */
-static const char pkcs_export_gc_hint[] = "gnutls-pkcs-export";
-
-
-/* Export DH/RSA parameters PARAMS through EXPORT, using format FORMAT.
- Return a `u8vector'. */
-static inline SCM
-pkcs_export_parameters (pkcs_export_function_t export,
- void *params, gnutls_x509_crt_fmt_t format,
- const char *func_name)
-#define FUNC_NAME func_name
-{
- int err;
- unsigned char *output;
- size_t output_len, output_total_len = 4096;
-
- output = (unsigned char *) scm_gc_malloc (output_total_len,
- pkcs_export_gc_hint);
- do
- {
- output_len = output_total_len;
- err = export (params, format, output, &output_len);
-
- if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
- {
- output = scm_gc_realloc (output, output_total_len,
- output_total_len * 2, pkcs_export_gc_hint);
- output_total_len *= 2;
- }
- }
- while (err == GNUTLS_E_SHORT_MEMORY_BUFFER);
-
- if (EXPECT_FALSE (err))
- {
- scm_gc_free (output, output_total_len, pkcs_export_gc_hint);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- if (output_len != output_total_len)
- /* Shrink the output buffer. */
- output = scm_gc_realloc (output, output_total_len,
- output_len, pkcs_export_gc_hint);
-
- return (scm_take_u8vector (output, output_len));
-}
-
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_gnutls_make_dh_parameters, "make-dh-parameters", 1, 0, 0,
- (SCM bits), "Return new Diffie-Hellman parameters.")
-#define FUNC_NAME s_scm_gnutls_make_dh_parameters
-{
- int err;
- unsigned c_bits;
- gnutls_dh_params_t c_dh_params;
-
- c_bits = scm_to_uint (bits);
-
- err = gnutls_dh_params_init (&c_dh_params);
- if (EXPECT_FALSE (err))
- scm_gnutls_error (err, FUNC_NAME);
-
- err = gnutls_dh_params_generate2 (c_dh_params, c_bits);
- if (EXPECT_FALSE (err))
- {
- gnutls_dh_params_deinit (c_dh_params);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- return (scm_from_gnutls_dh_parameters (c_dh_params));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_pkcs3_import_dh_parameters,
- "pkcs3-import-dh-parameters",
- 2, 0, 0,
- (SCM array, SCM format),
- "Import Diffie-Hellman parameters in PKCS3 format (further "
- "specified by @var{format}, an @code{x509-certificate-format} "
- "value) from @var{array} (a homogeneous array) and return a "
- "new @code{dh-params} object.")
-#define FUNC_NAME s_scm_gnutls_pkcs3_import_dh_parameters
-{
- int err;
- gnutls_x509_crt_fmt_t c_format;
- gnutls_dh_params_t c_dh_params;
- scm_t_array_handle c_handle;
- const char *c_array;
- size_t c_len;
- gnutls_datum_t c_datum;
-
- c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
-
- c_array = scm_gnutls_get_array (array, &c_handle, &c_len, FUNC_NAME);
- c_datum.data = (unsigned char *) c_array;
- c_datum.size = c_len;
-
- err = gnutls_dh_params_init (&c_dh_params);
- if (EXPECT_FALSE (err))
- {
- scm_gnutls_release_array (&c_handle);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- err = gnutls_dh_params_import_pkcs3 (c_dh_params, &c_datum, c_format);
- scm_gnutls_release_array (&c_handle);
-
- if (EXPECT_FALSE (err))
- {
- gnutls_dh_params_deinit (c_dh_params);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- return (scm_from_gnutls_dh_parameters (c_dh_params));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_pkcs3_export_dh_parameters,
- "pkcs3-export-dh-parameters",
- 2, 0, 0,
- (SCM dh_params, SCM format),
- "Export Diffie-Hellman parameters @var{dh_params} in PKCS3 "
- "format according for @var{format} (an "
- "@code{x509-certificate-format} value). Return a "
- "@code{u8vector} containing the result.")
-#define FUNC_NAME s_scm_gnutls_pkcs3_export_dh_parameters
-{
- SCM result;
- gnutls_dh_params_t c_dh_params;
- gnutls_x509_crt_fmt_t c_format;
-
- c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 1, FUNC_NAME);
- c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
-
- result = pkcs_export_parameters ((pkcs_export_function_t)
- gnutls_dh_params_export_pkcs3,
- (void *) c_dh_params, c_format, FUNC_NAME);
-
- return (result);
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_set_session_dh_prime_bits_x,
- "set-session-dh-prime-bits!", 2, 0, 0,
- (SCM session, SCM bits),
- "Use @var{bits} DH prime bits for @var{session}.")
-#define FUNC_NAME s_scm_gnutls_set_session_dh_prime_bits_x
-{
- unsigned int c_bits;
- gnutls_session_t c_session;
-
- c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);
- c_bits = scm_to_uint (bits);
-
- gnutls_dh_set_prime_bits (c_session, c_bits);
-
- return SCM_UNSPECIFIED;
-}
-
-#undef FUNC_NAME
-\f
-
-/* Anonymous credentials. */
-
-SCM_DEFINE (scm_gnutls_make_anon_server_credentials,
- "make-anonymous-server-credentials",
- 0, 0, 0, (void), "Return anonymous server credentials.")
-#define FUNC_NAME s_scm_gnutls_make_anon_server_credentials
-{
- int err;
- gnutls_anon_server_credentials_t c_cred;
-
- err = gnutls_anon_allocate_server_credentials (&c_cred);
-
- if (EXPECT_FALSE (err))
- scm_gnutls_error (err, FUNC_NAME);
-
- return (scm_from_gnutls_anonymous_server_credentials (c_cred));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_make_anon_client_credentials,
- "make-anonymous-client-credentials",
- 0, 0, 0, (void), "Return anonymous client credentials.")
-#define FUNC_NAME s_scm_gnutls_make_anon_client_credentials
-{
- int err;
- gnutls_anon_client_credentials_t c_cred;
-
- err = gnutls_anon_allocate_client_credentials (&c_cred);
-
- if (EXPECT_FALSE (err))
- scm_gnutls_error (err, FUNC_NAME);
-
- return (scm_from_gnutls_anonymous_client_credentials (c_cred));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_set_anonymous_server_dh_parameters_x,
- "set-anonymous-server-dh-parameters!", 2, 0, 0,
- (SCM cred, SCM dh_params),
- "Set the Diffie-Hellman parameters of anonymous server "
- "credentials @var{cred}.")
-#define FUNC_NAME s_scm_gnutls_set_anonymous_server_dh_parameters_x
-{
- gnutls_dh_params_t c_dh_params;
- gnutls_anon_server_credentials_t c_cred;
-
- c_cred = scm_to_gnutls_anonymous_server_credentials (cred, 1, FUNC_NAME);
- c_dh_params = scm_to_gnutls_dh_parameters (dh_params, 2, FUNC_NAME);
-
- gnutls_anon_set_server_dh_params (c_cred, c_dh_params);
- register_weak_reference (cred, dh_params);
-
- return SCM_UNSPECIFIED;
-}
-
-#undef FUNC_NAME
-
-\f
-
-/* Certificate credentials. */
-
-typedef
- int (*certificate_set_file_function_t) (gnutls_certificate_credentials_t,
- const char *,
- gnutls_x509_crt_fmt_t);
-
-typedef
- int (*certificate_set_data_function_t) (gnutls_certificate_credentials_t,
- const gnutls_datum_t *,
- gnutls_x509_crt_fmt_t);
-
-/* Helper function to implement the `set-file!' functions. */
-static 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
-\f
-
-/* 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 */
-\f
-
-/* PSK credentials. */
-
-SCM_DEFINE (scm_gnutls_make_psk_server_credentials,
- "make-psk-server-credentials",
- 0, 0, 0, (void), "Return new PSK server credentials.")
-#define FUNC_NAME s_scm_gnutls_make_psk_server_credentials
-{
- int err;
- gnutls_psk_server_credentials_t c_cred;
-
- err = gnutls_psk_allocate_server_credentials (&c_cred);
- if (EXPECT_FALSE (err))
- scm_gnutls_error (err, FUNC_NAME);
-
- return (scm_from_gnutls_psk_server_credentials (c_cred));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_set_psk_server_credentials_file_x,
- "set-psk-server-credentials-file!",
- 2, 0, 0,
- (SCM cred, SCM file),
- "Use @var{file} as the password file for PSK server "
- "credentials @var{cred}.")
-#define FUNC_NAME s_scm_gnutls_set_psk_server_credentials_file_x
-{
- int err;
- gnutls_psk_server_credentials_t c_cred;
- char *c_file;
- size_t c_file_len;
-
- c_cred = scm_to_gnutls_psk_server_credentials (cred, 1, FUNC_NAME);
- SCM_VALIDATE_STRING (2, file);
-
- c_file_len = scm_c_string_length (file);
- c_file = 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
-\f
-
-/* X.509 certificates. */
-
-SCM_DEFINE (scm_gnutls_import_x509_certificate, "import-x509-certificate",
- 2, 0, 0,
- (SCM data, SCM format),
- "Return a new X.509 certificate object resulting from the "
- "import of @var{data} (a uniform array) according to "
- "@var{format}.")
-#define FUNC_NAME s_scm_gnutls_import_x509_certificate
-{
- int err;
- gnutls_x509_crt_t c_cert;
- gnutls_x509_crt_fmt_t c_format;
- gnutls_datum_t c_data_d;
- scm_t_array_handle c_data_handle;
- const char *c_data;
- size_t c_data_len;
-
- SCM_VALIDATE_ARRAY (1, data);
- c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
-
- c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
- FUNC_NAME);
- c_data_d.data = (unsigned char *) c_data;
- c_data_d.size = c_data_len;
-
- err = gnutls_x509_crt_init (&c_cert);
- if (EXPECT_FALSE (err))
- {
- scm_gnutls_release_array (&c_data_handle);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- err = gnutls_x509_crt_import (c_cert, &c_data_d, c_format);
- scm_gnutls_release_array (&c_data_handle);
-
- if (EXPECT_FALSE (err))
- {
- gnutls_x509_crt_deinit (c_cert);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- return (scm_from_gnutls_x509_certificate (c_cert));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_import_x509_private_key, "import-x509-private-key",
- 2, 0, 0,
- (SCM data, SCM format),
- "Return a new X.509 private key object resulting from the "
- "import of @var{data} (a uniform array) according to "
- "@var{format}.")
-#define FUNC_NAME s_scm_gnutls_import_x509_private_key
-{
- int err;
- gnutls_x509_privkey_t c_key;
- gnutls_x509_crt_fmt_t c_format;
- gnutls_datum_t c_data_d;
- scm_t_array_handle c_data_handle;
- const char *c_data;
- size_t c_data_len;
-
- SCM_VALIDATE_ARRAY (1, data);
- c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
-
- c_data = scm_gnutls_get_array (data, &c_data_handle, &c_data_len,
- FUNC_NAME);
- c_data_d.data = (unsigned char *) c_data;
- c_data_d.size = c_data_len;
-
- err = gnutls_x509_privkey_init (&c_key);
- if (EXPECT_FALSE (err))
- {
- scm_gnutls_release_array (&c_data_handle);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- err = gnutls_x509_privkey_import (c_key, &c_data_d, c_format);
- scm_gnutls_release_array (&c_data_handle);
-
- if (EXPECT_FALSE (err))
- {
- gnutls_x509_privkey_deinit (c_key);
- scm_gnutls_error (err, FUNC_NAME);
- }
-
- return (scm_from_gnutls_x509_private_key (c_key));
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_pkcs8_import_x509_private_key,
- "pkcs8-import-x509-private-key",
- 2, 2, 0,
- (SCM data, SCM format, SCM pass, SCM encrypted),
- "Return a new X.509 private key object resulting from the "
- "import of @var{data} (a uniform array) according to "
- "@var{format}. Optionally, if @var{pass} is not @code{#f}, "
- "it should be a string denoting a passphrase. "
- "@var{encrypted} tells whether the private key is encrypted "
- "(@code{#t} by default).")
-#define FUNC_NAME s_scm_gnutls_pkcs8_import_x509_private_key
-{
- int err;
- gnutls_x509_privkey_t c_key;
- gnutls_x509_crt_fmt_t c_format;
- unsigned int c_flags;
- gnutls_datum_t c_data_d;
- scm_t_array_handle c_data_handle;
- const char *c_data;
- char *c_pass;
- size_t c_data_len, c_pass_len;
-
- SCM_VALIDATE_ARRAY (1, data);
- c_format = scm_to_gnutls_x509_certificate_format (format, 2, FUNC_NAME);
- if ((pass == SCM_UNDEFINED) || (scm_is_false (pass)))
- c_pass = NULL;
- else
- {
- c_pass_len = scm_c_string_length (pass);
- c_pass = 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
-\f
-
-/* OpenPGP keys. */
-
-
-/* Maximum size we support for the name of OpenPGP keys. */
-#define GUILE_GNUTLS_MAX_OPENPGP_NAME_LENGTH 2048
-
-SCM_DEFINE (scm_gnutls_import_openpgp_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
-\f
-
-
-/* OpenPGP keyrings. */
-
-SCM_DEFINE (scm_gnutls_import_openpgp_keyring, "import-openpgp-keyring",
- 2, 0, 0,
- (SCM data, SCM format),
- "Import @var{data} (a u8vector) according to @var{format} "
- "and return the imported keyring.")
-#define FUNC_NAME s_scm_gnutls_import_openpgp_keyring
-{
- int err;
- gnutls_openpgp_keyring_t c_keyring;
- gnutls_openpgp_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
-\f
-
-/* 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
-
-\f
-
-/* Debugging. */
-
-static SCM log_procedure = SCM_BOOL_F;
-
-static void
-scm_gnutls_log (int level, const char *str)
-{
- if (scm_is_true (log_procedure))
- (void) scm_call_2 (log_procedure, scm_from_int (level),
- scm_from_locale_string (str));
-}
-
-SCM_DEFINE (scm_gnutls_set_log_procedure_x, "set-log-procedure!",
- 1, 0, 0,
- (SCM proc),
- "Use @var{proc} (a two-argument procedure) as the global "
- "GnuTLS log procedure.")
-#define FUNC_NAME s_scm_gnutls_set_log_procedure_x
-{
- SCM_VALIDATE_PROC (1, proc);
-
- if (scm_is_true (log_procedure))
- (void) scm_gc_unprotect_object (log_procedure);
-
- log_procedure = scm_gc_protect_object (proc);
- gnutls_global_set_log_function (scm_gnutls_log);
-
- return SCM_UNSPECIFIED;
-}
-
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_gnutls_set_log_level_x, "set-log-level!", 1, 0, 0,
- (SCM level),
- "Enable GnuTLS logging up to @var{level} (an integer).")
-#define FUNC_NAME s_scm_gnutls_set_log_level_x
-{
- unsigned int c_level;
-
- c_level = scm_to_uint (level);
- gnutls_global_set_log_level (c_level);
-
- return SCM_UNSPECIFIED;
-}
-
-#undef FUNC_NAME
-\f
-
-/* Initialization. */
-
-void
-scm_init_gnutls (void)
-{
-#include "core.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);
-}
+++ /dev/null
-/* 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
-
-\f
-
-void
-scm_init_gnutls_error (void)
-{
-#include "errors.x"
-}
-
-/* arch-tag: 48f07ecf-65c4-480c-b043-a51eab592d6b
- */
+++ /dev/null
-/* 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
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; 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
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; 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
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; 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
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; The program.
-;;;
-
-(define (main . args)
- (let ((port (current-output-port)))
- (for-each (lambda (type)
- (output-smob-type-definition type port)
- (output-smob-type-predicate type port))
- %gnutls-smobs)))
-
-(apply main (cdr (command-line)))
-
-;;; Local Variables:
-;;; mode: scheme
-;;; coding: latin-1
-;;; End:
-
-;;; arch-tag: 364811a0-6d0a-431a-ae50-d2f7dc529903
+++ /dev/null
-/* GnuTLS --- Guile bindings for GnuTLS.
- Copyright (C) 2007-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
- */
+++ /dev/null
-/* 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>
-\f
-
-/* Compiler twiddling. */
-
-#ifdef __GNUC__
-#define EXPECT __builtin_expect
-#define NO_RETURN __attribute__ ((__noreturn__))
-#else
-#define EXPECT(_expr, _value) (_expr)
-#define NO_RETURN
-#endif
-
-#define EXPECT_TRUE(_expr) EXPECT ((_expr), 1)
-#define EXPECT_FALSE(_expr) EXPECT ((_expr), 0)
-\f
-
-/* Arrays as byte vectors. */
-
-extern const char scm_gnutls_array_error_message[];
-
-/* Initialize C_HANDLE and C_LEN and return the contiguous C array
- corresponding to ARRAY. */
-static inline const char *
-scm_gnutls_get_array (SCM array, scm_t_array_handle * c_handle,
- size_t * c_len, const char *func_name)
-{
- const char *c_array = NULL;
- const scm_t_array_dim *c_dims;
-
- scm_array_get_handle (array, c_handle);
- c_dims = scm_array_handle_dims (c_handle);
- if ((scm_array_handle_rank (c_handle) != 1) || (c_dims->inc != 1))
- {
- scm_array_handle_release (c_handle);
- scm_misc_error (func_name, scm_gnutls_array_error_message,
- scm_list_1 (array));
- }
- else
- {
- size_t c_elem_size;
-
- c_elem_size = scm_array_handle_uniform_element_size (c_handle);
- *c_len = c_elem_size * (c_dims->ubnd - c_dims->lbnd + 1);
-
- c_array = (char *) scm_array_handle_uniform_elements (c_handle);
- }
-
- return (c_array);
-}
-
-/* Initialize C_HANDLE and C_LEN and return the contiguous C array
- corresponding to ARRAY. The returned array can be written to. */
-static inline char *
-scm_gnutls_get_writable_array (SCM array, scm_t_array_handle * c_handle,
- size_t * c_len, const char *func_name)
-{
- char *c_array = NULL;
- const scm_t_array_dim *c_dims;
-
- scm_array_get_handle (array, c_handle);
- c_dims = scm_array_handle_dims (c_handle);
- if ((scm_array_handle_rank (c_handle) != 1) || (c_dims->inc != 1))
- {
- scm_array_handle_release (c_handle);
- scm_misc_error (func_name, scm_gnutls_array_error_message,
- scm_list_1 (array));
- }
- else
- {
- size_t c_elem_size;
-
- c_elem_size = scm_array_handle_uniform_element_size (c_handle);
- *c_len = c_elem_size * (c_dims->ubnd - c_dims->lbnd + 1);
-
- c_array =
- (char *) scm_array_handle_uniform_writable_elements (c_handle);
- }
-
- return (c_array);
-}
-
-#define scm_gnutls_release_array scm_array_handle_release
-\f
-
-
-/* Type conversion. */
-
-/* Return a list corresponding to the key usage values ORed in C_USAGE. */
-SCM_API SCM scm_from_gnutls_key_usage_flags (unsigned int c_usage);
-
-#endif
-
-/* arch-tag: a33400bc-b5e3-429e-80e0-6ff14cab79e7
- */
+++ /dev/null
-;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-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
+++ /dev/null
------BEGIN DH PARAMETERS-----
-MIGGAoGAtkxw2jlsVCsrfLqxrN+IrF/3W8vVFvDzYbLmxi2GQv9s/PQGWP1d9i22
-P2DprfcJknWt7KhCI1SaYseOQIIIAYP78CfyIpGScW/vS8khrw0rlQiyeCvQgF3O
-GeGOEywcw+oQT4SmFOD7H0smJe2CNyjYpexBXQ/A0mbTF9QKm1cCAQU=
------END DH PARAMETERS-----
+++ /dev/null
-;;; 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
+++ /dev/null
-;;; 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
+++ /dev/null
-;;; 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))))))))
+++ /dev/null
-;;; 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))))
+++ /dev/null
-;;; 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))))))
+++ /dev/null
------BEGIN RSA PRIVATE KEY-----
-MIICWwIBAAKBgQDMOUZ0VEyX41ZLmZ7O0FPDaUYoJRFSoQF82TVt7zTcyLGTIoER
-QRpqpzA6DUyHZyX4bEodiCc4ks0efZYv7sjfz9pH1nEQiNe30ScFml79Yz8TmGtC
-aSiDEigZOq8F0NAzBgN9pfS5sxZw5yMK69m9DOUU/uQRJPM0nIaa6IHQ9QIDAQAB
-AoGAChNITcxr4/FwDDZFvrPJ8iHTN39OqbouQdvQdj4/KCZRlm31GqYQ2NKrPy3x
-SNvWpHkpNehF8RVS/85X1sEL0WJQ4h9/krWYsmO6h8ve/kMT6A2K2vVkv+Li/QBi
-6RyjP+FUcN5INe2cmRx7U04HaBoLyXg0wSOfRxpIez6nobkCQQDafbFQhGxqf0cS
-sMMu1jOX2HGGWwoPXWk8CANVmZWAZz3B507hc0di4ITgwTpw/JRr0RxzkEZQChLy
-RQDbW/5NAkEA70iPmsCVD7mSf8yo4h52YClmHhsHGkHD+kealg1Nq5LmnKoNftfa
-Ftg3wG8X7d86DU1pq1tJbRiUmxtgcGgBSQJABXNrUAnttn50ZHf6dpmrcddZhbOR
-va5j6LZ+ds09GJX6yXKe2isJFeNqDT1k2trCTSpLXmq0Bl0p+ddU3SQfZQJAXIXl
-KUSAHtV1pT8AqnZ29VXsq4Vt6KQ3YEZhqtW4C7jAvSEwGLTkGmM+o4URbqQbMVuW
-mXCx4qJXi+Y5Ex3UKQJAcuKAICXkM0Zi2aKE5Rv64w30VRbT2dNFGw2hWoHcQU9X
-S6Bf9LJmL8rJ8GOqwjEO8TbnAn+yNevd9zuFsGbw9A==
------END RSA PRIVATE KEY-----
+++ /dev/null
-;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-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
+++ /dev/null
-;;; 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
+++ /dev/null
-;;; 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
+++ /dev/null
------BEGIN CERTIFICATE-----
-MIICmDCCAgOgAwIBAgIBAjALBgkqhkiG9w0BAQUwUjELMAkGA1UEBhMCR1IxDDAK
-BgNVBAoTA0ZTRjEPMA0GA1UECxMGR05VVExTMSQwIgYDVQQDExtHTlVUTFMgSU5U
-RVJNRURJQVRFIFRFU1QgQ0EwHhcNMDQwNjI4MjI0NzAwWhcNMDcwMzIyMjI0NzAw
-WjBJMQswCQYDVQQGEwJHUjEMMAoGA1UEChMDRlNGMQ8wDQYDVQQLEwZHTlVUTFMx
-GzAZBgNVBAMTEkdOVVRMUyBURVNUIFNFUlZFUjCBnDALBgkqhkiG9w0BAQEDgYwA
-MIGIAoGA1chUqA9ib8S5GKd29B9d1rwgUncFhJPu0+RK8kOyOsV3qBdtdWeBSiGW
-So1RHkcmV9BlbUtmuHioAUkZPSo8gtoEy3JpSemW221BsjwITjGeZxZsb+4C/U2X
-HUIlO+jqBK5VYbpNXkP/2ofMkWWAZyKnI+PMIfFvv/cASsI0k48CAwEAAaOBjTCB
-ijAMBgNVHRMBAf8EAjAAMBQGA1UdEQQNMAuCCWxvY2FsaG9zdDATBgNVHSUEDDAK
-BggrBgEFBQcDATAPBgNVHQ8BAf8EBQMDB6AAMB0GA1UdDgQWBBTIZD/hlqUB89OE
-AwonwqGflkHtijAfBgNVHSMEGDAWgBQ2tS+xHdrw3r4o20MwGkLdzh5UlDALBgkq
-hkiG9w0BAQUDgYEAWPpWlUlvzDZRbpneYw8d6Q8On/ZPmSYBCm38vTKPEoNA6lW1
-WIc3Vbw5zOeSfDLifIWV2W/MqyjDo9MeWvSKpcUfRfibpXBgbA4RAGW0j2K1JQmE
-gP3k1vMicYzn5EglhZjoa9I+36a90vJraqzHQ7DrKtW0FDfW2GREzSh9RV8=
------END CERTIFICATE-----
-
------BEGIN CERTIFICATE-----
-MIICajCCAdWgAwIBAgIBATALBgkqhkiG9w0BAQUwRTELMAkGA1UEBhMCR1IxDDAK
-BgNVBAoTA0ZTRjEPMA0GA1UECxMGR05VVExTMRcwFQYDVQQDEw5HTlVUTFMgVEVT
-VCBDQTAeFw0wNDA2MjgyMjQ2MDBaFw0wNzAzMjMyMjQ2MDBaMFIxCzAJBgNVBAYT
-AkdSMQwwCgYDVQQKEwNGU0YxDzANBgNVBAsTBkdOVVRMUzEkMCIGA1UEAxMbR05V
-VExTIElOVEVSTUVESUFURSBURVNUIENBMIGcMAsGCSqGSIb3DQEBAQOBjAAwgYgC
-gYC0JKSLzHuiWK66XYOJk6AxDBo94hdCFnfIor7xnZkqTgiUQZhk9HDVmmz1+tLd
-yJk6r9PK+WMDDBkSOvT+SmQNd9mL2JzI+bJWwoB77aJ7vUI3/9+ugtffiapnX6wx
-vLyAxeJRyN0Q3oBHc6N2dJo9z1NHoFe8xipXXHOdxU1DAwIDAQABo2QwYjAPBgNV
-HRMBAf8EBTADAQH/MA8GA1UdDwEB/wQFAwMHBAAwHQYDVR0OBBYEFDa1L7Ed2vDe
-vijbQzAaQt3OHlSUMB8GA1UdIwQYMBaAFHnrG2+jZuZ54dHitdvaJwZFKQpIMAsG
-CSqGSIb3DQEBBQOBgQCi/SI37DrGCeZhtGhU2AyZFaqskRoFt4zAb9UYaGZaYEh5
-0VUZsA/Ol8jiiQTtiCokZswhSsn+2McZmcspKigsY2aEBrry+TGFWMnYu5j5kcwP
-1nVuHxLRwLt2rIsjgkeSNdHr8XHKi9/Roz/Gj86OnBAHwPt8WHfHK+63cMX1WA==
------END CERTIFICATE-----
+++ /dev/null
-;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-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
+++ /dev/null
------BEGIN RSA PRIVATE KEY-----
-MIICWwIBAAKBgQDVyFSoD2JvxLkYp3b0H13WvCBSdwWEk+7T5EryQ7I6xXeoF211
-Z4FKIZZKjVEeRyZX0GVtS2a4eKgBSRk9KjyC2gTLcmlJ6ZbbbUGyPAhOMZ5nFmxv
-7gL9TZcdQiU76OoErlVhuk1eQ//ah8yRZYBnIqcj48wh8W+/9wBKwjSTjwIDAQAB
-AoGAAn2Ueua++1Vb4K0mxh5NbhCAAeXwEwTULfTFaMAgJe4iADvRoyIDEBWHFjRC
-QyuKB1DetaDAwBprvqQW3q8MyGYD7P9h85Wfu/hpIYKTw9hNeph420aE8WXw2ygl
-TkJz3bzkMrXe/WjdhS1kTt8avCNQR/p0jM/UHvNze4oLc1ECQQDfammiczQFtj+F
-uf3CNcYwp5XNumF+pubdGb+UHUiHyCuVQxvm+LXgq8wXV/uXFLrp7FQFLCDQf0ji
-KDB2YQvRAkEA9PY/2AaGsU7j8ePwQbxCkwuj3hY6O6aNLIGxKxwZrzbob26c+tQk
-/++e0IXusIscBvcRV1Kg8Ff6fnw7/AdhXwJAG8qVbOuRmGk0BkwuFmPoeW3vNQgR
-X96O7po0qPBqVdRAU2rvzYtkCFxYqq0ilI0ekZtAfKxbeykaQaRkkKPaoQJAcifP
-yWJ/tu8z4DM7Ka+pFqTMwIllM1U3vFtv3LXezDE7AGDCyHKdB7MXcPXqj6nmCLMi
-swwiLLahAOBnUqk6xwJAJQ4pGcFFlCiIiVsq0wYSYmZUcRpSIInEQ0f8/xN6J22Z
-siP5vnJM3F7R6ciYTt2gzNci/W9cdZI2HxskkO5lbQ==
------END RSA PRIVATE KEY-----
+++ /dev/null
-## 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
projects / thirdparty / gnutls.git / commitdiff
