Merge branch 'wip/dueno/guile-fixes' into 'master'

guile: Add 'gnutls_x509_crt_get_fingerprint',  'GNUTLS_DIG_SHA256'

See merge request gnutls/gnutls!1461

4 files changed, 66 insertions, 6 deletions

diff --git a/guile/modules/gnutls.in b/guile/modules/gnutls.in
index 6461c404a2..0395196273 100644
--- a/guile/modules/gnutls.in
+++ b/guile/modules/gnutls.in
@@ -1,5 +1,6 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-2012, 2014, 2015, 2016, 2019 Free Software Foundation, Inc.
+;;; Copyright (C) 2007-2012, 2014, 2015, 2016, 2019, 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
@@ -89,7 +90,8 @@
            x509-certificate-subject-key-id
            x509-certificate-subject-alternative-name
            x509-certificate-public-key-algorithm x509-certificate-key-usage
-           import-x509-private-key pkcs8-import-x509-private-key
+           x509-certificate-fingerprint import-x509-private-key
+           pkcs8-import-x509-private-key
 
            ;; record layer
            record-send record-receive!
@@ -151,6 +153,7 @@
            digest/sha1
            digest/rmd160
            digest/md2
+           digest/sha256
            compression-method/null
            compression-method/deflate
            compression-method/lzo
diff --git a/guile/modules/gnutls/build/enums.scm b/guile/modules/gnutls/build/enums.scm
index 117059b0e3..4bfbb45549 100644
--- a/guile/modules/gnutls/build/enums.scm
+++ b/guile/modules/gnutls/build/enums.scm
@@ -325,7 +325,7 @@
 
 (define %digest-enum
   (make-enum-type 'digest "gnutls_digest_algorithm_t"
-                  '(null md5 sha1 rmd160 md2)
+                  '(null md5 sha1 rmd160 md2 sha256)
                   #f
                   "GNUTLS_DIG_"))
 
diff --git a/guile/src/core.c b/guile/src/core.c
index 0926dc8a97..b1dad0777f 100644
--- a/guile/src/core.c
+++ b/guile/src/core.c
@@ -50,6 +50,9 @@
    ? 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"
@@ -2891,6 +2894,40 @@ SCM_DEFINE (scm_gnutls_x509_certificate_subject_alternative_name,
 }
 
 #undef FUNC_NAME
+
+SCM_DEFINE (scm_gnutls_x509_certificate_fingerprint,
+            "x509-certificate-fingerprint",
+            2, 0, 0,
+            (SCM cert, SCM algo),
+            "Return the fingerprint (a u8vector) of the certificate "
+            "@var{cert}, computed using the digest algorithm @var{algo}.")
+#define FUNC_NAME s_scm_gnutls_x509_certificate_fingerprint
+{
+  int err;
+  SCM result;
+  gnutls_x509_crt_t c_cert;
+  gnutls_digest_algorithm_t c_algo;
+  uint8_t c_fpr[MAX_HASH_SIZE];
+  size_t c_fpr_len = MAX_HASH_SIZE;
+  scm_t_array_handle c_handle;
+
+  c_cert = scm_to_gnutls_x509_certificate (cert, 1, FUNC_NAME);
+  c_algo = scm_to_gnutls_digest (algo, 1, FUNC_NAME);
+
+  err = gnutls_x509_crt_get_fingerprint (c_cert, c_algo, &c_fpr, &c_fpr_len);
+  if (EXPECT_FALSE (err))
+    scm_gnutls_error (err, FUNC_NAME);
+
+  result = scm_make_u8vector (scm_from_uint(c_fpr_len), SCM_INUM0);
+  scm_array_get_handle (result, &c_handle);
+  memcpy (scm_array_handle_u8_writable_elements (&c_handle), &c_fpr,
+          c_fpr_len);
+  scm_array_handle_release (&c_handle);
+
+  return result;
+}
+
+#undef FUNC_NAME
 
 
 /* OpenPGP keys.  */
diff --git a/guile/tests/x509-certificates.scm b/guile/tests/x509-certificates.scm
index ccf871bd43..874c8ac5ea 100644
--- a/guile/tests/x509-certificates.scm
+++ b/guile/tests/x509-certificates.scm
@@ -1,5 +1,5 @@
 ;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007-2012 Free Software Foundation, Inc.
+;;; 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
@@ -25,7 +25,8 @@
 (use-modules (gnutls)
              (gnutls build tests)
              (srfi srfi-4)
-             (srfi srfi-11))
+             (srfi srfi-11)
+             (ice-9 format))
 
 (define %certificate-file
   (search-path %load-path "x509-certificate.pem"))
@@ -41,10 +42,23 @@
   ;; 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 ()
@@ -74,6 +88,12 @@
                               cert 0)))
                  (and (string? name)
                       (string?
-                       (x509-subject-alternative-name->string type)))))))))
+                       (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