/asdf-systems/acl-compat/acl-ssl-streams.lisp

  1;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
  2;;;
  3;;; Filename:    gray-streams-integration.lisp
  4;;; Author:      Jochen Schmidt <jsc@dataheaven.de>
  5;;; Description: Integrate ssl-sockets with the lisp
  6;;;              stream system using gray-streams.
  7;;;              
  8
  9(in-package :ssl)
 10
 11;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 12;;; Gray Streams integration ;;;
 13;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 14
 15(defclass ssl-stream-mixin ()
 16  ((ssl-socket :accessor ssl-socket :initarg :ssl-socket)))
 17
 18(defclass binary-ssl-stream 
 19          (ssl-stream-mixin
 20           gray-stream:fundamental-binary-input-stream
 21           gray-stream:fundamental-binary-output-stream)
 22  ())
 23
 24(defclass character-ssl-stream
 25          (ssl-stream-mixin
 26           gray-stream:fundamental-character-input-stream
 27           gray-stream:fundamental-character-output-stream)
 28  ())
 29
 30(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream binary-ssl-stream))
 31  '(unsigned-byte 8))
 32
 33(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream character-ssl-stream))
 34  'character)
 35
 36(defmethod gray-stream:stream-line-column ((socket-stream character-ssl-stream))
 37  nil)
 38
 39(defmethod gray-stream:stream-line-column ((socket-stream binary-ssl-stream))
 40  nil)
 41
 42(defmethod gray-stream:stream-listen ((socket-stream ssl-stream-mixin))
 43  (with-slots (ssl-socket) socket-stream
 44    (> (ssl-internal:ssl-pending (ssl-internal:ssl-socket-handle ssl-socket)) 0)))
 45
 46(defmethod gray-stream:stream-read-byte ((socket-stream binary-ssl-stream))
 47  (with-slots (ssl-socket) socket-stream
 48    (ssl-internal:ssl-socket-read-byte ssl-socket)))
 49
 50(defmethod gray-stream:stream-write-byte ((socket-stream binary-ssl-stream) byte)
 51  (with-slots (ssl-socket) socket-stream
 52    (ssl-internal:ssl-socket-write-byte byte ssl-socket)))
 53
 54#|
 55(defmethod gray-stream:stream-read-char ((socket-stream character-ssl-stream))
 56  (with-slots (ssl-socket) socket-stream
 57    (ssl-internal:ssl-socket-read-char ssl-socket)))
 58
 59(defmethod gray-stream:stream-read-char ((socket-stream binary-ssl-stream))
 60  (with-slots (ssl-socket) socket-stream
 61    (ssl-internal:ssl-socket-read-char ssl-socket)))
 62|#
 63
 64; Bivalent
 65(defmethod gray-stream:stream-read-char ((socket-stream ssl-stream-mixin))
 66  (with-slots (ssl-socket) socket-stream
 67    (ssl-internal:ssl-socket-read-char ssl-socket)))
 68
 69
 70(defmethod gray-stream:stream-read-char-no-hang ((socket-stream character-ssl-stream))
 71  (when (listen socket-stream)
 72    (with-slots (ssl-socket) socket-stream
 73      (ssl-internal:ssl-socket-read-char ssl-socket))))
 74
 75#|
 76(defmethod gray-stream:stream-write-char ((socket-stream character-ssl-stream) char)
 77  (with-slots (ssl-socket) socket-stream
 78    (ssl-internal:ssl-socket-write-char char ssl-socket)))
 79
 80(defmethod gray-stream:stream-write-char ((socket-stream binary-ssl-stream) char)
 81  (with-slots (ssl-socket) socket-stream
 82    (ssl-internal:ssl-socket-write-char char ssl-socket)))
 83|#
 84
 85; Bivalent
 86(defmethod gray-stream:stream-write-char ((socket-stream ssl-stream-mixin) char)
 87  (with-slots (ssl-socket) socket-stream
 88    (ssl-internal:ssl-socket-write-char char ssl-socket)))
 89
 90
 91
 92; Bivalent
 93(defmethod gray-stream:stream-force-output ((socket-stream ssl-stream-mixin))
 94  (with-slots (ssl-socket) socket-stream
 95    (ssl-internal:flush-output-buffer ssl-socket)))
 96
 97(defmethod gray-stream:stream-finish-output ((socket-stream ssl-stream-mixin))
 98  (with-slots (ssl-socket) socket-stream
 99    (ssl-internal:flush-output-buffer ssl-socket)))
100
101(defmethod gray-stream:stream-clear-output ((socket-stream ssl-stream-mixin))
102  (with-slots (ssl-socket) socket-stream
103    (with-slots (ssl-internal::output-offset) ssl-socket
104      (setf ssl-internal::output-offset 0))))
105
106(defmethod gray-stream:stream-clear-input ((socket-stream ssl-stream-mixin))
107  (with-slots (ssl-socket) socket-stream
108    (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
109      (setf ssl-internal::input-avail 0)
110      (setf ssl-internal::input-offset 0))))
111
112(defmethod #-cormanlisp common-lisp:close #+cormanlisp gray-stream:stream-close ((socket-stream ssl-stream-mixin) &key abort)
113  (with-slots (ssl-socket) socket-stream
114    (unless abort
115      (ssl-internal:flush-output-buffer ssl-socket))
116    (ssl-internal:close-ssl-socket ssl-socket)))
117
118#|
119(defmethod gray-stream:stream-force-output ((socket-stream character-ssl-stream))
120  (with-slots (ssl-socket) socket-stream
121    (ssl-internal:flush-output-buffer ssl-socket)))
122
123(defmethod gray-stream:stream-finish-output ((socket-stream character-ssl-stream))
124  (with-slots (ssl-socket) socket-stream
125    (ssl-internal:flush-output-buffer ssl-socket)))
126
127(defmethod gray-stream:stream-clear-output ((socket-stream character-ssl-stream))
128  (with-slots (ssl-socket) socket-stream
129    (with-slots (ssl-internal::output-offset) ssl-socket
130      (setf ssl-internal::output-offset 0))))
131
132(defmethod gray-stream:stream-clear-input ((socket-stream character-ssl-stream))
133  (with-slots (ssl-socket) socket-stream
134    (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
135      (setf ssl-internal::input-avail 0)
136      (setf ssl-internal::input-offset 0))))
137
138(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
139  (let* ((len (length sequence))
140         (chars (- (min (or end len) len) start)))
141    ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
142    (loop for i upfrom start
143          repeat chars
144          for char = (progn ;(format t "Read char on index ~A~%" i)
145                       ;(force-output t)
146                       (let ((c (gray-streams:stream-read-char socket-stream)))
147                         ;(format t "The element read was ~A~%" c) 
148			 c))
149          if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
150                                 ;(force-output t)
151                                 (return-from gray-streams:stream-read-sequence i))
152          do (setf (elt sequence i) char))
153    ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
154    (+ start chars)))
155
156|#
157
158;;
159;; Why this argument ordering in CMUCL? LW has (stream sequence start end)
160;; It would be interesting to know why it is a particular good idea to
161;; reinvent APIs every second day in an incompatible way.... *grrr*
162;;
163
164#+cmu
165(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) (sequence sequence) &optional start end)
166  (let* ((len (length sequence))
167         (chars (- (min (or end len) len) start)))
168    (loop for i upfrom start
169          repeat chars
170          for char = (gray-stream:stream-read-char socket-stream)
171          if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
172          do (setf (elt sequence i) char))
173    (+ start chars)))
174
175#+cmu
176(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) (sequence sequence) &optional start end)
177  (let* ((len (length sequence))
178         (chars (- (min (or end len) len) start)))
179    (loop for i upfrom start
180          repeat chars
181          for char = (gray-stream:stream-read-byte socket-stream)
182          if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
183          do (setf (elt sequence i) char))
184    (+ start chars)))
185
186#|
187(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) sequence start end)
188  (let* ((len (length sequence))
189         (chars (- (min (or end len) len) start)))
190    ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
191    (loop for i upfrom start
192          repeat chars
193          for char = (progn ;(format t "Read char on index ~A~%" i)
194                       ;(force-output t)
195                       (let ((c (gray-streams:stream-read-byte socket-stream)))
196                         ;(format t "The element read was ~A~%" c) 
197			 c))
198          if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
199                                 ;(force-output t)
200                                 (return-from gray-streams:stream-read-sequence i))
201          do (setf (elt sequence i) char))
202    ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
203    (+ start chars)))
204|#
205
206#| Alternative implementation?
207(defmethod stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
208  (let* ((len (length sequence))
209         (chars (- (min (or end len) len) start)))
210    (format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
211    (loop for i upfrom start
212          repeat chars
213          for char = (progn (format t "Read char on index ~A~%" i)
214                       (force-output t)
215                       (let ((c (stream:stream-read-char socket-stream)))
216                         (format t "The element read was ~A~%" c) c))
217          if (eq char :eof) do (progn (format t "premature return on index ~A~%" i)
218                                 (force-output t)
219                                 (return-from stream:stream-read-sequence i))
220          do (setf (elt sequence i) char))
221    (format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
222    (+ start chars)))
223|#
224
225#|
226(defmethod common-lisp:close ((socket-stream character-ssl-stream) &key abort)
227  (with-slots (ssl-socket) socket-stream
228    (unless abort
229      (ssl-internal:flush-output-buffer ssl-socket))
230    (ssl-internal:close-ssl-socket ssl-socket)))
231|#
232
233#+lispworks
234(declaim (inline %reader-function-for-sequence))
235#+lispworks
236(defun %reader-function-for-sequence (sequence)
237  (typecase sequence
238    (string #'read-char)
239    ((array unsigned-byte (*)) #'read-byte)
240    ((array signed-byte (*)) #'read-byte)
241    (otherwise #'read-byte)))
242
243#+lispworks
244(declaim (inline %writer-function-for-sequence))
245#+lispworks
246(defun %writer-function-for-sequence (sequence)
247  (typecase sequence
248    (string #'write-char)
249    ((array unsigned-byte (*)) #'write-byte)
250    ((array signed-byte (*)) #'write-byte)
251    (otherwise #'write-byte)))
252
253;; Bivalent socket support for READ-SEQUENCE / WRITE-SEQUENCE
254#+lispworks
255(defmethod gray-stream:stream-read-sequence ((stream ssl-stream-mixin) sequence start end)
256  (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence)))
257
258#+lispworks
259(defmethod gray-stream:stream-write-sequence ((stream ssl-stream-mixin) sequence start end)
260  (stream::write-elements stream sequence start end (typecase sequence
261                                                      (string t)
262                                                      ((array unsigned-byte (*)) nil)
263                                                      ((array signed-byte (*)) nil)
264                                                      (otherwise nil))))
265
266#+lispworks
267(in-package :acl-socket)
268
269#+lispworks
270(defmethod remote-host ((socket ssl::ssl-stream-mixin))
271  (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))))
272
273#+lispworks
274(defmethod remote-port ((socket ssl::ssl-stream-mixin))
275  (multiple-value-bind (host port)
276      (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
277    (declare (ignore host))
278    port))
279
280#+lispworks
281(defmethod local-host ((socket ssl::ssl-stream-mixin))
282  (multiple-value-bind (host port)
283      (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
284    (declare (ignore port))
285    host))
286
287#+lispworks
288(defmethod local-port ((socket ssl::ssl-stream-mixin))
289  (multiple-value-bind (host port)
290      (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
291    (declare (ignore host))
292    port))
293