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
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
;;;
;;; Filename: gray-streams-integration.lisp
;;; Author: Jochen Schmidt <jsc@dataheaven.de>
;;; Description: Integrate ssl-sockets with the lisp
;;; stream system using gray-streams.
;;;
(in-package :ssl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Gray Streams integration ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass ssl-stream-mixin ()
((ssl-socket :accessor ssl-socket :initarg :ssl-socket)))
(defclass binary-ssl-stream
(ssl-stream-mixin
gray-stream:fundamental-binary-input-stream
gray-stream:fundamental-binary-output-stream)
())
(defclass character-ssl-stream
(ssl-stream-mixin
gray-stream:fundamental-character-input-stream
gray-stream:fundamental-character-output-stream)
())
(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream binary-ssl-stream))
'(unsigned-byte 8))
(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream character-ssl-stream))
'character)
(defmethod gray-stream:stream-line-column ((socket-stream character-ssl-stream))
nil)
(defmethod gray-stream:stream-line-column ((socket-stream binary-ssl-stream))
nil)
(defmethod gray-stream:stream-listen ((socket-stream ssl-stream-mixin))
(with-slots (ssl-socket) socket-stream
(> (ssl-internal:ssl-pending (ssl-internal:ssl-socket-handle ssl-socket)) 0)))
(defmethod gray-stream:stream-read-byte ((socket-stream binary-ssl-stream))
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-read-byte ssl-socket)))
(defmethod gray-stream:stream-write-byte ((socket-stream binary-ssl-stream) byte)
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-write-byte byte ssl-socket)))
#|
(defmethod gray-stream:stream-read-char ((socket-stream character-ssl-stream))
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-read-char ssl-socket)))
(defmethod gray-stream:stream-read-char ((socket-stream binary-ssl-stream))
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-read-char ssl-socket)))
|#
; Bivalent
(defmethod gray-stream:stream-read-char ((socket-stream ssl-stream-mixin))
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-read-char ssl-socket)))
(defmethod gray-stream:stream-read-char-no-hang ((socket-stream character-ssl-stream))
(when (listen socket-stream)
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-read-char ssl-socket))))
#|
(defmethod gray-stream:stream-write-char ((socket-stream character-ssl-stream) char)
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-write-char char ssl-socket)))
(defmethod gray-stream:stream-write-char ((socket-stream binary-ssl-stream) char)
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-write-char char ssl-socket)))
|#
; Bivalent
(defmethod gray-stream:stream-write-char ((socket-stream ssl-stream-mixin) char)
(with-slots (ssl-socket) socket-stream
(ssl-internal:ssl-socket-write-char char ssl-socket)))
; Bivalent
(defmethod gray-stream:stream-force-output ((socket-stream ssl-stream-mixin))
(with-slots (ssl-socket) socket-stream
(ssl-internal:flush-output-buffer ssl-socket)))
(defmethod gray-stream:stream-finish-output ((socket-stream ssl-stream-mixin))
(with-slots (ssl-socket) socket-stream
(ssl-internal:flush-output-buffer ssl-socket)))
(defmethod gray-stream:stream-clear-output ((socket-stream ssl-stream-mixin))
(with-slots (ssl-socket) socket-stream
(with-slots (ssl-internal::output-offset) ssl-socket
(setf ssl-internal::output-offset 0))))
(defmethod gray-stream:stream-clear-input ((socket-stream ssl-stream-mixin))
(with-slots (ssl-socket) socket-stream
(with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
(setf ssl-internal::input-avail 0)
(setf ssl-internal::input-offset 0))))
(defmethod #-cormanlisp common-lisp:close #+cormanlisp gray-stream:stream-close ((socket-stream ssl-stream-mixin) &key abort)
(with-slots (ssl-socket) socket-stream
(unless abort
(ssl-internal:flush-output-buffer ssl-socket))
(ssl-internal:close-ssl-socket ssl-socket)))
#|
(defmethod gray-stream:stream-force-output ((socket-stream character-ssl-stream))
(with-slots (ssl-socket) socket-stream
(ssl-internal:flush-output-buffer ssl-socket)))
(defmethod gray-stream:stream-finish-output ((socket-stream character-ssl-stream))
(with-slots (ssl-socket) socket-stream
(ssl-internal:flush-output-buffer ssl-socket)))
(defmethod gray-stream:stream-clear-output ((socket-stream character-ssl-stream))
(with-slots (ssl-socket) socket-stream
(with-slots (ssl-internal::output-offset) ssl-socket
(setf ssl-internal::output-offset 0))))
(defmethod gray-stream:stream-clear-input ((socket-stream character-ssl-stream))
(with-slots (ssl-socket) socket-stream
(with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
(setf ssl-internal::input-avail 0)
(setf ssl-internal::input-offset 0))))
(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
(let* ((len (length sequence))
(chars (- (min (or end len) len) start)))
;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
(loop for i upfrom start
repeat chars
for char = (progn ;(format t "Read char on index ~A~%" i)
;(force-output t)
(let ((c (gray-streams:stream-read-char socket-stream)))
;(format t "The element read was ~A~%" c)
c))
if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
;(force-output t)
(return-from gray-streams:stream-read-sequence i))
do (setf (elt sequence i) char))
;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
(+ start chars)))
|#
;;
;; Why this argument ordering in CMUCL? LW has (stream sequence start end)
;; It would be interesting to know why it is a particular good idea to
;; reinvent APIs every second day in an incompatible way.... *grrr*
;;
#+cmu
(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) (sequence sequence) &optional start end)
(let* ((len (length sequence))
(chars (- (min (or end len) len) start)))
(loop for i upfrom start
repeat chars
for char = (gray-stream:stream-read-char socket-stream)
if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
do (setf (elt sequence i) char))
(+ start chars)))
#+cmu
(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) (sequence sequence) &optional start end)
(let* ((len (length sequence))
(chars (- (min (or end len) len) start)))
(loop for i upfrom start
repeat chars
for char = (gray-stream:stream-read-byte socket-stream)
if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
do (setf (elt sequence i) char))
(+ start chars)))
#|
(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) sequence start end)
(let* ((len (length sequence))
(chars (- (min (or end len) len) start)))
;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
(loop for i upfrom start
repeat chars
for char = (progn ;(format t "Read char on index ~A~%" i)
;(force-output t)
(let ((c (gray-streams:stream-read-byte socket-stream)))
;(format t "The element read was ~A~%" c)
c))
if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
;(force-output t)
(return-from gray-streams:stream-read-sequence i))
do (setf (elt sequence i) char))
;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
(+ start chars)))
|#
#| Alternative implementation?
(defmethod stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
(let* ((len (length sequence))
(chars (- (min (or end len) len) start)))
(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
(loop for i upfrom start
repeat chars
for char = (progn (format t "Read char on index ~A~%" i)
(force-output t)
(let ((c (stream:stream-read-char socket-stream)))
(format t "The element read was ~A~%" c) c))
if (eq char :eof) do (progn (format t "premature return on index ~A~%" i)
(force-output t)
(return-from stream:stream-read-sequence i))
do (setf (elt sequence i) char))
(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
(+ start chars)))
|#
#|
(defmethod common-lisp:close ((socket-stream character-ssl-stream) &key abort)
(with-slots (ssl-socket) socket-stream
(unless abort
(ssl-internal:flush-output-buffer ssl-socket))
(ssl-internal:close-ssl-socket ssl-socket)))
|#
#+lispworks
(declaim (inline %reader-function-for-sequence))
#+lispworks
(defun %reader-function-for-sequence (sequence)
(typecase sequence
(string #'read-char)
((array unsigned-byte (*)) #'read-byte)
((array signed-byte (*)) #'read-byte)
(otherwise #'read-byte)))
#+lispworks
(declaim (inline %writer-function-for-sequence))
#+lispworks
(defun %writer-function-for-sequence (sequence)
(typecase sequence
(string #'write-char)
((array unsigned-byte (*)) #'write-byte)
((array signed-byte (*)) #'write-byte)
(otherwise #'write-byte)))
;; Bivalent socket support for READ-SEQUENCE / WRITE-SEQUENCE
#+lispworks
(defmethod gray-stream:stream-read-sequence ((stream ssl-stream-mixin) sequence start end)
(stream::read-elements stream sequence start end (%reader-function-for-sequence sequence)))
#+lispworks
(defmethod gray-stream:stream-write-sequence ((stream ssl-stream-mixin) sequence start end)
(stream::write-elements stream sequence start end (typecase sequence
(string t)
((array unsigned-byte (*)) nil)
((array signed-byte (*)) nil)
(otherwise nil))))
#+lispworks
(in-package :acl-socket)
#+lispworks
(defmethod remote-host ((socket ssl::ssl-stream-mixin))
(comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))))
#+lispworks
(defmethod remote-port ((socket ssl::ssl-stream-mixin))
(multiple-value-bind (host port)
(comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
(declare (ignore host))
port))
#+lispworks
(defmethod local-host ((socket ssl::ssl-stream-mixin))
(multiple-value-bind (host port)
(comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
(declare (ignore port))
host))
#+lispworks
(defmethod local-port ((socket ssl::ssl-stream-mixin))
(multiple-value-bind (host port)
(comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
(declare (ignore host))
port))
|
