guile: Remove GNUTLS_A_INNER_APPLICATION_FAILURE and GNUTLS_A_INNER_APPLICATION_VERIF...
[gnutls.git] / guile / modules / gnutls / build / enums.scm
blob91b61614e5f1a125e4add28ef1ecb4acb7e3f6a0
1 ;;; GnuTLS --- Guile bindings for GnuTLS.
2 ;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc.
3 ;;;
4 ;;; GnuTLS is free software; you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Lesser General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 2.1 of the License, or (at your option) any later version.
8 ;;;
9 ;;; GnuTLS is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12 ;;; Lesser General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Lesser General Public
15 ;;; License along with GnuTLS; if not, write to the Free Software
16 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
18 ;;; Written by Ludovic Courtès <ludo@chbouib.org>
20 (define-module (gnutls build enums)
21   :use-module (srfi srfi-1)
22   :use-module (srfi srfi-9)
23   :use-module (gnutls build utils)
25   :export (make-enum-type enum-type-subsystem enum-type-value-alist
26            enum-type-c-type enum-type-get-name-function
27            enum-type-automatic-get-name-function
28            enum-type-smob-name
29            enum-type-to-c-function enum-type-from-c-function
31            output-enum-smob-definitions output-enum-definitions
32            output-enum-declarations
33            output-enum-definition-function output-c->enum-converter
34            output-enum->c-converter
36            %cipher-enum %mac-enum %compression-method-enum %kx-enum
37            %protocol-enum %certificate-type-enum
39            %gnutls-enums %gnutls-extra-enums))
41 ;;;
42 ;;; This module helps with the creation of bindings for the C enumerate
43 ;;; types.  It aims at providing strong typing (i.e., one cannot use an
44 ;;; enumerate value of the wrong type) along with authenticity checks (i.e.,
45 ;;; values of a given enumerate type cannot be forged---for instance, one
46 ;;; cannot use some random integer as an enumerate value).  Additionally,
47 ;;; Scheme enums representing the same C enum value should be `eq?'.
48 ;;;
49 ;;; To that end, Scheme->C conversions are optimized (a simple
50 ;;; `SCM_SMOB_DATA'), since that is the most common usage pattern.
51 ;;; Conversely, C->Scheme conversions take time proportional to the number of
52 ;;; value in the enum type.
53 ;;;
56 ;;;
57 ;;; Enumeration tools.
58 ;;;
60 (define-record-type <enum-type>
61   (%make-enum-type subsystem c-type enum-map get-name value-prefix)
62   enum-type?
63   (subsystem    enum-type-subsystem)
64   (enum-map     enum-type-value-alist)
65   (c-type       enum-type-c-type)
66   (get-name     enum-type-get-name-function)
67   (value-prefix enum-type-value-prefix))
70 (define (make-enum-type subsystem c-type values get-name . value-prefix)
71   ;; Return a new enumeration type.
72   (let ((value-prefix (if (null? value-prefix)
73                           #f
74                           (car value-prefix))))
75     (%make-enum-type subsystem c-type
76                      (make-enum-map subsystem values value-prefix)
77                      get-name value-prefix)))
80 (define (make-enum-map subsystem values value-prefix)
81   ;; Return an alist mapping C enum values (strings) to Scheme symbols.
82   (define (value-symbol->string value)
83     (string-upcase (scheme-symbol->c-name value)))
85   (define (make-c-name value)
86     (case value-prefix
87       ((#f)
88        ;; automatically derive the C value name.
89        (string-append "GNUTLS_" (string-upcase (symbol->string subsystem))
90                       "_" (value-symbol->string value)))
91       (else
92        (string-append value-prefix (value-symbol->string value)))))
94   (map (lambda (value)
95          (cons (make-c-name value) value))
96        values))
98 (define (enum-type-smob-name enum)
99   ;; Return the C name of the smob type for ENUM.
100   (string-append "scm_tc16_gnutls_"
101                  (scheme-symbol->c-name (enum-type-subsystem enum))
102                  "_enum"))
104 (define (enum-type-smob-list enum)
105   ;; Return the name of the C variable holding a list of value (SMOBs) for
106   ;; ENUM.  This list is used when converting from C to Scheme.
107   (string-append "scm_gnutls_"
108                  (scheme-symbol->c-name (enum-type-subsystem enum))
109                  "_enum_values"))
111 (define (enum-type-to-c-function enum)
112   ;; Return the name of the C `scm_to_' function for ENUM.
113   (string-append "scm_to_gnutls_"
114                  (scheme-symbol->c-name (enum-type-subsystem enum))))
116 (define (enum-type-from-c-function enum)
117   ;; Return the name of the C `scm_from_' function for ENUM.
118   (string-append "scm_from_gnutls_"
119                  (scheme-symbol->c-name (enum-type-subsystem enum))))
121 (define (enum-type-automatic-get-name-function enum)
122   ;; Return the name of an automatically-generated C function that returns a
123   ;; string describing the given enum value of type ENUM.
124   (string-append "scm_gnutls_"
125                  (scheme-symbol->c-name (enum-type-subsystem enum))
126                  "_to_c_string"))
130 ;;; C code generation.
133 (define (output-enum-smob-definitions enum port)
134   (let ((smob     (enum-type-smob-name enum))
135         (get-name (enum-type-get-name-function enum)))
136     (format port "SCM_GLOBAL_SMOB (~a, \"~a\", 0);~%"
137             smob (enum-type-subsystem enum))
138     (format port "SCM ~a = SCM_EOL;~%"
139             (enum-type-smob-list enum))
141     (if (not (string? get-name))
142         ;; Generate a "get name" function.
143         (output-enum-get-name-function enum port))
145     ;; Generate the printer and `->string' function.
146     (let ((get-name (or get-name
147                         (enum-type-automatic-get-name-function enum))))
148       (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
149         ;; SMOB printer.
150         (format port "SCM_SMOB_PRINT (~a, ~a_print, obj, port, pstate)~%{~%"
151                 smob subsystem)
152         (format port "  scm_puts (\"#<gnutls-~a-enum \", port);~%"
153                 (enum-type-subsystem enum))
154         (format port "  scm_puts (~a (~a (obj, 1, \"~a_print\")), port);~%"
155                 get-name (enum-type-to-c-function enum) subsystem)
156         (format port "  scm_puts (\">\", port);~%")
157         (format port "  return 1;~%")
158         (format port "}~%")
160         ;; Enum-to-string.
161         (format port "SCM_DEFINE (scm_gnutls_~a_to_string, \"~a->string\", "
162                 subsystem (enum-type-subsystem enum))
163         (format port "1, 0, 0,~%")
164         (format port "            (SCM enumval),~%")
165         (format port "            \"Return a string describing ")
166         (format port "@var{enumval}, a @code{~a} value.\")~%"
167                 (enum-type-subsystem enum))
168         (format port "#define FUNC_NAME s_scm_gnutls_~a_to_string~%"
169                 subsystem)
170         (format port "{~%")
171         (format port "  ~a c_enum;~%"
172                 (enum-type-c-type enum))
173         (format port "  const char *c_string;~%")
174         (format port "  c_enum = ~a (enumval, 1, FUNC_NAME);~%"
175                 (enum-type-to-c-function enum))
176         (format port "  c_string = ~a (c_enum);~%"
177                 get-name)
178         (format port "  return (scm_from_locale_string (c_string));~%")
179         (format port "}~%")
180         (format port "#undef FUNC_NAME~%")))))
182 (define (output-enum-definitions enum port)
183   ;; Output to PORT the Guile C code that defines the values of ENUM-ALIST.
184   (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum))))
185     (format port "  enum_values = SCM_EOL;~%")
186     (for-each (lambda (c+scheme)
187                 (format port "  SCM_NEWSMOB (enum_smob, ~a, "
188                         (enum-type-smob-name enum))
189                 (format port "(scm_t_bits) ~a);~%"
190                         (car c+scheme))
191                 (format port "  enum_values = scm_cons (enum_smob, ")
192                 (format port "enum_values);~%")
193                 (format port "  scm_c_define (\"~a\", enum_smob);~%"
194                         (symbol-append (enum-type-subsystem enum) '/
195                                        (cdr c+scheme))))
196               (enum-type-value-alist enum))
197     (format port "  ~a = scm_permanent_object (enum_values);~%"
198             (enum-type-smob-list enum))))
200 (define (output-enum-declarations enum port)
201   ;; Issue header file declarations needed for the inline functions that
202   ;; handle ENUM values.
203   (format port "SCM_API scm_t_bits ~a;~%"
204           (enum-type-smob-name enum))
205   (format port "SCM_API SCM ~a;~%"
206           (enum-type-smob-list enum)))
208 (define (output-enum-definition-function enums port)
209   ;; Output a C function that does all the `scm_c_define ()' for the enums
210   ;; listed in ENUMS.
211   (format port "static inline void~%scm_gnutls_define_enums (void)~%{~%")
212   (format port "  SCM enum_values, enum_smob;~%")
213   (for-each (lambda (enum)
214               (output-enum-definitions enum port))
215             enums)
216   (format port "}~%"))
218 (define (output-c->enum-converter enum port)
219   ;; Output a C->Scheme converted for ENUM.  This works by walking the list
220   ;; of available enum values (SMOBs) for ENUM and then returning the
221   ;; matching SMOB, so that users can then compare enums using `eq?'.  While
222   ;; this may look inefficient, this shouldn't be a problem since (i)
223   ;; conversion in that direction is rarely needed and (ii) the number of
224   ;; values per enum is expected to be small.
225   (format port "static inline SCM~%~a (~a c_obj)~%{~%"
226           (enum-type-from-c-function enum)
227           (enum-type-c-type enum))
228   (format port "  SCM pair, result = SCM_BOOL_F;~%")
229   (format port "  for (pair = ~a; scm_is_pair (pair); "
230           (enum-type-smob-list enum))
231   (format port "pair = SCM_CDR (pair))~%")
232   (format port "    {~%")
233   (format port "      SCM enum_smob;~%")
234   (format port "      enum_smob = SCM_CAR (pair);~%")
235   (format port "      if ((~a) SCM_SMOB_DATA (enum_smob) == c_obj)~%"
236           (enum-type-c-type enum))
237   (format port "        {~%")
238   (format port "          result = enum_smob;~%")
239   (format port "          break;~%")
240   (format port "        }~%")
241   (format port "    }~%")
242   (format port "  return result;~%")
243   (format port "}~%"))
245 (define (output-enum->c-converter enum port)
246   (let* ((c-type-name (enum-type-c-type enum))
247          (subsystem   (scheme-symbol->c-name (enum-type-subsystem enum))))
249     (format port
250             "static inline ~a~%~a (SCM obj, unsigned pos, const char *func)~%"
251             c-type-name (enum-type-to-c-function enum))
252     (format port "#define FUNC_NAME func~%")
253     (format port "{~%")
254     (format port "  SCM_VALIDATE_SMOB (pos, obj, ~a);~%"
255             (string-append "gnutls_" subsystem "_enum"))
256     (format port "  return ((~a) SCM_SMOB_DATA (obj));~%"
257             c-type-name)
258     (format port "}~%")
259     (format port "#undef FUNC_NAME~%")))
261 (define (output-enum-get-name-function enum port)
262   ;; Output a C function that, when passed a C ENUM value, returns a C string
263   ;; representing that value.
264   (let ((function (enum-type-automatic-get-name-function enum)))
265     (format port
266             "static const char *~%~a (~a c_obj)~%"
267             function (enum-type-c-type enum))
268     (format port "{~%")
269     (format port "  static const struct ")
270     (format port "{ ~a value; const char *name; } "
271             (enum-type-c-type enum))
272     (format port "table[] =~%")
273     (format port "    {~%")
274     (for-each (lambda (c+scheme)
275                 (format port "       { ~a, \"~a\" },~%"
276                         (car c+scheme) (cdr c+scheme)))
277               (enum-type-value-alist enum))
278     (format port "    };~%")
279     (format port "  unsigned i;~%")
280     (format port "  const char *name = NULL;~%")
281     (format port "  for (i = 0; i < ~a; i++)~%"
282             (length (enum-type-value-alist enum)))
283     (format port "    {~%")
284     (format port "      if (table[i].value == c_obj)~%")
285     (format port "        {~%")
286     (format port "          name = table[i].name;~%")
287     (format port "          break;~%")
288     (format port "        }~%")
289     (format port "    }~%")
290     (format port "  return (name);~%")
291     (format port "}~%")))
295 ;;; Actual enumerations.
298 (define %cipher-enum
299   (make-enum-type 'cipher "gnutls_cipher_algorithm_t"
300                   '(null arcfour 3des-cbc aes-128-cbc aes-256-cbc
301                     arcfour-40 rc2-40-cbc des-cbc)
302                   "gnutls_cipher_get_name"))
304 (define %kx-enum
305   (make-enum-type 'kx "gnutls_kx_algorithm_t"
306                   '(rsa dhe-dss dhe-rsa anon-dh srp rsa-export
307                     srp-rsa srp-dss psk dhe-dss)
308                   "gnutls_kx_get_name"))
310 (define %params-enum
311   (make-enum-type 'params "gnutls_params_type_t"
312                   '(rsa-export dh)
313                   #f))
315 (define %credentials-enum
316   (make-enum-type 'credentials "gnutls_credentials_type_t"
317                   '(certificate anon srp psk ia)
318                   #f
319                   "GNUTLS_CRD_"))
321 (define %mac-enum
322   (make-enum-type 'mac "gnutls_mac_algorithm_t"
323                   '(unknown null md5 sha1 rmd160 md2)
324                   "gnutls_mac_get_name"))
326 (define %digest-enum
327   (make-enum-type 'digest "gnutls_digest_algorithm_t"
328                   '(null md5 sha1 rmd160 md2)
329                   #f
330                   "GNUTLS_DIG_"))
332 (define %compression-method-enum
333   (make-enum-type 'compression-method "gnutls_compression_method_t"
334                   '(null deflate lzo)
335                   "gnutls_compression_get_name"
336                   "GNUTLS_COMP_"))
338 (define %connection-end-enum
339   (make-enum-type 'connection-end "gnutls_connection_end_t"
340                   '(server client)
341                   #f
342                   "GNUTLS_"))
344 (define %alert-level-enum
345   (make-enum-type 'alert-level "gnutls_alert_level_t"
346                   '(warning fatal)
347                   #f
348                   "GNUTLS_AL_"))
350 (define %alert-description-enum
351   (make-enum-type 'alert-description "gnutls_alert_description_t"
352                   '(close-notify unexpected-message bad-record-mac
353 decryption-failed record-overflow decompression-failure handshake-failure
354 ssl3-no-certificate bad-certificate unsupported-certificate
355 certificate-revoked certificate-expired certificate-unknown illegal-parameter
356 unknown-ca access-denied decode-error decrypt-error export-restriction
357 protocol-version insufficient-security internal-error user-canceled
358 no-renegotiation unsupported-extension certificate-unobtainable
359 unrecognized-name unknown-psk-identity)
360                   #f
361                   "GNUTLS_A_"))
363 (define %handshake-description-enum
364   (make-enum-type 'handshake-description "gnutls_handshake_description_t"
365                   '(hello-request client-hello server-hello certificate-pkt
366                     server-key-exchange certificate-request server-hello-done
367                     certificate-verify client-key-exchange finished)
368                   #f
369                   "GNUTLS_HANDSHAKE_"))
371 (define %certificate-status-enum
372   (make-enum-type 'certificate-status "gnutls_certificate_status_t"
373                   '(invalid revoked signer-not-found signer-not-ca
374                     insecure-algorithm)
375                   #f
376                   "GNUTLS_CERT_"))
378 (define %certificate-request-enum
379   (make-enum-type 'certificate-request "gnutls_certificate_request_t"
380                   '(ignore request require)
381                   #f
382                   "GNUTLS_CERT_"))
384 ;; XXX: Broken naming convention.
385 ; (define %openpgp-key-status-enum
386 ;   (make-enum-type 'openpgp-key-status "gnutls_openpgp_key_status_t"
387 ;                   '(key fingerprint)
388 ;                   #f
389 ;                   "GNUTLS_OPENPGP_"))
391 (define %close-request-enum
392   (make-enum-type 'close-request "gnutls_close_request_t"
393                   '(rdwr wr) ;; FIXME: Check the meaning and rename
394                   #f
395                   "GNUTLS_SHUT_"))
397 (define %protocol-enum
398   (make-enum-type 'protocol "gnutls_protocol_t"
399                   '(ssl3 tls1-0 tls1-1 version-unknown)
400                   #f
401                   "GNUTLS_"))
403 (define %certificate-type-enum
404   (make-enum-type 'certificate-type "gnutls_certificate_type_t"
405                   '(x509 openpgp)
406                   "gnutls_certificate_type_get_name"
407                   "GNUTLS_CRT_"))
409 (define %x509-certificate-format-enum
410   (make-enum-type 'x509-certificate-format "gnutls_x509_crt_fmt_t"
411                   '(der pem)
412                   #f
413                   "GNUTLS_X509_FMT_"))
415 (define %x509-subject-alternative-name-enum
416   (make-enum-type 'x509-subject-alternative-name
417                   "gnutls_x509_subject_alt_name_t"
418                   '(dnsname rfc822name uri ipaddress)
419                   #f
420                   "GNUTLS_SAN_"))
422 (define %pk-algorithm-enum
423   (make-enum-type 'pk-algorithm "gnutls_pk_algorithm_t"
424                   '(unknown rsa dsa)
425                   "gnutls_pk_algorithm_get_name"
426                   "GNUTLS_PK_"))
428 (define %sign-algorithm-enum
429   (make-enum-type 'sign-algorithm "gnutls_sign_algorithm_t"
430                   '(unknown rsa-sha1 dsa-sha1 rsa-md5 rsa-md2
431                     rsa-rmd160)
432                   "gnutls_sign_algorithm_get_name"
433                   "GNUTLS_SIGN_"))
435 (define %psk-key-format-enum
436   (make-enum-type 'psk-key-format "gnutls_psk_key_flags"
437                   '(raw hex)
438                   #f
439                   "GNUTLS_PSK_KEY_"))
441 (define %key-usage-enum
442   ;; Not actually an enum on the C side.
443   (make-enum-type 'key-usage "int"
444                   '(digital-signature non-repudiation key-encipherment
445                     data-encipherment key-agreement key-cert-sign
446                     crl-sign encipher-only decipher-only)
447                   #f
448                   "GNUTLS_KEY_"))
450 (define %certificate-verify-enum
451   (make-enum-type 'certificate-verify "gnutls_certificate_verify_flags"
452                   '(disable-ca-sign allow-x509-v1-ca-crt
453                     do-not-allow-same allow-any-x509-v1-ca-crt
454                     allow-sign-rsa-md2 allow-sign-rsa-md5)
455                   #f
456                   "GNUTLS_VERIFY_"))
458 (define %error-enum
459   (make-enum-type 'error "int"
460                   '(
461 success
462 unknown-compression-algorithm
463 unknown-cipher-type
464 large-packet
465 unsupported-version-packet
466 unexpected-packet-length
467 invalid-session
468 fatal-alert-received
469 unexpected-packet
470 warning-alert-received
471 error-in-finished-packet
472 unexpected-handshake-packet
473 unknown-cipher-suite
474 unwanted-algorithm
475 mpi-scan-failed
476 decryption-failed
477 memory-error
478 decompression-failed
479 compression-failed
480 again
481 expired
482 db-error
483 srp-pwd-error
484 insufficient-credentials
485 insuficient-credentials
486 insufficient-cred
487 insuficient-cred
488 hash-failed
489 base64-decoding-error
490 mpi-print-failed
491 rehandshake
492 got-application-data
493 record-limit-reached
494 encryption-failed
495 pk-encryption-failed
496 pk-decryption-failed
497 pk-sign-failed
498 x509-unsupported-critical-extension
499 key-usage-violation
500 no-certificate-found
501 invalid-request
502 short-memory-buffer
503 interrupted
504 push-error
505 pull-error
506 received-illegal-parameter
507 requested-data-not-available
508 pkcs1-wrong-pad
509 received-illegal-extension
510 internal-error
511 dh-prime-unacceptable
512 file-error
513 too-many-empty-packets
514 unknown-pk-algorithm
515 init-libextra
516 library-version-mismatch
517 no-temporary-rsa-params
518 lzo-init-failed
519 no-compression-algorithms
520 no-cipher-suites
521 openpgp-getkey-failed
522 pk-sig-verify-failed
523 illegal-srp-username
524 srp-pwd-parsing-error
525 no-temporary-dh-params
526 asn1-element-not-found
527 asn1-identifier-not-found
528 asn1-der-error
529 asn1-value-not-found
530 asn1-generic-error
531 asn1-value-not-valid
532 asn1-tag-error
533 asn1-tag-implicit
534 asn1-type-any-error
535 asn1-syntax-error
536 asn1-der-overflow
537 openpgp-uid-revoked
538 certificate-error
539 x509-certificate-error
540 certificate-key-mismatch
541 unsupported-certificate-type
542 x509-unknown-san
543 openpgp-fingerprint-unsupported
544 x509-unsupported-attribute
545 unknown-algorithm
546 unknown-hash-algorithm
547 unknown-pkcs-content-type
548 unknown-pkcs-bag-type
549 invalid-password
550 mac-verify-failed
551 constraint-error
552 warning-ia-iphf-received
553 warning-ia-fphf-received
554 ia-verify-failed
555 base64-encoding-error
556 incompatible-gcrypt-library
557 incompatible-crypto-library
558 incompatible-libtasn1-library
559 openpgp-keyring-error
560 x509-unsupported-oid
561 random-failed
562 unimplemented-feature)
563                   "gnutls_strerror"
564                   "GNUTLS_E_"))
567 (define %openpgp-certificate-format-enum
568   (make-enum-type 'openpgp-certificate-format "gnutls_openpgp_crt_fmt_t"
569                   '(raw base64)
570                   #f
571                   "GNUTLS_OPENPGP_FMT_"))
574 (define %gnutls-enums
575   ;; All enums.
576   (list %cipher-enum %kx-enum %params-enum %credentials-enum %mac-enum
577         %digest-enum %compression-method-enum %connection-end-enum
578         %alert-level-enum %alert-description-enum %handshake-description-enum
579         %certificate-status-enum %certificate-request-enum
580         %close-request-enum %protocol-enum %certificate-type-enum
581         %x509-certificate-format-enum %x509-subject-alternative-name-enum
582         %pk-algorithm-enum %sign-algorithm-enum
583         %psk-key-format-enum %key-usage-enum %certificate-verify-enum
584         %error-enum))
586 (define %gnutls-extra-enums
587   ;; All enums for GnuTLS-extra (GPL).
588   (list %openpgp-certificate-format-enum))
590 ;;; Local Variables:
591 ;;; mode: scheme
592 ;;; coding: latin-1
593 ;;; End:
595 ;;; arch-tag: 9e3eb6bb-61a5-4e85-861f-1914ab9677b0