guile/tests/anonymous-auth.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 ;;; 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 %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       (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
  61             (pid         (primitive-fork)))
  62         (if (= 0 pid)
  63
  64             (let ((client (make-session connection-end/client)))
  65               ;; client-side (child process)
  66               (set-session-default-priority! client)
  67               (set-session-certificate-type-priority! client %certs)
  68               (set-session-kx-priority! client %kx)
  69               (set-session-protocol-priority! client %protos)
  70               (set-session-cipher-priority! client %ciphers)
  71               (set-session-mac-priority! client %macs)
  72
  73               (set-session-transport-fd! client (fileno (car socket-pair)))
  74               (set-session-credentials! client (make-anonymous-client-credentials))
  75               (set-session-dh-prime-bits! client 1024)
  76
  77               (handshake client)
  78               (record-send client %message)
  79               (bye client close-request/rdwr)
  80
  81               (primitive-exit))
  82
  83             (let ((server (make-session connection-end/server)))
  84               ;; server-side
  85               (set-session-default-priority! server)
  86               (set-session-certificate-type-priority! server %certs)
  87               (set-session-kx-priority! server %kx)
  88               (set-session-protocol-priority! server %protos)
  89               (set-session-cipher-priority! server %ciphers)
  90               (set-session-mac-priority! server %macs)
  91
  92               (set-session-transport-fd! server (fileno (cdr socket-pair)))
  93               (let ((cred (make-anonymous-server-credentials))
  94                     (dh-params (import-dh-params "dh-parameters.pem")))
  95                 ;; Note: DH parameter generation can take some time.
  96                 (set-anonymous-server-dh-parameters! cred dh-params)
  97                 (set-session-credentials! server cred))
  98               (set-session-dh-prime-bits! server 1024)
  99
 100               (handshake server)
 101               (let* ((buf (make-u8vector (u8vector-length %message)))
 102                      (amount (record-receive! server buf)))
 103                 (bye server close-request/rdwr)
 104                 (and (= amount (u8vector-length %message))
 105                      (equal? buf %message))))))))
 106
 107 ;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0