guile: Add support for post-handshake reauthentication.

* guile/modules/gnutls/build/enums.scm (%connection-flag-enum): New
variable.
(%gnutls-enums): Add it.
* guile/modules/gnutls.in: Export 'reauthenticate',
'connection-flag->string', and all the 'connection-flag/' bindings.
* guile/src/core.c (scm_gnutls_make_session): Add rest arguments FLAGS
and honor it.
(scm_gnutls_reauthenticate): New function.
* guile/tests/reauth.scm: New file.
* guile/Makefile.am (TESTS): Add it.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

5 files changed, 199 insertions, 9 deletions

diff --git a/guile/Makefile.am b/guile/Makefile.am
index 13bdeee774..0b19bad90f 100644
--- a/guile/Makefile.am
+++ b/guile/Makefile.am
@@ -1,5 +1,5 @@
 #  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
@@ -101,6 +101,7 @@ TESTS =						\
   tests/errors.scm				\
   tests/x509-certificates.scm			\
   tests/x509-auth.scm				\
+  tests/reauth.scm				\
   tests/priorities.scm
 
 if ENABLE_SRP
diff --git a/guile/modules/gnutls.in b/guile/modules/gnutls.in
index e935d96270..eed0ffcf8e 100644
--- a/guile/modules/gnutls.in
+++ b/guile/modules/gnutls.in
@@ -25,7 +25,7 @@
 
            ;; 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
@@ -101,7 +101,8 @@
            ;; 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
@@ -155,6 +156,25 @@
            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
diff --git a/guile/modules/gnutls/build/enums.scm b/guile/modules/gnutls/build/enums.scm
index 7bfb5d2533..6554099f06 100644
--- a/guile/modules/gnutls/build/enums.scm
+++ b/guile/modules/gnutls/build/enums.scm
@@ -341,6 +341,30 @@
                   #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)
@@ -681,7 +705,8 @@ application-error-min
 (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
diff --git a/guile/src/core.c b/guile/src/core.c
index a3b3e9f740..dc6611a4d7 100644
--- a/guile/src/core.c
+++ b/guile/src/core.c
@@ -129,21 +129,27 @@ SCM_DEFINE (scm_gnutls_version, "gnutls-version", 0, 0, 0,
 
 #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);
@@ -209,7 +215,24 @@ SCM_DEFINE (scm_gnutls_rehandshake, "rehandshake", 1, 0, 0,
 
   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,
diff --git a/guile/tests/reauth.scm b/guile/tests/reauth.scm
new file mode 100644
index 0000000000..0f768e514e
--- /dev/null
+++ b/guile/tests/reauth.scm
@@ -0,0 +1,121 @@
+;;; 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))))))