blob: 7570fdb1eb3c64f5d6aba4ce682697a734b9bb84 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
;;; GnuTLS --- Guile bindings for GnuTLS.
;;; Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc.
;;;
;;; GnuTLS is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;;
;;; GnuTLS is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with GnuTLS; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Written by Ludovic Courtès <ludo@chbouib.org>.
;;;
;;; Test session establishment using anonymous authentication. Exercise the
;;; `session-record-port' API.
;;;
(use-modules (gnutls)
(gnutls build tests)
(srfi srfi-4))
;; TLS session settings.
(define %protos (list protocol/tls-1.0))
(define %certs '())
(define %ciphers (list cipher/null cipher/arcfour cipher/aes-128-cbc
cipher/aes-256-cbc))
(define %kx (list kx/anon-dh))
(define %macs (list mac/sha1 mac/rmd160 mac/md5))
;; Message sent by the client.
(define %message (apply u8vector (iota 256)))
(define (import-something import-proc file fmt)
(let* ((path (search-path %load-path file))
(size (stat:size (stat path)))
(raw (make-u8vector size)))
(uniform-vector-read! raw (open-input-file path))
(import-proc raw fmt)))
(define (import-dh-params file)
(import-something pkcs3-import-dh-parameters file
x509-certificate-format/pem))
;; Debugging.
;; (set-log-level! 100)
;; (set-log-procedure! (lambda (level str)
;; (format #t "[~a|~a] ~a" (getpid) level str)))
(run-test
(lambda ()
;; Stress the GC. In 0.0, this triggered an abort due to
;; "scm_unprotect_object called during GC".
(let ((sessions (map (lambda (i)
(make-session connection-end/server))
(iota 123))))
(for-each session-record-port sessions)
(gc)(gc)(gc))
;; Stress the GC. The session associated to each port in PORTS should
;; remain reachable.
(let ((ports (map session-record-port
(map (lambda (i)
(make-session connection-end/server))
(iota 123)))))
(gc)(gc)(gc)
(for-each (lambda (p)
(catch 'gnutls-error
(lambda ()
(read p))
(lambda (key . args)
#t)))
ports))
;; Try using the record port for I/O.
(let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0))
(pid (primitive-fork)))
(if (= 0 pid)
(let ((client (make-session connection-end/client)))
;; client-side (child process)
(set-session-default-priority! client)
(set-session-certificate-type-priority! client %certs)
(set-session-kx-priority! client %kx)
(set-session-protocol-priority! client %protos)
(set-session-cipher-priority! client %ciphers)
(set-session-mac-priority! client %macs)
(set-session-transport-port! client (car socket-pair))
(set-session-credentials! client (make-anonymous-client-credentials))
(set-session-dh-prime-bits! client 1024)
(handshake client)
(uniform-vector-write %message (session-record-port client))
(bye client close-request/rdwr)
(primitive-exit))
(let ((server (make-session connection-end/server)))
;; server-side
(set-session-default-priority! server)
(set-session-certificate-type-priority! server %certs)
(set-session-kx-priority! server %kx)
(set-session-protocol-priority! server %protos)
(set-session-cipher-priority! server %ciphers)
(set-session-mac-priority! server %macs)
(set-session-transport-port! server (cdr socket-pair))
(let ((cred (make-anonymous-server-credentials))
(dh-params (import-dh-params "dh-parameters.pem")))
;; Note: DH parameter generation can take some time.
(set-anonymous-server-dh-parameters! cred dh-params)
(set-session-credentials! server cred))
(set-session-dh-prime-bits! server 1024)
(handshake server)
(let* ((buf (make-u8vector (u8vector-length %message)))
(amount
(uniform-vector-read! buf (session-record-port server))))
(bye server close-request/rdwr)
;; Make sure we got everything right.
(and (eq? (session-record-port server)
(session-record-port server))
(= amount (u8vector-length %message))
(equal? buf %message)
(eof-object?
(read-char (session-record-port server))))))))))
;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2
|
