;;; Help produce Guile wrappers for GnuTLS types.
;;;
;;; GnuTLS --- Guile bindings for GnuTLS.
;;; Copyright (C) 2007-2025 Free Software Foundation, Inc.
;;;
;;; This file is part of Guile-GnuTLS.
;;;
;;; 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 2.1 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, see <https://www.gnu.org/licenses/>.

;;; 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))


;;;
;;; 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))))


;;;
;;; 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~%"))


;;;
;;; 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 %public-key-smob
  (make-smob-type "gnutls_pubkey_t" 'public-key
                  "gnutls_pubkey_deinit"))

(define %private-key-smob
  (make-smob-type "gnutls_privkey_t" 'private-key
                  "gnutls_privkey_deinit"))

(define %hmac-smob
  ;; The hmac object in gnutls does not contain enough information to be used
  ;; safely. The output length of the hmac algorithm cannot be found from an
  ;; hmac state. So, we define our own compound structure that packs the hmac
  ;; state and the algorithm.
  (make-smob-type "scm_gnutls_hmac_and_algorithm_t" 'hmac
                  "hmac_and_algorithm_deinit"))

(define %hash-smob
  ;; The hash object suffers from the same problem as the hmac object.
  (make-smob-type "scm_gnutls_hash_and_algorithm_t" 'hash
                  "hash_and_algorithm_deinit"))

(define %aead-cipher-smob
  (make-smob-type "scm_gnutls_aead_cipher_and_algorithm_t" 'aead-cipher
                  "aead_cipher_and_algorithm_deinit"))

(define %cipher-smob
  (make-smob-type "scm_gnutls_cipher_and_algorithm_t" 'cipher-hd
                  "cipher_and_algorithm_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 %hmac-smob
        %hash-smob %aead-cipher-smob %cipher-smob
        %public-key-smob %private-key-smob

        %openpgp-certificate-smob %openpgp-private-key-smob
        %openpgp-keyring-smob))


;;; Local Variables:
;;; mode: scheme
;;; coding: utf-8
;;; End:

;;; arch-tag: 26bf79ef-6dee-45f2-9e9d-2d209c518278
