guile/tests/anonymous-auth.scm

   1 ;;; GnuTLS --- Guile bindings for GnuTLS.
   2 ;;; Copyright (C) 2007-2012 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
  21 ;;;
  22 ;;; Test session establishment using anonymous authentication.  Exercise the
  23 ;;; record layer low-level API.
  24 ;;;
  25
  26 (use-modules (gnutls)
  27              (gnutls build tests)
  28              (srfi srfi-4))
  29
  30
  31 ;; TLS session settings.
  32 (define priorities
  33   "NONE:+VERS-TLS-ALL:+CIPHER-ALL:+MAC-ALL:+SIGN-ALL:+COMP-ALL:+ANON-DH")
  34
  35 ;; Message sent by the client.
  36 (define %message (apply u8vector (iota 256)))
  37
  38 (define (import-something import-proc file fmt)
  39   (let* ((path (search-path %load-path file))
  40          (size (stat:size (stat path)))
  41          (raw  (make-u8vector size)))
  42     (uniform-vector-read! raw (open-input-file path))
  43     (import-proc raw fmt)))
  44
  45 (define (import-dh-params file)
  46   (import-something pkcs3-import-dh-parameters file
  47                     x509-certificate-format/pem))
  48
  49 ;; Debugging.
  50 ;; (set-log-level! 100)
  51 ;; (set-log-procedure! (lambda (level str)
  52 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
  53
  54 (run-test
  55     (lambda ()
  56       (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
  57             (pid         (primitive-fork)))
  58         (if (= 0 pid)
  59
  60             (let ((client (make-session connection-end/client)))
  61               ;; client-side (child process)
  62               (set-session-priorities! client priorities)
  63
  64               (set-session-transport-fd! client (fileno (car socket-pair)))
  65               (set-session-credentials! client (make-anonymous-client-credentials))
  66               (set-session-dh-prime-bits! client 1024)
  67
  68               (handshake client)
  69               (record-send client %message)
  70               (bye client close-request/rdwr)
  71
  72               (primitive-exit))
  73
  74             (let ((server (make-session connection-end/server)))
  75               ;; server-side
  76               (set-session-priorities! server priorities)
  77
  78               (set-session-transport-fd! server (fileno (cdr socket-pair)))
  79               (let ((cred (make-anonymous-server-credentials))
  80                     (dh-params (import-dh-params "dh-parameters.pem")))
  81                 ;; Note: DH parameter generation can take some time.
  82                 (set-anonymous-server-dh-parameters! cred dh-params)
  83                 (set-session-credentials! server cred))
  84               (set-session-dh-prime-bits! server 1024)
  85
  86               (handshake server)
  87               (let* ((buf (make-u8vector (u8vector-length %message)))
  88                      (amount (record-receive! server buf)))
  89                 (bye server close-request/rdwr)
  90                 (and (= amount (u8vector-length %message))
  91                      (equal? buf %message))))))))
  92
  93 ;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0