/asdf-systems/acl-compat/sbcl/acl-socket.lisp
Lisp | 283 lines | 240 code | 33 blank | 10 comment | 11 complexity | 13cfa9016783ad792701ab3cd2d9bee0 MD5 | raw file
Possible License(s): LGPL-2.1, BSD-3-Clause
- ;; This package is designed for sbcl. It implements the
- ;; ACL-style socket interface on top of sbcl.
- ;;
- ;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
- ;; for Lispworks and net.lisp in the port library of CLOCC.
- (in-package #:acl-compat.socket)
- (defclass server-socket ()
- ((socket :initarg :socket :reader socket
- :initform (error "No value supplied for socket"))
- (element-type :type (member signed-byte unsigned-byte base-char)
- :initarg :element-type
- :reader element-type
- :initform (error "No value supplied for element-type"))
- (port :type fixnum
- :initarg :port
- :reader port
- :initform (error "No value supplied for port"))
- (stream-type :type (member :text :binary :bivalent)
- :initarg :stream-type
- :reader stream-type
- :initform (error "No value supplied for stream-type"))))
- (defclass datagram-socket (server-socket)
- ())
- (defmethod print-object ((socket server-socket) stream)
- (print-unreadable-object (socket stream :type t :identity nil)
- (format stream "listening on port ~d" (port socket))))
- (defmethod print-object ((socket datagram-socket) stream)
- (print-unreadable-object (socket stream :type t :identity nil)
- (format stream "datagram socket listening on port ~d" (port socket))))
- (defgeneric accept-connection (socket &key wait))
- (defmethod accept-connection ((server-socket server-socket)
- &key (wait t))
- "Return a bidirectional stream connected to socket."
- (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket))
- :input (if (numberp wait) wait nil))
- (let* ((socket (socket-accept (socket server-socket)))
- (stream (socket-make-stream socket
- :input t :output t
- ; :buffering :none
- :element-type
- (element-type server-socket)
- :auto-close t)))
- (if (eq (stream-type server-socket) :bivalent)
- ;; HACK: remember socket, so we can do peer lookup
- (make-bivalent-stream stream :plist `(:socket ,socket))
- stream))
- nil))
- (defmethod receive-from ((socket datagram-socket) size &key buffer extract)
- (multiple-value-bind (rbuf len address port)
- (socket-receive (socket socket) buffer size)
- (declare (ignore port))
- (let ((buf
- (if (not extract)
- rbuf
- (subseq rbuf 0 len)))) ;; FIXME: am I right?
- (when buffer
- (replace buffer buf :end2 len))
- (values
- (if buffer buffer buf)
- len
- address))))
- (defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port)
- (let* ((rhost (typecase remote-host
- (string (lookup-hostname remote-host))
- (otherwise remote-host)))
- (s (socket socket))
- (stream (progn
- (socket-connect s rhost remote-port)
- (socket-make-stream s :input t :output t :buffering :none))))
- (write-sequence buffer stream)
- size))
-
-
- (defun make-socket (&key
- (type :stream)
- (remote-host "localhost")
- local-port
- remote-port
- (connect :active)
- (format :text)
- (reuse-address t)
- &allow-other-keys)
- "Return a stream connected to remote-host if connect is :active, or
- something listening on local-port that can be fed to accept-connection
- if connect is :passive.
- This is an incomplete implementation of ACL's make-socket function!
- It was written to provide the functionality necessary to port
- AllegroServe. Refer to
- http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
- to read about the missing parts."
- (check-type remote-host string)
- (let ((element-type (ecase format
- (:text 'base-char)
- (:binary 'signed-byte)
- (:bivalent 'unsigned-byte)))
- (socket
- (if (eq type :datagram)
- (progn
- (setf connect :passive-udp)
- (make-instance 'inet-socket :type :datagram :protocol :udp))
- (make-instance 'inet-socket :type :stream :protocol :tcp))))
- (ecase connect
- (:passive-udp
- (setf (sockopt-reuse-address socket) reuse-address)
- (if local-port
- (socket-bind socket #(0 0 0 0) local-port))
- (make-instance 'datagram-socket
- :port (nth-value 1 (socket-name socket))
- :socket socket
- :element-type element-type
- :stream-type format))
- (:passive
- (setf (sockopt-reuse-address socket) reuse-address)
- (if local-port
- (socket-bind socket #(0 0 0 0) local-port))
- (socket-listen socket 10) ;Arbitrarily chosen backlog value
- (make-instance 'server-socket
- :port (nth-value 1 (socket-name socket))
- :socket socket
- :element-type element-type
- :stream-type format))
- (:active
- (socket-connect socket (lookup-hostname remote-host) remote-port)
- (let ((stream (socket-make-stream socket :input t :output t
- :element-type element-type
- ; :buffering :none
- )))
- (if (eq :bivalent format)
- ;; HACK: remember socket, so we can do peer lookup
- (make-bivalent-stream stream :plist `(:socket ,socket))
- stream))))))
- (defmethod close ((server server-socket) &key abort)
- "Kill a passive (listening) socket. (Active sockets are actually
- streams and handled by their close methods."
- (declare (ignore abort))
- (socket-close (socket server)))
- #+ignore
- (declaim (ftype (function ((unsigned-byte 32) &key (:values t))
- (or (values fixnum fixnum fixnum fixnum)
- (values simple-string)))
- ipaddr-to-dotted))
- (defun ipaddr-to-dotted (ipaddr &key values)
- "Convert from 32-bit integer to dotted string."
- (declare (type (unsigned-byte 32) ipaddr))
- (let ((a (logand #xff (ash ipaddr -24)))
- (b (logand #xff (ash ipaddr -16)))
- (c (logand #xff (ash ipaddr -8)))
- (d (logand #xff ipaddr)))
- (if values
- (values a b c d)
- (format nil "~d.~d.~d.~d" a b c d))))
- (defun ipaddr-to-vector (ipaddr)
- "Convert from 32-bit integer to a vector of octets."
- (declare (type (unsigned-byte 32) ipaddr))
- (let ((a (logand #xff (ash ipaddr -24)))
- (b (logand #xff (ash ipaddr -16)))
- (c (logand #xff (ash ipaddr -8)))
- (d (logand #xff ipaddr)))
- (make-array 4 :initial-contents (list a b c d))))
- (declaim (ftype (function (vector)
- (values (unsigned-byte 32)))
- vector-to-ipaddr))
- (defun vector-to-ipaddr (sensible-ipaddr)
- "Convert from 4-integer vector to 32-bit integer."
- (loop with result = 0
- for component across sensible-ipaddr
- do (setf result (+ (ash result 8) component))
- finally (return result)))
- (defun string-tokens (string)
- (labels ((get-token (str pos1 acc)
- (let ((pos2 (position #\Space str :start pos1)))
- (if (not pos2)
- (nreverse acc)
- (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
- acc))))))
- (get-token (concatenate 'string string " ") 0 nil)))
- (declaim (ftype (function (string &key (:errorp t))
- (or null (unsigned-byte 32)))
- dotted-to-ipaddr))
- (defun dotted-to-ipaddr (dotted &key (errorp t))
- "Convert from dotted string to 32-bit integer."
- (declare (string dotted))
- (if errorp
- (let ((ll (string-tokens (substitute #\Space #\. dotted))))
- (+ (ash (first ll) 24) (ash (second ll) 16)
- (ash (third ll) 8) (fourth ll)))
- (ignore-errors
- (let ((ll (string-tokens (substitute #\Space #\. dotted))))
- (+ (ash (first ll) 24) (ash (second ll) 16)
- (ash (third ll) 8) (fourth ll))))))
- (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
- (when ignore-cache
- (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
- (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr))))
- (defun lookup-hostname (host &key ignore-cache)
- (when ignore-cache
- (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
- (if (stringp host)
- (host-ent-address (get-host-by-name host))
- (dotted-to-ipaddr (ipaddr-to-dotted host))))
- (defun remote-host (socket-stream)
- (let (socket)
- (if (and (typep socket-stream 'chunked-stream)
- (setf socket (getf (stream-plist socket-stream) :socket)))
- (vector-to-ipaddr (socket-peername socket))
- (progn (warn "Could not get remote host for ~S" socket-stream)
- 0))))
- (defun remote-port (socket-stream)
- (let (socket)
- (if (and (typep socket-stream 'chunked-stream)
- (setq socket (getf (stream-plist socket-stream) :socket)))
- (nth-value 1 (socket-peername socket))
- (progn (warn "Could not get remote port for ~S" socket-stream)
- 0))))
- (defun local-host (thing)
- (typecase thing
- (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
- (if socket (vector-to-ipaddr (socket-name socket))
- (progn (warn "Socket not in plist of ~S -- could not get local host" thing)
- 0))))
- (server-socket (vector-to-ipaddr #(127 0 0 1)))
- (t (progn (warn "Could not get local host for ~S" thing)
- 0))))
- (defun local-port (thing)
- (typecase thing
- (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
- (if socket (nth-value 1 (socket-name socket))
- (progn (warn "Socket not in plist of ~S -- could not get local port" thing)
- 0))))
- (server-socket (port thing))
- (t (progn (warn "Could not get local port for ~S" thing)
- 0))))
- ;; Now, throw chunking in the mix
- (defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
- gray-stream::buffered-bivalent-stream)
- ((plist :initarg :plist :accessor stream-plist)))
- (defun make-bivalent-stream (lisp-stream &key plist)
- (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
- (defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
- (when oc-p
- (when output-chunking
- (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
- (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
- output-chunking))
- (when output-chunking-eof
- (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
- (when ic-p
- (when input-chunking
- (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
- (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
- input-chunking)))
- (provide 'acl-socket)