guile/tests/session-record-port.scm

   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
  17
  18 ;;; Written by Ludovic Courtès <ludo@chbouib.org>.
  19
  20
  21 ;;;
  22 ;;; Test session establishment using anonymous authentication.  Exercise the
  23 ;;; `session-record-port' API.
  24 ;;;
  25
  26 (use-modules (gnutls)
  27              (gnutls build tests)
  28              (srfi srfi-4))
  29
  30
  31 ;; TLS session settings.
  32 (define %protos  (list protocol/tls-1.0))
  33 (define %certs   '())
  34 (define %ciphers (list cipher/null cipher/arcfour cipher/aes-128-cbc
  35                        cipher/aes-256-cbc))
  36 (define %kx      (list kx/anon-dh))
  37 (define %macs    (list mac/sha1 mac/rmd160 mac/md5))
  38
  39 ;; Message sent by the client.
  40 (define %message (apply u8vector (iota 256)))
  41
  42 (define (import-something import-proc file fmt)
  43   (let* ((path (search-path %load-path file))
  44          (size (stat:size (stat path)))
  45          (raw  (make-u8vector size)))
  46     (uniform-vector-read! raw (open-input-file path))
  47     (import-proc raw fmt)))
  48
  49 (define (import-dh-params file)
  50   (import-something pkcs3-import-dh-parameters file
  51                     x509-certificate-format/pem))
  52
  53 ;; Debugging.
  54 ;; (set-log-level! 100)
  55 ;; (set-log-procedure! (lambda (level str)
  56 ;;                       (format #t "[~a|~a] ~a" (getpid) level str)))
  57
  58 (run-test
  59     (lambda ()
  60       ;; Stress the GC.  In 0.0, this triggered an abort due to
  61       ;; "scm_unprotect_object called during GC".
  62       (let ((sessions (map (lambda (i)
  63                              (make-session connection-end/server))
  64                            (iota 123))))
  65         (for-each session-record-port sessions)
  66         (gc)(gc)(gc))
  67
  68       ;; Stress the GC.  The session associated to each port in PORTS should
  69       ;; remain reachable.
  70       (let ((ports (map session-record-port
  71                         (map (lambda (i)
  72                                (make-session connection-end/server))
  73                              (iota 123)))))
  74         (gc)(gc)(gc)
  75         (for-each (lambda (p)
  76                     (catch 'gnutls-error
  77                       (lambda ()
  78                         (read p))
  79                       (lambda (key . args)
  80                         #t)))
  81                   ports))
  82
  83       ;; Try using the record port for I/O.
  84       (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
  85             (pid         (primitive-fork)))
  86         (if (= 0 pid)
  87
  88             (let ((client (make-session connection-end/client)))
  89               ;; client-side (child process)
  90               (set-session-default-priority! client)
  91               (set-session-certificate-type-priority! client %certs)
  92               (set-session-kx-priority! client %kx)
  93               (set-session-protocol-priority! client %protos)
  94               (set-session-cipher-priority! client %ciphers)
  95               (set-session-mac-priority! client %macs)
  96
  97               (set-session-transport-port! client (car socket-pair))
  98               (set-session-credentials! client (make-anonymous-client-credentials))
  99               (set-session-dh-prime-bits! client 1024)
 100
 101               (handshake client)
 102               (uniform-vector-write %message (session-record-port client))
 103               (bye client close-request/rdwr)
 104
 105               (primitive-exit))
 106
 107             (let ((server (make-session connection-end/server)))
 108               ;; server-side
 109               (set-session-default-priority! server)
 110               (set-session-certificate-type-priority! server %certs)
 111               (set-session-kx-priority! server %kx)
 112               (set-session-protocol-priority! server %protos)
 113               (set-session-cipher-priority! server %ciphers)
 114               (set-session-mac-priority! server %macs)
 115
 116               (set-session-transport-port! server (cdr socket-pair))
 117               (let ((cred (make-anonymous-server-credentials))
 118                     (dh-params (import-dh-params "dh-parameters.pem")))
 119                 ;; Note: DH parameter generation can take some time.
 120                 (set-anonymous-server-dh-parameters! cred dh-params)
 121                 (set-session-credentials! server cred))
 122               (set-session-dh-prime-bits! server 1024)
 123
 124               (handshake server)
 125               (let* ((buf (make-u8vector (u8vector-length %message)))
 126                      (amount
 127                       (uniform-vector-read! buf (session-record-port server))))
 128                 (bye server close-request/rdwr)
 129
 130                 ;; Make sure we got everything right.
 131                 (and (eq? (session-record-port server)
 132                           (session-record-port server))
 133                      (= amount (u8vector-length %message))
 134                      (equal? buf %message)
 135                      (eof-object?
 136                       (read-char (session-record-port server))))))))))
 137
 138 ;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2