guile/modules/gnutls/build/priorities.scm

   1 ;;; GnuTLS --- Guile bindings for GnuTLS.
   2 ;;; Copyright (C) 2007, 2010 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
  17
  18 ;;; Written by Ludovic Courtès <ludo@chbouib.org>
  19
  20 (define-module (gnutls build priorities)
  21   :use-module (srfi srfi-9)
  22   :use-module (gnutls build utils)
  23   :use-module (gnutls build enums)
  24   :export (output-session-set-priority-function %gnutls-priorities))
  25
  26 ;;;
  27 ;;; Helpers to generate the `gnutls_XXX_set_priority ()' wrappers.
  28 ;;;
  29
  30
  31 \f
  32 ;;;
  33 ;;; Priority functions.
  34 ;;;
  35
  36 (define-record-type <session-priority>
  37   (make-session-priority enum-type c-setter)
  38   session-priority?
  39   (enum-type        session-priority-enum-type)
  40   (c-setter         session-priority-c-setter)
  41   (c-getter         session-priority-c-getter))
  42
  43 \f
  44 ;;;
  45 ;;; C code generation.
  46 ;;;
  47
  48 (define (output-session-set-priority-function priority port)
  49   (let* ((enum   (session-priority-enum-type priority))
  50          (setter (session-priority-c-setter priority))
  51          (c-name (scheme-symbol->c-name (enum-type-subsystem enum))))
  52     (format port "SCM_DEFINE (scm_gnutls_set_session_~a_priority_x,~%"
  53             c-name)
  54     (format port "            \"set-session-~a-priority!\", 2, 0, 0,~%"
  55             (enum-type-subsystem enum))
  56     (format port "            (SCM session, SCM items),~%")
  57     (format port "            \"Use @var{items} (a list) as the list of \"~%")
  58     (format port "            \"preferred ~a for @var{session}.\")~%"
  59             (enum-type-subsystem enum))
  60     (format port "#define FUNC_NAME s_scm_gnutls_set_session_~a_priority_x~%"
  61             c-name)
  62     (format port "{~%")
  63     (format port "  gnutls_session_t c_session;~%")
  64     (format port "  ~a *c_items;~%"
  65             (enum-type-c-type enum))
  66     (format port "  long int c_len, i;~%")
  67     (format port "  c_session = scm_to_gnutls_session (session, 1, FUNC_NAME);~%")
  68     (format port "  SCM_VALIDATE_LIST_COPYLEN (2, items, c_len);~%")
  69     (format port "  c_items = (~a *) alloca (sizeof (* c_items) * c_len);~%"
  70             (enum-type-c-type enum))
  71     (format port "  for (i = 0; i < c_len; i++, items = SCM_CDR (items))~%")
  72     (format port "    c_items[i] = ~a (SCM_CAR (items), 2, FUNC_NAME);~%"
  73             (enum-type-to-c-function enum))
  74     (format port "  c_items[c_len] = (~a) 0;~%"
  75             (enum-type-c-type enum))
  76     (format port "  ~a (c_session, (int *) c_items);~%"
  77             setter)
  78     (format port "  return SCM_UNSPECIFIED;~%")
  79     (format port "}~%")
  80     (format port "#undef FUNC_NAME~%")))
  81
  82 \f
  83 ;;;
  84 ;;; Actual priority functions.
  85 ;;;
  86
  87 (define %gnutls-priorities
  88   (map make-session-priority
  89        (list %cipher-enum %mac-enum %compression-method-enum %kx-enum
  90              %protocol-enum %certificate-type-enum)
  91        (list "gnutls_cipher_set_priority" "gnutls_mac_set_priority"
  92              "gnutls_compression_set_priority" "gnutls_kx_set_priority"
  93              "gnutls_protocol_set_priority"
  94              "gnutls_certificate_type_set_priority")))
  95
  96
  97 ;;; Local Variables:
  98 ;;; mode: scheme
  99 ;;; coding: latin-1
 100 ;;; End:
 101
 102 ;;; arch-tag: a9cdcc92-6dcf-4d63-afec-6dc16334e379