PageRenderTime 51ms CodeModel.GetById 2ms app.highlight 44ms RepoModel.GetById 1ms app.codeStats 0ms

/asdf-systems/acl-compat/sbcl/acl-socket.lisp

https://bitbucket.org/mt/biobike
Lisp | 283 lines | 240 code | 33 blank | 10 comment | 11 complexity | 13cfa9016783ad792701ab3cd2d9bee0 MD5 | raw file
  1;; This package is designed for sbcl.  It implements the
  2;; ACL-style socket interface on top of sbcl.
  3;;
  4;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
  5;; for Lispworks and net.lisp in the port library of CLOCC.
  6
  7(in-package #:acl-compat.socket)
  8
  9(defclass server-socket ()
 10  ((socket :initarg :socket :reader socket
 11           :initform (error "No value supplied for socket"))
 12   (element-type :type (member signed-byte unsigned-byte base-char)
 13		 :initarg :element-type
 14		 :reader element-type
 15                 :initform (error "No value supplied for element-type"))
 16   (port :type fixnum
 17	 :initarg :port
 18	 :reader port
 19         :initform (error "No value supplied for port"))
 20   (stream-type :type (member :text :binary :bivalent)
 21                :initarg :stream-type
 22                :reader stream-type
 23                :initform (error "No value supplied for stream-type"))))
 24
 25(defclass datagram-socket (server-socket)
 26  ())
 27
 28
 29(defmethod print-object ((socket server-socket) stream)
 30  (print-unreadable-object (socket stream :type t :identity nil)
 31    (format stream "listening on port ~d" (port socket))))
 32
 33(defmethod print-object ((socket datagram-socket) stream)
 34  (print-unreadable-object (socket stream :type t :identity nil)
 35    (format stream "datagram socket listening on port ~d" (port socket))))
 36
 37(defgeneric accept-connection (socket &key wait))
 38(defmethod accept-connection ((server-socket server-socket)
 39			      &key (wait t))
 40  "Return a bidirectional stream connected to socket."
 41  (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket))
 42                                   :input (if (numberp wait) wait nil))
 43      (let* ((socket (socket-accept (socket server-socket)))
 44             (stream (socket-make-stream socket
 45                                         :input t :output t
 46                                        ; :buffering :none
 47                                         :element-type
 48                                         (element-type server-socket)
 49                                         :auto-close t)))
 50        (if (eq (stream-type server-socket) :bivalent)
 51            ;; HACK: remember socket, so we can do peer lookup
 52            (make-bivalent-stream stream :plist `(:socket ,socket))
 53            stream))
 54      nil))
 55
 56(defmethod receive-from ((socket datagram-socket) size &key buffer extract)
 57  (multiple-value-bind (rbuf len address port)
 58      (socket-receive (socket socket) buffer size)
 59    (declare (ignore port))
 60    (let ((buf
 61	   (if (not extract) 
 62	       rbuf
 63	     (subseq rbuf 0 len)))) ;; FIXME: am I right?
 64      (when buffer
 65	  (replace buffer buf :end2 len))
 66      (values
 67       (if buffer buffer buf)
 68       len
 69       address))))
 70
 71(defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port)
 72  (let* ((rhost (typecase remote-host
 73		  (string (lookup-hostname remote-host))
 74		  (otherwise remote-host)))
 75	 (s (socket socket))
 76	 (stream (progn
 77		   (socket-connect s rhost remote-port)
 78		   (socket-make-stream s :input t :output t :buffering :none))))
 79    (write-sequence buffer stream)
 80    size))
 81    
 82     
 83
 84(defun make-socket (&key 
 85		    (type :stream)
 86		    (remote-host "localhost")
 87                    local-port
 88                    remote-port
 89                    (connect :active)
 90                    (format :text)
 91                    (reuse-address t)
 92                    &allow-other-keys)
 93  "Return a stream connected to remote-host if connect is :active, or
 94something listening on local-port that can be fed to accept-connection
 95if connect is :passive.
 96
 97This is an incomplete implementation of ACL's make-socket function!
 98It was written to provide the functionality necessary to port
 99AllegroServe.  Refer to
100http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
101to read about the missing parts."
102  (check-type remote-host string)
103  (let ((element-type (ecase format
104			(:text 'base-char)
105			(:binary 'signed-byte)
106                        (:bivalent 'unsigned-byte)))
107        (socket 
108	 (if (eq type :datagram)
109	     (progn
110	       (setf connect :passive-udp)
111	       (make-instance 'inet-socket :type :datagram :protocol :udp))
112	   (make-instance 'inet-socket :type :stream :protocol :tcp))))
113    (ecase connect
114      (:passive-udp
115       (setf (sockopt-reuse-address socket) reuse-address)
116       (if local-port
117	   (socket-bind socket #(0 0 0 0) local-port))
118       (make-instance 'datagram-socket
119                      :port (nth-value 1 (socket-name socket))
120                      :socket socket
121                      :element-type element-type
122                      :stream-type format))
123      (:passive
124       (setf (sockopt-reuse-address socket) reuse-address)
125       (if local-port
126	   (socket-bind socket #(0 0 0 0) local-port))
127       (socket-listen socket 10)        ;Arbitrarily chosen backlog value
128       (make-instance 'server-socket
129                      :port (nth-value 1 (socket-name socket))
130                      :socket socket
131                      :element-type element-type
132                      :stream-type format))
133      (:active
134       (socket-connect socket (lookup-hostname remote-host) remote-port)
135       (let ((stream (socket-make-stream socket :input t :output t
136                                         :element-type element-type
137                                        ; :buffering :none
138                                           )))
139           (if (eq :bivalent format)
140               ;; HACK: remember socket, so we can do peer lookup
141               (make-bivalent-stream stream :plist `(:socket ,socket))
142               stream))))))
143
144(defmethod close ((server server-socket) &key abort)
145  "Kill a passive (listening) socket.  (Active sockets are actually
146streams and handled by their close methods."
147  (declare (ignore abort))
148  (socket-close (socket server)))
149
150#+ignore
151(declaim (ftype (function ((unsigned-byte 32) &key (:values t))
152                          (or (values fixnum fixnum fixnum fixnum)
153			      (values simple-string)))
154		ipaddr-to-dotted))
155(defun ipaddr-to-dotted (ipaddr &key values)
156  "Convert from 32-bit integer to dotted string."
157  (declare (type (unsigned-byte 32) ipaddr))
158  (let ((a (logand #xff (ash ipaddr -24)))
159	(b (logand #xff (ash ipaddr -16)))
160	(c (logand #xff (ash ipaddr -8)))
161	(d (logand #xff ipaddr)))
162    (if values
163	(values a b c d)
164      (format nil "~d.~d.~d.~d" a b c d))))
165
166(defun ipaddr-to-vector (ipaddr)
167  "Convert from 32-bit integer to a vector of octets."
168  (declare (type (unsigned-byte 32) ipaddr))
169  (let ((a (logand #xff (ash ipaddr -24)))
170	(b (logand #xff (ash ipaddr -16)))
171	(c (logand #xff (ash ipaddr -8)))
172	(d (logand #xff ipaddr)))
173    (make-array 4 :initial-contents (list a b c d))))
174
175(declaim (ftype (function (vector)
176                          (values (unsigned-byte 32)))
177                vector-to-ipaddr))
178(defun vector-to-ipaddr (sensible-ipaddr)
179  "Convert from 4-integer vector to 32-bit integer."
180  (loop with result = 0
181        for component across sensible-ipaddr
182        do (setf result (+ (ash result 8) component))
183        finally (return result)))
184
185(defun string-tokens (string)
186  (labels ((get-token (str pos1 acc)
187                      (let ((pos2 (position #\Space str :start pos1)))
188                        (if (not pos2)
189                            (nreverse acc)
190                          (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
191                                                         acc))))))
192    (get-token (concatenate 'string string " ") 0 nil)))
193
194(declaim (ftype (function (string &key (:errorp t))
195                          (or null (unsigned-byte 32)))
196		dotted-to-ipaddr))
197(defun dotted-to-ipaddr (dotted &key (errorp t))
198  "Convert from dotted string to 32-bit integer."
199  (declare (string dotted))
200  (if errorp
201      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
202	(+ (ash (first ll) 24) (ash (second ll) 16)
203	   (ash (third ll) 8) (fourth ll)))
204    (ignore-errors
205	(let ((ll (string-tokens (substitute #\Space #\. dotted))))
206	  (+ (ash (first ll) 24) (ash (second ll) 16)
207	     (ash (third ll) 8) (fourth ll))))))
208
209(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
210  (when ignore-cache
211    (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
212  (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr))))
213
214(defun lookup-hostname (host &key ignore-cache)
215  (when ignore-cache
216    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
217  (if (stringp host)
218      (host-ent-address (get-host-by-name host))
219      (dotted-to-ipaddr (ipaddr-to-dotted host))))
220
221(defun remote-host (socket-stream)
222  (let (socket)
223    (if (and (typep socket-stream 'chunked-stream)
224             (setf socket (getf (stream-plist socket-stream) :socket)))
225        (vector-to-ipaddr (socket-peername socket))
226        (progn (warn "Could not get remote host for ~S" socket-stream)
227               0))))
228
229(defun remote-port (socket-stream)
230  (let (socket)
231    (if (and (typep socket-stream 'chunked-stream)
232             (setq socket (getf (stream-plist socket-stream) :socket)))
233        (nth-value 1 (socket-peername socket))
234        (progn (warn "Could not get remote port for ~S" socket-stream)
235               0))))
236
237(defun local-host (thing)
238  (typecase thing
239    (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
240                      (if socket (vector-to-ipaddr (socket-name socket))
241                        (progn (warn "Socket not in plist of ~S -- could not get local host" thing)
242                               0))))
243    (server-socket (vector-to-ipaddr #(127 0 0 1)))
244    (t (progn (warn "Could not get local host for ~S" thing)
245              0))))
246
247(defun local-port (thing)
248  (typecase thing
249    (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
250                      (if socket (nth-value 1 (socket-name socket))
251                        (progn (warn "Socket not in plist of ~S -- could not get local port" thing)
252                               0))))
253    (server-socket (port thing))
254    (t (progn (warn "Could not get local port for ~S" thing)
255              0))))
256
257;; Now, throw chunking in the mix
258
259(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
260                          gray-stream::buffered-bivalent-stream)
261  ((plist :initarg :plist :accessor stream-plist)))
262
263
264(defun make-bivalent-stream (lisp-stream &key plist)
265  (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
266
267
268(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
269  (when oc-p
270    (when output-chunking
271      (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
272    (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
273          output-chunking))
274  (when output-chunking-eof
275    (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
276  (when ic-p
277    (when input-chunking
278      (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
279    (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
280          input-chunking)))
281
282
283(provide 'acl-socket)