/asdf-systems/acl-compat/acl-ssl-streams.lisp
Lisp | 293 lines | 131 code | 42 blank | 120 comment | 6 complexity | ea439aea3c755c33b42ff3bdc8f61d4c MD5 | raw file
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