# GnuTLS --- Guile bindings for GnuTLS.
-# Copyright (C) 2007-2012, 2016 Free Software Foundation, Inc.
+# Copyright (C) 2007-2012, 2016, 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
tests/errors.scm \
tests/x509-certificates.scm \
tests/x509-auth.scm \
+ tests/reauth.scm \
tests/priorities.scm
if ENABLE_SRP
;; sessions
session?
- make-session bye handshake rehandshake
+ make-session bye handshake rehandshake reauthenticate
alert-get alert-send
session-cipher session-kx session-mac session-protocol
session-compression-method session-certificate-type
;; enum->string functions
cipher->string kx->string params->string credentials->string
mac->string digest->string compression-method->string
- connection-end->string alert-level->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
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
#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)
(define %gnutls-enums
;; All enums.
(list %cipher-enum %kx-enum %params-enum %credentials-enum %mac-enum
- %digest-enum %compression-method-enum %connection-end-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
#undef FUNC_NAME
-SCM_DEFINE (scm_gnutls_make_session, "make-session", 1, 0, 0,
- (SCM end),
+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}.")
+ "@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;
+ 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 ();
- err = gnutls_init (&c_session, c_end);
+ 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);
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,
--- /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))))))
projects / thirdparty / gnutls.git / commitdiff
