/contrib/server/net.lisp
Lisp | 781 lines | 676 code | 54 blank | 51 comment | 8 complexity | 46b82865f11358a6915b8a56ee149be9 MD5 | raw file
Possible License(s): GPL-3.0
- ;;; Network Access
- ;;;
- ;;; Copyright (C) 1999-2008 by Sam Steingold
- ;;; This is open-source software.
- ;;; GNU Lesser General Public License (LGPL) is applicable:
- ;;; No warranty; you may copy/modify/redistribute under the same
- ;;; conditions with the source code.
- ;;; See <URL:http://www.gnu.org/copyleft/lesser.html>
- ;;; for details and the precise copyright document.
- ;;;
- ;;; $Id: net.lisp,v 1.64 2008/10/20 19:54:38 sds Exp $
- ;;; $Source: /cvsroot-fuse/clocc/clocc/src/port/net.lisp,v $
- (in-package :cl-user)
- (eval-when (:compile-toplevel :load-toplevel :execute)
- ;;(require "ext.lisp")
- ;; `getenv'
- ;;(require "sys.lisp")
- #+(or cmu scl) (require :simple-streams) ; for `set-socket-stream-format'
- #+cormanlisp (require :winsock)
- #+lispworks (require "comm")
- #+(and sbcl (not (or db-sockets net.sbcl.sockets)))
- (progn (require :sb-bsd-sockets) (pushnew :sb-bsd-sockets *features*)))
- (defpackage :port
- (:use :common-lisp)
- (:export :resolve-host-ipaddr
- :ipaddr-to-dotted
- :dotted-to-ipaddr
- :ipaddr-closure
- :hostent
- :hostent-name
- :hostent-aliases
- :hostent-addr-list
- :hostent-addr-type
- :socket
- :open-socket
- :socket-host/port
- :socket-string
- :socket-server
- :set-socket-stream-format
- :socket-accept
- :open-socket-server
- :socket-server-close
- :socket-server-host/port
- :socket-service-port
- :servent-name
- :servent-aliases
- :servent-port
- :servent-proto
- :servent-p
- :servent
- :network
- :timeout
- :login
- :net-path))
- (in-package :port)
- (define-condition code (error)
- ((proc :reader code-proc :initarg :proc :initform nil)
- (mesg :type (or null simple-string) :reader code-mesg
- :initarg :mesg :initform nil)
- (args :type list :reader code-args :initarg :args :initform nil))
- (:documentation "An error in the user code.")
- (:report (lambda (cc out)
- (declare (stream out))
- (format out "[~s]~@[ ~?~]" (code-proc cc) (code-mesg cc)
- (code-args cc)))))
- (define-condition case-error (code)
- ((mesg :type simple-string :reader code-mesg :initform
- "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]"))
- (:documentation "An error in a case statement.
- This carries the function name which makes the error message more useful."))
- (define-condition not-implemented (code)
- ((mesg :type simple-string :reader code-mesg :initform
- "not implemented for ~a [~a]")
- (args :type list :reader code-args :initform
- (list (lisp-implementation-type) (lisp-implementation-version))))
- (:documentation "Your implementation does not support this functionality."))
- (defmacro with-gensyms ((title &rest names) &body body)
- "Bind symbols in NAMES to gensyms. TITLE is a string - `gensym' prefix.
- Inspired by Paul Graham, <On Lisp>, p. 145."
- `(let (,@(mapcar (lambda (sy)
- `(,sy (gensym ,(concatenate 'string title
- (symbol-name sy) "-"))))
- names))
- ,@body))
- (defmacro defconst (name type init doc)
- "Define a typed constant."
- `(progn (declaim (type ,type ,name))
- ;; since constant redefinition must be the same under EQL, there
- ;; can be no constants other than symbols, numbers and characters
- ;; see ANSI CL spec 3.1.2.1.1.3 "Constant Variables"
- (,(if (subtypep type '(or symbol number character)) 'defconstant 'defvar)
- ,name (the ,type ,init) ,doc)))
- (defconst +eof+ cons (list '+eof+)
- "*The end-of-file object.
- To be passed as the third arg to `read' and checked against using `eq'.")
- (defun string-tokens (string &key (start 0) end max
- ((:package *package*) (find-package :keyword)))
- "Read from STRING repeatedly, starting with START, up to MAX tokens.
- Return the list of objects read and the final index in STRING.
- Binds `*package*' to the KEYWORD package (or argument),
- so that the bare symbols are read as keywords."
- (declare (type (or null fixnum) max) (type fixnum start))
- (if max
- (do ((beg start) obj res (num 0 (1+ num)))
- ((or (= max num) (and end (>= beg end)))
- (values (nreverse res) beg))
- (declare (fixnum beg num))
- (setf (values obj beg)
- (read-from-string string nil +eof+ :start beg :end end))
- (if (eq obj +eof+)
- (return (values (nreverse res) beg))
- (push obj res)))
- (with-input-from-string (st string :start start :end end)
- (loop :for obj = (read st nil st)
- :until (eq obj st) :collect obj))))
- (defmacro compose (&rest functions)
- "Macro: compose functions or macros of 1 argument into a lambda.
- E.g., (compose abs (dl-val zz) 'key) ==>
- (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))"
- (labels ((rec (xx yy)
- (let ((rr (list (car xx) (if (cdr xx) (rec (cdr xx) yy) yy))))
- (if (consp (car xx))
- (cons 'funcall (if (eq (caar xx) 'quote)
- (cons (cadar xx) (cdr rr)) rr))
- rr))))
- (with-gensyms ("COMPOSE-" arg)
- `(lambda (,arg) ,(rec functions arg)))))
- ;;;
- ;;; {{{ name resolution
- ;;;
- (declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
- ipaddr-to-dotted))
- (defun ipaddr-to-dotted (ipaddr)
- "Number --> string."
- (declare (type (unsigned-byte 32) ipaddr))
- #+allegro (socket:ipaddr-to-dotted ipaddr)
- #+(or openmcl ccl) (ccl:ipaddr-to-dotted ipaddr)
- #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:ipaddr-to-dot-string ipaddr)
- #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets))
- (format nil "~d.~d.~d.~d"
- (logand #xff (ash ipaddr -24)) (logand #xff (ash ipaddr -16))
- (logand #xff (ash ipaddr -8)) (logand #xff ipaddr)))
- (declaim (ftype (function (string) (values (unsigned-byte 32)))
- dotted-to-ipaddr))
- (defun dotted-to-ipaddr (dotted)
- "String --> number."
- (declare (string dotted))
- #+allegro (socket:dotted-to-ipaddr dotted)
- #+(or openmcl ccl) (ccl:dotted-to-ipaddr dotted)
- #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:dot-string-to-ipaddr dotted)
- #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets))
- (let ((ll (string-tokens (substitute #\Space #\. dotted))))
- (+ (ash (first ll) 24) (ash (second ll) 16)
- (ash (third ll) 8) (fourth ll))))
- ;#+(and sbcl (or db-sockets sb-bsd-sockets))
- ;(declaim (ftype (function (vector) (values (unsigned-byte 32)))
- ; vector-to-ipaddr))
- #+(and sbcl (or db-sockets sb-bsd-sockets))
- (defun vector-to-ipaddr (vector)
- (+ (ash (aref vector 0) 24)
- (ash (aref vector 1) 16)
- (ash (aref vector 2) 8)
- (aref vector 3)))
- ;#+(and sbcl (or db-sockets sb-bsd-sockets))
- ;(declaim (ftype (function (vector) (values (unsigned-byte 32)))
- ; ipaddr-to-vector))
- #+(and sbcl (or db-sockets sb-bsd-sockets))
- (defun ipaddr-to-vector (ipaddr)
- (vector (ldb (byte 8 24) ipaddr)
- (ldb (byte 8 16) ipaddr)
- (ldb (byte 8 8) ipaddr)
- (ldb (byte 8 0) ipaddr)))
- (defstruct hostent
- "see gethostbyname(3) for details"
- (name "" :type simple-string) ; canonical name of host
- (aliases nil :type list) ; alias list
- (addr-list nil :type list) ; list of addresses
- (addr-type 2 :type fixnum)) ; host address type
- (defun resolve-host-ipaddr (host)
- "Call gethostbyname(3) or gethostbyaddr(3)."
- #+allegro
- (let* ((ipaddr
- (etypecase host
- (string
- (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch)))
- host)
- (socket:dotted-to-ipaddr host)
- (socket:lookup-hostname host)))
- (integer host)))
- (name (socket:ipaddr-to-hostname ipaddr)))
- (make-hostent :name name :addr-list
- (list (socket:ipaddr-to-dotted ipaddr))))
- #+(and clisp syscalls)
- (let ((he (posix:resolve-host-ipaddr host)))
- (make-hostent :name (posix::hostent-name he)
- :aliases (posix::hostent-aliases he)
- :addr-list (posix::hostent-addr-list he)
- :addr-type (posix::hostent-addrtype he)))
- #+(or cmu scl)
- (let ((he (ext:lookup-host-entry host)))
- (make-hostent :name (ext:host-entry-name he)
- :aliases (ext:host-entry-aliases he)
- :addr-list (mapcar #'ipaddr-to-dotted
- (ext:host-entry-addr-list he))
- :addr-type (ext::host-entry-addr-type he)))
- #+gcl (make-hostent :name (or (si:hostid-to-hostname host) host)
- :addr-list (list (si:hostname-to-hostid host)))
- #+lispworks
- (multiple-value-bind (name addr aliases)
- (comm:get-host-entry host :fields '(:name :address :aliases))
- (make-hostent :name name :addr-list (list (ipaddr-to-dotted addr))
- :aliases aliases))
- #+(or openmcl ccl)
- (let* ((ipaddr
- (etypecase host
- (string
- (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch)))
- host)
- (dotted-to-ipaddr host)
- (ccl:lookup-hostname host)))
- (integer host)))
- (name (ccl:ipaddr-to-hostname ipaddr)))
- (make-hostent :name name :addr-list (list (ccl:lookup-hostname ipaddr))))
- #+(and sbcl sb-bsd-sockets)
- (let ((he (sb-bsd-sockets:get-host-by-name host)))
- (make-hostent :name (sb-bsd-sockets:host-ent-name he)
- :addr-list
- (loop for ipaddr in (sb-bsd-sockets:host-ent-addresses he)
- collect (format nil "~{~a~^.~}"
- (loop for octect
- being the elements of ipaddr
- collect octect)))))
- #+(and sbcl db-sockets)
- (let* ((ipaddr
- (etypecase host
- (string
- (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch)))
- host)
- (dotted-to-ipaddr host)
- (let ((hostent
- (sockets:get-host-by-name host)))
- (when hostent
- (vector-to-ipaddr
- (sockets::host-ent-address hostent))))))
- (integer host)))
- (name
- (when ipaddr
- (let ((hostent
- (sockets:get-host-by-address
- (ipaddr-to-vector ipaddr))))
- (when (and hostent
- (sockets::host-ent-aliases hostent))
- (first (sockets::host-ent-aliases hostent)))))))
- (make-hostent :name name :addr-list (list ipaddr)))
- #+(and sbcl net.sbcl.sockets)
- (let ((he (net.sbcl.sockets:lookup-host-entry host)))
- (make-hostent :name (net.sbcl.sockets:host-entry-name he)
- :aliases (net.sbcl.sockets:host-entry-aliases he)
- :addr-list (mapcar #'ipaddr-to-dotted
- (net.sbcl.sockets:host-entry-addr-list he))
- :addr-type (net.sbcl.sockets::host-entry-addr-type he)))
- #-(or allegro (and clisp syscalls) cmu gcl lispworks openmcl ccl
- (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl)
- (error 'not-implemented :proc (list 'resolve-host-ipaddr host)))
- (defun ipaddr-closure (address)
- "Resolve all addresses and names associated with the argument."
- (let ((a2he (make-hash-table :test 'equalp))
- (he2a (make-hash-table :test 'equalp)))
- (labels ((handle (s)
- (unless (gethash s a2he)
- (let ((he (resolve-host-ipaddr s)))
- (setf (gethash s a2he) he)
- (push s (gethash he he2a))
- (handle (hostent-name he))
- (mapc #'handle (hostent-aliases he))
- (mapc #'handle (hostent-addr-list he))))))
- (handle address))
- (values he2a a2he)))
- ;;;
- ;;; }}}{{{ sockets
- ;;;
- (deftype socket ()
- #+abcl 'to-way-stream
- #+allegro 'excl::socket-stream
- #+clisp 'stream
- #+(or cmu scl) 'stream ; '(or stream:socket-simple-stream sys:fd-stream)
- #+gcl 'stream
- #+lispworks 'comm:socket-stream
- #+(or openmcl ccl) 'ccl::socket
- #+(and sbcl (or db-sockets sb-bsd-sockets)) 'sb-sys:fd-stream
- #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:stream-socket
- #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl
- (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) 'stream)
- (defun open-socket (host port &optional bin)
- "Open a socket connection to HOST at PORT."
- (declare (type (or integer string) host) (fixnum port)
- #+(or cmu scl) (ignore bin))
- (let ((host (etypecase host
- (string host)
- (integer (hostent-name (resolve-host-ipaddr host))))))
- #+abcl (ext:get-socket-stream
- (sys:make-socket host port)
- :element-type (if bin '(unsigned-byte 8) 'character))
- #+allegro (socket:make-socket :remote-host host :remote-port port
- :format (if bin :binary :text))
- #+clisp (#+lisp=cl ext:socket-connect #-lisp=cl lisp:socket-connect
- port host :element-type
- (if bin '(unsigned-byte 8) 'character))
- #+(or cmu scl)
- (make-instance 'stream:socket-simple-stream :direction :io
- :remote-host host :remote-port port)
- #+gcl (si:socket port :host host)
- #+lispworks (comm:open-tcp-stream host port :direction :io :element-type
- (if bin 'unsigned-byte 'base-char))
- #+(or mcl ccl) (ccl:make-socket :remote-host host :remote-port port
- :format (if bin :binary :text))
- #+(and sbcl db-sockets)
- (let ((socket (make-instance 'sockets:inet-socket
- :type :stream :protocol :tcp)))
- (sockets:socket-connect socket
- (sockets::host-ent-address
- (sockets:get-host-by-name host))
- port)
- (sockets:socket-make-stream
- socket :input t :output t :buffering (if bin :none :line)
- :element-type (if bin '(unsigned-byte 8) 'character)))
- #+(and sbcl net.sbcl.sockets)
- (net.sbcl.sockets:make-socket
- (if bin
- 'net.sbcl.sockets:binary-stream-socket
- 'net.sbcl.sockets:character-stream-socket)
- :port port :host host)
- #+(and sbcl sb-bsd-sockets)
- (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
- :type :stream :protocol :tcp)))
- (sb-bsd-sockets:socket-connect socket
- (sb-bsd-sockets::host-ent-address
- (sb-bsd-sockets:get-host-by-name host))
- port)
- (sb-bsd-sockets:socket-make-stream
- socket :input t :output t :buffering (if bin :none :line)
- :element-type (if bin '(unsigned-byte 8) 'character)))
- #-(or abcl allegro clisp cmu gcl lispworks mcl ccl
- (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
- (error 'not-implemented :proc (list 'open-socket host port bin))))
- (defun set-socket-stream-format (socket format)
- "switch between binary and text output"
- #+clisp (setf (stream-element-type socket) format)
- #+(or acl cmu lispworks scl)
- (declare (ignore socket format)) ; bivalent streams
- #-(or acl clisp cmu lispworks scl)
- (error 'not-implemented :proc (list 'set-socket-stream-format socket format)))
- #+(and sbcl sb-bsd-sockets)
- (defun funcall-on-sock (function sock)
- "Apply function (getsockname/getpeername) on socket, return host/port as two values"
- (let ((sockaddr (sockint::allocate-sockaddr-in)))
- (funcall function (sb-sys:fd-stream-fd sock) sockaddr sockint::size-of-sockaddr-in)
- (let ((host (coerce (loop :for i :from 0 :below 4
- :collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i))
- '(vector (unsigned-byte 8) 4)))
- (port (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0))
- (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1))))
- (sockint::free-sockaddr-in sockaddr)
- (values host port))))
- (defun socket-host/port (sock)
- "Return the remote and local host&port, as 4 values."
- (declare (type socket sock))
- #+allegro (values (socket:ipaddr-to-dotted (socket:remote-host sock))
- (socket:remote-port sock)
- (socket:ipaddr-to-dotted (socket:local-host sock))
- (socket:local-port sock))
- #+clisp (flet ((ip (ho) (subseq ho 0 (position #\Space ho :test #'char=))))
- (multiple-value-bind (ho1 po1)
- (#+lisp=cl ext:socket-stream-peer
- #-lisp=cl lisp:socket-stream-peer sock)
- (multiple-value-bind (ho2 po2)
- (#+lisp=cl ext:socket-stream-local
- #-lisp=cl lisp:socket-stream-local sock)
- (values (ip ho1) po1
- (ip ho2) po2))))
- #+(or cmu scl)
- (let ((fd (sys:fd-stream-fd sock)))
- (multiple-value-bind (ho1 po1) (ext:get-peer-host-and-port fd)
- (multiple-value-bind (ho2 po2) (ext:get-socket-host-and-port fd)
- (values (ipaddr-to-dotted ho1) po1
- (ipaddr-to-dotted ho2) po2))))
- #+gcl (let ((peer (si:getpeername sock))
- (loc (si:getsockname sock)))
- (values (car peer) (caddr peer)
- (car loc) (caddr loc)))
- #+lispworks
- (multiple-value-bind (ho1 po1) (comm:socket-stream-peer-address sock)
- (multiple-value-bind (ho2 po2) (comm:socket-stream-address sock)
- (values (ipaddr-to-dotted ho1) po1
- (ipaddr-to-dotted ho2) po2)))
- #+(or mcl ccl)
- (values (ccl:ipaddr-to-dotted (ccl:remote-host sock))
- (ccl:remote-port sock)
- (ccl:ipaddr-to-dotted (ccl:local-host sock))
- (ccl:local-port sock))
- #+(and sbcl db-sockets)
- (let ((sock (sb-sys:fd-stream-fd sock)))
- (multiple-value-bind (remote remote-port) (sockets:socket-peername sock)
- (multiple-value-bind (local local-port) (sockets:socket-name sock)
- (values (ipaddr-to-dotted (vector-to-ipaddr remote))
- remote-port
- (ipaddr-to-dotted (vector-to-ipaddr local))
- local-port))))
- #+(and sbcl net.sbcl.sockets)
- (net.sbcl.sockets:socket-host-port sock)
- #+(and sbcl sb-bsd-sockets)
- (multiple-value-bind (remote remote-port)
- (funcall-on-sock #'sockint::getpeername sock)
- (multiple-value-bind (local local-port)
- (funcall-on-sock #'sockint::getsockname sock)
- (values (ipaddr-to-dotted (vector-to-ipaddr remote))
- remote-port
- (ipaddr-to-dotted (vector-to-ipaddr local))
- local-port)))
- #-(or allegro clisp cmu gcl lispworks mcl ccl
- (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
- (error 'not-implemented :proc (list 'socket-host/port sock)))
- (defun socket-string (sock)
- "Print the socket local&peer host&port to a string."
- (declare (type socket sock))
- (with-output-to-string (stream)
- (print-unreadable-object (sock stream :type t :identity t)
- (multiple-value-bind (ho1 po1 ho2 po2) (socket-host/port sock)
- (format stream "[local: ~a:~d] [peer: ~s:~d]" ho2 po2 ho1 po1)))))
- ;;;
- ;;; }}}{{{ socket-servers
- ;;;
- #+lispworks (defstruct socket-server proc mbox port)
- #-lispworks
- (deftype socket-server ()
- #+abcl 'ext:javaobject
- #+allegro 'acl-socket::socket-stream-internet-passive
- #+(and clisp lisp=cl) 'ext:socket-server
- #+(and clisp (not lisp=cl)) 'lisp:socket-server
- #+(or cmu scl) 'integer
- #+gcl 'si:socket-stream
- #+(or mcl ccl) 'ccl::listener-socket
- #+(and sbcl db-sockets) 'sb-sys:fd-stream
- #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:passive-socket
- #+(and sbcl sb-bsd-sockets) 'sb-bsd-sockets:inet-socket
- #-(or abcl allegro clisp cmu gcl mcl ccl
- (and sbcl (or net.sbcl.sockets db-sockets)) scl) t)
- (defun open-socket-server (&optional port)
- "Open a `generic' socket server."
- (declare (type (or null integer #-sbcl socket) port))
- #+abcl (ext:make-server-socket port)
- #+allegro (socket:make-socket :connect :passive :local-port
- (when (integerp port) port))
- #+clisp (#+lisp=cl ext:socket-server #-lisp=cl lisp:socket-server port)
- #+(or cmu scl) (ext:create-inet-listener (or port 0) :stream :reuse-address t)
- #+gcl (si:make-socket-pair port) ; FIXME
- #+lispworks (let ((mbox (mp:make-mailbox :size 1)))
- (make-socket-server
- :mbox mbox :port port
- :proc (comm:start-up-server
- :function (lambda (sock) (mp:mailbox-send mbox sock))
- :service port)))
- #+(or mcl ccl)
- (ccl:make-socket :connect :passive
- :type :stream
- :reuse-address t
- :local-port (or port 0))
- #+(and sbcl db-sockets)
- (let ((socket (make-instance 'sockets:inet-socket
- :type :stream :protocol :tcp)))
- (sockets:socket-bind socket (vector 0 0 0 0) (or port 0)))
- #+(and sbcl net.sbcl.sockets)
- (net.sbcl.sockets:make-socket 'net.sbcl.sockets:passive-socket :port port)
- #+(and sbcl sb-bsd-sockets)
- (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
- :type :stream
- :protocol :tcp)))
- (setf (sb-bsd-sockets:sockopt-reuse-address sock) t)
- (sb-bsd-sockets:socket-bind sock (vector 0 0 0 0) (or port 0))
- (sb-bsd-sockets:socket-listen sock 15)
- sock)
- #-(or abcl allegro clisp cmu gcl lispworks mcl ccl
- (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
- (error 'not-implemented :proc (list 'open-socket-server port)))
- (defun socket-accept (serv &key bin wait)
- "Accept a connection on a socket server (passive socket).
- Keyword arguments are:
- BIN - create a binary stream;
- WAIT - wait for the connection this many seconds
- (the default is NIL - wait forever).
- Returns a socket stream or NIL."
- (declare (type socket-server serv)
- #+(or (and allegro (version>= 6)) openmcl ccl)
- (ignore bin))
- #+abcl (ext:get-socket-stream
- (ext:socket-accept serv)
- :element-type (if bin '(unsigned-byte 8) 'character))
- #+allegro (let* ((fmt (if bin :binary :text))
- #+allegro-v5.0
- (excl:*default-external-format* fmt)
- (sock (if wait
- (if (plusp wait)
- (mp:with-timeout (wait)
- (socket:accept-connection serv :wait t))
- (socket:accept-connection serv :wait nil))
- (socket:accept-connection serv :wait t))))
- (when sock
- ;; From: John Foderaro <jkf@franz.com>
- ;; Date: Sun, 12 Nov 2000 16:58:28 -0800
- ;; in ACL6 and later, all sockets are bivalent (both
- ;; text and binary) and thus there's no need to convert
- ;; between the element types.
- #+allegro-v5.0
- (unless (eq (socket:socket-format sock) fmt)
- (warn "~s: ACL5 cannot modify socket format"
- 'socket-accept))
- #+allegro-v4.3
- (socket:set-socket-format sock fmt)
- sock))
- #+clisp (multiple-value-bind (sec usec) (floor (or wait 0))
- (when (#+lisp=cl ext:socket-wait #-lisp=cl lisp:socket-wait
- serv (and wait sec) (round usec 1d-6))
- (#+lisp=cl ext:socket-accept #-lisp=cl lisp:socket-accept
- serv :element-type
- (if bin '(unsigned-byte 8) 'character))))
- #+(or cmu scl)
- (when (sys:wait-until-fd-usable serv :input wait)
- (sys:make-fd-stream (ext:accept-tcp-connection serv)
- :buffering (if bin :full :line)
- :input t :output t :element-type
- (if bin '(unsigned-byte 8) 'character)))
- #+gcl (si:accept-socket-connection serv bin wait) ; FIXME
- #+lispworks (make-instance
- 'comm:socket-stream :direction :io
- :socket (mp:mailbox-read (socket-server-mbox serv))
- :element-type (if bin 'unsigned-byte 'base-char))
- ;; For ccl, as wait is a boolean, the time to wait is ignored.
- #+(or mcl ccl) (ccl:accept-connection serv :wait (not wait))
- #+(and sbcl db-sockets)
- (let ((new-connection (sockets:socket-accept serv)))
- ;; who needs WAIT and BIN anyway :-S
- new-connection)
- #+(and sbcl net.sbcl.sockets)
- (net.sbcl.sockets:accept-connection
- serv
- (if bin
- 'net.sbcl.sockets:binary-stream-socket
- 'net.sbcl.sockets:character-stream-socket)
- :wait wait)
- #+(and sbcl sb-bsd-sockets)
- (progn
- (setf (sb-bsd-sockets:non-blocking-mode serv) wait)
- (let ((s (sb-bsd-sockets:socket-accept serv)))
- (if s
- (sb-bsd-sockets:socket-make-stream
- s :input t :output t
- :element-type (if bin '(unsigned-byte 8) 'character)
- :buffering (if bin :full :line))
- (sleep wait))))
- #-(or abcl allegro clisp cmu gcl lispworks mcl ccl
- (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
- (error 'not-implemented :proc (list 'socket-accept serv bin)))
- (defun socket-server-close (server)
- "Close the server."
- (declare (type socket-server server))
- #+abcl (ext:server-socket-close server)
- #+allegro (close server)
- #+clisp (#+lisp=cl ext:socket-server-close
- #-lisp=cl lisp:socket-server-close server)
- #+(or cmu scl) (unix:unix-close server)
- #+gcl (close server)
- #+lispworks (mp:process-kill (socket-server-proc server))
- #+(or openmcl ccl) (close server)
- #+(and sbcl db-sockets) (sockets:socket-close server)
- #+(and sbcl net.sbcl.sockets) (close server)
- #+(and sbcl sb-bsd-sockets) (sb-bsd-sockets:socket-close server)
- #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl
- (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
- (error 'not-implemented :proc (list 'socket-server-close server)))
- (defun socket-server-host/port (server)
- "Return the local host&port on which the server is running, as 2 values."
- (declare (type socket-server server))
- #+allegro (values (socket:ipaddr-to-dotted (socket:local-host server))
- (socket:local-port server))
- #+(and clisp lisp=cl) (values (ext:socket-server-host server)
- (ext:socket-server-port server))
- #+(and clisp (not lisp=cl)) (values (lisp:socket-server-host server)
- (lisp:socket-server-port server))
- #+(or cmu scl)
- (values (ipaddr-to-dotted (car (ext:host-entry-addr-list
- (ext:lookup-host-entry "localhost"))))
- (nth-value 1 (ext:get-socket-host-and-port server)))
- #+gcl (let ((sock (si:getsockname server)))
- (values (car sock) (caddr sock)))
- #+lispworks (values (ipaddr-to-dotted (comm:get-host-entry
- "localhost" :fields '(:address)))
- (socket-server-port server))
- #+(or openmcl ccl)
- (values (ccl:ipaddr-to-dotted (ccl:local-host server))
- (ccl:local-port server))
- #+(and sbcl db-sockets)
- (multiple-value-bind (addr port) (sockets:socket-name server)
- (values (vector-to-ipaddr addr) port))
- #+(and sbcl net.sbcl.sockets)
- (net.sbcl.sockets:passive-socket-host-port server)
- #+(and sbcl sb-bsd-sockets)
- (multiple-value-bind (addr port) (sb-bsd-sockets:socket-name server)
- (values (ipaddr-to-dotted (vector-to-ipaddr addr)) port))
- #-(or allegro clisp cmu gcl lispworks openmcl ccl
- (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
- (error 'not-implemented :proc (list 'socket-server-host/port server)))
- ;;;
- ;;; }}}{{{ for CLX
- ;;;
- (defun wait-for-stream (stream &optional timeout)
- "Sleep until there is input on the STREAM, or for TIMEOUT seconds,
- whichever comes first. If there was a timeout, return NIL."
- #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
- (#+lisp=cl ext:socket-status #-lisp=cl lisp:socket-status
- stream (and timeout sec) (round usec 1d-6)))
- #+(or cmu scl)
- (#+mp mp:process-wait-until-fd-usable #-mp sys:wait-until-fd-usable
- (system:fd-stream-fd stream) :input timeout)
- #+(or openmcl ccl)
- (ccl:make-socket :type :stream
- :address-family :file
- :connect :active
- :format :text ;;(if bin :binary :text)
- :remote-filename #P"");;path)
- #+(and sbcl net.sbcl.sockets)
- (net.sbcl.sockets:wait-for-input-data stream timeout)
- #+(and sbcl db-sockets)
- (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout)
- #-(or clisp cmu (and sbcl (or net.sbcl.sockets db-sockets)) scl)
- (error 'not-implemented :proc (list 'wait-for-stream stream timeout)))
- (defun open-unix-socket (path &key (kind :stream) bin)
- "Opens a unix socket. Path is the location.
- Kind can be :stream or :datagram."
- (declare (simple-string path) #-(or cmu sbcl) (ignore kind))
- #+allegro (socket:make-socket :type :stream
- :address-family :file
- :connect :active
- :remote-filename path)
- #+cmu (sys:make-fd-stream (ext:connect-to-unix-socket path kind)
- :input t :output t :element-type
- (if bin '(unsigned-byte 8) 'character))
- #+(and sbcl net.sbcl.sockets)
- (net.sbcl.sockets:make-socket 'net.sbcl.sockets:unix-stream-socket
- :buffering :full :path path :type kind)
- #+(and sbcl db-sockets)
- (let ((socket (make-instance 'sockets:unix-socket :type :stream)))
- (sockets:socket-connect socket path)
- (sockets:socket-make-stream socket :input t :output t
- :buffering :none
- :element-type '(unsigned-byte 8)))
- #-(or allegro cmu (and sbcl (or net.sbcl.sockets db-sockets)))
- (open path :element-type (if bin '(unsigned-byte 8) 'character)
- :direction :io))
- ;;;
- ;;; }}}{{{ conditions
- ;;;
- (defun report-network-condition (cc out)
- (declare (stream out))
- (format out "[~s] ~s:~d~@[ ~?~]" (net-proc cc) (net-host cc)
- (net-port cc) (net-mesg cc) (net-args cc)))
- (define-condition network (error)
- ((proc :type symbol :reader net-proc :initarg :proc :initform nil)
- (host :type simple-string :reader net-host :initarg :host :initform "")
- (port :type (unsigned-byte 16) :reader net-port :initarg :port :initform 0)
- (mesg :type (or null simple-string) :reader net-mesg
- :initarg :mesg :initform nil)
- (args :type list :reader net-args :initarg :args :initform nil))
- (:report report-network-condition))
- (define-condition timeout (network)
- ((time :type (real 0) :reader timeout-time :initarg :time :initform 0))
- (:report (lambda (cc out)
- (declare (stream out))
- (report-network-condition cc out)
- (when (plusp (timeout-time cc))
- (format out " [timeout ~a sec]" (timeout-time cc))))))
- (define-condition login (network) ())
- (define-condition net-path (network) ())
- ;;;
- ;;; }}}{{{ `socket-service-port'
- ;;;
- (defstruct servent
- "see getservbyname(3) for details"
- (name "" :type simple-string) ; official name of service
- (aliases nil :type list) ; alias list
- (port -1 :type fixnum) ; port service resides at
- (proto :tcp :type symbol)) ; protocol to use
- (defun socket-service-port (&optional service (protocol "tcp"))
- "Return the SERVENT structure corresponding to the SERVICE.
- When SERVICE is NIL, return the list of all services."
- (with-open-file (fl #+unix "/etc/services" #+(or win32 mswindows)
- (concatenate 'string (getenv "windir")
- "/system32/drivers/etc/services")
- :direction :input)
- (loop :with name :and aliases :and port :and prot :and tokens
- :for st = (read-line fl nil nil)
- :until (null st)
- :unless (or (zerop (length st)) (char= #\# (schar st 0)))
- :do (setq tokens (string-tokens
- (nsubstitute
- #\Space #\/ (subseq st 0 (position #\# st))))
- name (string-downcase (string (first tokens)))
- aliases (mapcar (compose string-downcase string)
- (cdddr tokens))
- port (second tokens)
- prot (third tokens)) :and
- :if service
- :when (and (string-equal protocol prot)
- (or (string-equal service name)
- (member service aliases :test #'string-equal)))
- :return (make-servent :name name :aliases aliases :port port
- :proto prot)
- :end
- :else :collect (make-servent :name name :aliases aliases :port port
- :proto prot)
- :end
- :end
- :finally (when service
- (error "~s: service ~s is not found for protocol ~s"
- 'socket-service-port service protocol)))))
- ;;; }}}
- (provide :port-net)
- ;;; file net.lisp ends here