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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
;;; Copyright (C) 2001, 2003 Eric Marsden
;;; Copyright (C) 2005 David Lichteblau
;;; Copyright (C) 2007 Pixel // pinterface
;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
;;;
;;; See LICENSE for details.
(declaim
(optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0)))
(in-package :cl+ssl)
(defclass ssl-stream
(fundamental-binary-input-stream
fundamental-binary-output-stream
trivial-gray-stream-mixin)
((ssl-stream-socket
:initarg :socket
:accessor ssl-stream-socket)
(close-callback
:initarg :close-callback
:accessor ssl-close-callback)
(handle
:initform nil
:accessor ssl-stream-handle)
(output-buffer
:initform (make-buffer +initial-buffer-size+)
:accessor ssl-stream-output-buffer)
(output-pointer
:initform 0
:accessor ssl-stream-output-pointer)
(input-buffer
:initform (make-buffer +initial-buffer-size+)
:accessor ssl-stream-input-buffer)
(peeked-byte
:initform nil
:accessor ssl-stream-peeked-byte)))
(defmethod print-object ((object ssl-stream) stream)
(print-unreadable-object (object stream :type t)
(format stream "for ~A" (ssl-stream-socket object))))
(defclass ssl-server-stream (ssl-stream)
((certificate
:initarg :certificate
:accessor ssl-stream-certificate)
(key
:initarg :key
:accessor ssl-stream-key)))
(defmethod stream-element-type ((stream ssl-stream))
'(unsigned-byte 8))
(defmethod close ((stream ssl-stream) &key abort)
(declare (ignore abort))
(force-output stream)
(ssl-free (ssl-stream-handle stream))
(setf (ssl-stream-handle stream) nil)
(when (streamp (ssl-stream-socket stream))
(close (ssl-stream-socket stream)))
(when (functionp (ssl-close-callback stream))
(funcall (ssl-close-callback stream))))
(defmethod open-stream-p ((stream ssl-stream))
(and (ssl-stream-handle stream) t))
(defmethod stream-listen ((stream ssl-stream))
(or (ssl-stream-peeked-byte stream)
(setf (ssl-stream-peeked-byte stream)
(let* ((*blockp* nil)
(b (stream-read-byte stream)))
(if (eql b :eof) nil b)))))
(defmethod stream-read-byte ((stream ssl-stream))
(or (ssl-stream-peeked-byte stream)
(let ((buf (ssl-stream-input-buffer stream)))
(handler-case
(with-pointer-to-vector-data (ptr buf)
(ensure-ssl-funcall (ssl-stream-socket stream)
(ssl-stream-handle stream)
#'ssl-read
5.5
(ssl-stream-handle stream)
ptr
1)
(buffer-elt buf 0))
(ssl-error-zero-return () ;SSL_read returns 0 on end-of-file
:eof)))))
(defmethod stream-read-sequence ((stream ssl-stream) thing start end &key)
(check-type thing (simple-array (unsigned-byte 8) (*)))
(when (and (< start end) (ssl-stream-peeked-byte stream))
(setf (elt thing start) (ssl-stream-peeked-byte stream))
(setf (ssl-stream-peeked-byte stream) nil)
(incf start))
(let ((buf (ssl-stream-input-buffer stream)))
(loop
for length = (min (- end start) (buffer-length buf))
while (plusp length)
do
(handler-case
(with-pointer-to-vector-data (ptr buf)
(ensure-ssl-funcall (ssl-stream-socket stream)
(ssl-stream-handle stream)
#'ssl-read
5.5
(ssl-stream-handle stream)
ptr
length)
(v/b-replace thing buf :start1 start :end1 (+ start length))
(incf start length))
(ssl-error-zero-return () ;SSL_read returns 0 on end-of-file
(return))))
start))
(defmethod stream-write-byte ((stream ssl-stream) b)
(let ((buf (ssl-stream-output-buffer stream)))
(when (eql (buffer-length buf) (ssl-stream-output-pointer stream))
(force-output stream))
(setf (buffer-elt buf (ssl-stream-output-pointer stream)) b)
(incf (ssl-stream-output-pointer stream)))
b)
(defmethod stream-write-sequence ((stream ssl-stream) thing start end &key)
(check-type thing (simple-array (unsigned-byte 8) (*)))
(let ((buf (ssl-stream-output-buffer stream)))
(when (> (+ (- end start) (ssl-stream-output-pointer stream)) (buffer-length buf))
;; not enough space left? flush buffer.
(force-output stream)
;; still doesn't fit?
(while (> (- end start) (buffer-length buf))
(b/v-replace buf thing :start2 start)
(incf start (buffer-length buf))
(setf (ssl-stream-output-pointer stream) (buffer-length buf))
(force-output stream)))
(b/v-replace buf thing
:start1 (ssl-stream-output-pointer stream)
:start2 start
:end2 end)
(incf (ssl-stream-output-pointer stream) (- end start)))
thing)
(defmethod stream-finish-output ((stream ssl-stream))
(stream-force-output stream))
(defmethod stream-force-output ((stream ssl-stream))
(let ((buf (ssl-stream-output-buffer stream))
(fill-ptr (ssl-stream-output-pointer stream))
(handle (ssl-stream-handle stream))
(socket (ssl-stream-socket stream)))
(when (plusp fill-ptr)
(with-pointer-to-vector-data (ptr buf)
(ensure-ssl-funcall socket handle #'ssl-write 0.5 handle ptr fill-ptr))
(setf (ssl-stream-output-pointer stream) 0))))
;;; interface functions
;;;
(defun make-ssl-client-stream
(socket &key certificate key (method 'ssl-v23-method) external-format
close-callback)
"Returns an SSL stream for the client socket descriptor SOCKET.
CERTIFICATE is the path to a file containing the PEM-encoded certificate for
your client. KEY is the path to the PEM-encoded key for the client, which
must not be associated with a passphrase."
(ensure-initialized method)
(let ((stream (make-instance 'ssl-stream
:socket socket
:close-callback close-callback))
(handle (ssl-new *ssl-global-context*)))
(setf (ssl-stream-handle stream) handle)
(etypecase socket
(integer (ssl-set-fd handle socket))
(stream (ssl-set-bio handle (bio-new-lisp) (bio-new-lisp))))
(ssl-set-connect-state handle)
(when key
(unless (eql 1 (ssl-use-rsa-privatekey-file handle
key
+ssl-filetype-pem+))
(error 'ssl-error-initialize :reason "Can't load RSA private key ~A")))
(when certificate
(unless (eql 1 (ssl-use-certificate-file handle
certificate
+ssl-filetype-pem+))
(error 'ssl-error-initialize
:reason "Can't load certificate ~A" certificate)))
(ensure-ssl-funcall socket handle #'ssl-connect 0.25 handle)
(if external-format
(flexi-streams:make-flexi-stream stream
:external-format external-format)
stream)))
(defun make-ssl-server-stream
(socket &key certificate key (method 'ssl-v23-method) external-format
close-callback)
"Returns an SSL stream for the server socket descriptor SOCKET.
CERTIFICATE is the path to a file containing the PEM-encoded certificate for
your server. KEY is the path to the PEM-encoded key for the server, which
must not be associated with a passphrase."
(ensure-initialized method)
(let ((stream (make-instance 'ssl-server-stream
:socket socket
:close-callback close-callback
:certificate certificate
:key key))
(handle (ssl-new *ssl-global-context*)))
(setf (ssl-stream-handle stream) handle)
(etypecase socket
(integer
(ssl-set-fd handle socket))
(stream
(let ((bio (bio-new-lisp)))
(ssl-set-bio handle bio bio))))
(ssl-set-accept-state handle)
(when (zerop (ssl-set-cipher-list handle "ALL"))
(error 'ssl-error-initialize :reason "Can't set SSL cipher list"))
(when key
(unless (eql 1 (ssl-use-rsa-privatekey-file handle
key
+ssl-filetype-pem+))
(error 'ssl-error-initialize :reason "Can't load RSA private key ~A")))
(when certificate
(unless (eql 1 (ssl-use-certificate-file handle
certificate
+ssl-filetype-pem+))
(error 'ssl-error-initialize
:reason "Can't load certificate ~A" certificate)))
(ensure-ssl-funcall socket handle #'ssl-accept 0.25 handle)
(if external-format
(flexi-streams:make-flexi-stream stream
:external-format external-format)
stream)))
(defgeneric stream-fd (stream))
(defmethod stream-fd (stream) stream)
#+sbcl
(defmethod stream-fd ((stream sb-sys:fd-stream))
(sb-sys:fd-stream-fd stream))
#+cmu
(defmethod stream-fd ((stream system:fd-stream))
(system:fd-stream-fd stream))
#+openmcl
(defmethod stream-fd ((stream ccl::basic-stream))
(ccl::ioblock-device (ccl::stream-ioblock stream t)))
#+clisp
(defmethod stream-fd ((stream stream))
;; sockets appear to be direct instances of STREAM
(ignore-errors (socket:stream-handles stream)))
|
