guile: Add binding for 'gnutls_x509_crt_get_fingerprint'.

* guile/src/core.c (MAX_HASH_SIZE): New constant.
(scm_gnutls_x509_certificate_fingerprint): New function.
* guile/modules/gnutls.in: Export 'x509-certificate-fingerprint'.
* guile/tests/x509-certificates.scm: Test 'x509-certificate-fingerprint'.
(%sha1-fingerprint): New constant.
(u8vector->hex-string): New procedure.

Signed-off-by: Simon South <simon@simonsouth.net>

3 files changed, 57 insertions, 5 deletions

diff --git a/guile/modules/gnutls.in b/guile/modules/gnutls.in
index 6461c404a2..56b4068e07 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!
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..984ec6fe3b 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,19 @@
   ;; The certificate's signature algorithm.
   sign-algorithm/rsa-sha1)
 
+(define %sha1-fingerprint
+  ;; The certificate's SHA-1 fingerprint.
+  "7c55df47de718869d55998ee1e9301331ccd0601")
+
 
 (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 +84,9 @@
                               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))))))
 
 ;;; arch-tag: eef09b52-30e8-472a-8b93-cb636434f6eb