PageRenderTime 85ms CodeModel.GetById 2ms app.highlight 75ms RepoModel.GetById 1ms app.codeStats 0ms

/contrib/server/net.lisp

https://github.com/dochang/debian-clfswm
Lisp | 781 lines | 676 code | 54 blank | 51 comment | 8 complexity | 46b82865f11358a6915b8a56ee149be9 MD5 | raw file
  1;;; Network Access
  2;;;
  3;;; Copyright (C) 1999-2008 by Sam Steingold
  4;;; This is open-source software.
  5;;; GNU Lesser General Public License (LGPL) is applicable:
  6;;; No warranty; you may copy/modify/redistribute under the same
  7;;; conditions with the source code.
  8;;; See <URL:http://www.gnu.org/copyleft/lesser.html>
  9;;; for details and the precise copyright document.
 10;;;
 11;;; $Id: net.lisp,v 1.64 2008/10/20 19:54:38 sds Exp $
 12;;; $Source: /cvsroot-fuse/clocc/clocc/src/port/net.lisp,v $
 13
 14(in-package :cl-user)
 15
 16(eval-when (:compile-toplevel :load-toplevel :execute)
 17  ;;(require "ext.lisp")
 18  ;; `getenv'
 19  ;;(require "sys.lisp")
 20  #+(or cmu scl) (require :simple-streams) ; for `set-socket-stream-format'
 21  #+cormanlisp (require :winsock)
 22  #+lispworks (require "comm")
 23  #+(and sbcl (not (or db-sockets net.sbcl.sockets)))
 24  (progn (require :sb-bsd-sockets) (pushnew :sb-bsd-sockets *features*)))
 25
 26(defpackage :port
 27  (:use :common-lisp)
 28  (:export :resolve-host-ipaddr
 29	   :ipaddr-to-dotted
 30	   :dotted-to-ipaddr
 31	   :ipaddr-closure
 32	   :hostent
 33	   :hostent-name
 34	   :hostent-aliases
 35	   :hostent-addr-list
 36	   :hostent-addr-type
 37	   :socket
 38	   :open-socket
 39	   :socket-host/port
 40	   :socket-string
 41	   :socket-server
 42	   :set-socket-stream-format
 43	   :socket-accept
 44	   :open-socket-server
 45	   :socket-server-close
 46	   :socket-server-host/port
 47	   :socket-service-port
 48	   :servent-name
 49	   :servent-aliases
 50	   :servent-port
 51	   :servent-proto
 52	   :servent-p
 53	   :servent
 54	   :network
 55	   :timeout
 56	   :login
 57	   :net-path))
 58
 59(in-package :port)
 60
 61
 62(define-condition code (error)
 63  ((proc :reader code-proc :initarg :proc :initform nil)
 64   (mesg :type (or null simple-string) :reader code-mesg
 65         :initarg :mesg :initform nil)
 66   (args :type list :reader code-args :initarg :args :initform nil))
 67  (:documentation "An error in the user code.")
 68  (:report (lambda (cc out)
 69             (declare (stream out))
 70             (format out "[~s]~@[ ~?~]" (code-proc cc) (code-mesg cc)
 71                     (code-args cc)))))
 72
 73(define-condition case-error (code)
 74  ((mesg :type simple-string :reader code-mesg :initform
 75         "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]"))
 76  (:documentation "An error in a case statement.
 77This carries the function name which makes the error message more useful."))
 78
 79
 80(define-condition not-implemented (code)
 81  ((mesg :type simple-string :reader code-mesg :initform
 82         "not implemented for ~a [~a]")
 83   (args :type list :reader code-args :initform
 84         (list (lisp-implementation-type) (lisp-implementation-version))))
 85  (:documentation "Your implementation does not support this functionality."))
 86
 87
 88(defmacro with-gensyms ((title &rest names) &body body)
 89  "Bind symbols in NAMES to gensyms.  TITLE is a string - `gensym' prefix.
 90Inspired by Paul Graham, <On Lisp>, p. 145."
 91  `(let (,@(mapcar (lambda (sy)
 92                     `(,sy (gensym ,(concatenate 'string title
 93                                                 (symbol-name sy) "-"))))
 94                   names))
 95     ,@body))
 96
 97(defmacro defconst (name type init doc)
 98  "Define a typed constant."
 99  `(progn (declaim (type ,type ,name))
100    ;; since constant redefinition must be the same under EQL, there
101    ;; can be no constants other than symbols, numbers and characters
102    ;; see ANSI CL spec 3.1.2.1.1.3 "Constant Variables"
103    (,(if (subtypep type '(or symbol number character)) 'defconstant 'defvar)
104     ,name (the ,type ,init) ,doc)))
105
106(defconst +eof+ cons (list '+eof+)
107  "*The end-of-file object.
108To be passed as the third arg to `read' and checked against using `eq'.")
109
110(defun string-tokens (string &key (start 0) end max
111                      ((:package *package*) (find-package :keyword)))
112  "Read from STRING repeatedly, starting with START, up to MAX tokens.
113Return the list of objects read and the final index in STRING.
114Binds `*package*' to the KEYWORD package (or argument),
115so that the bare symbols are read as keywords."
116  (declare (type (or null fixnum) max) (type fixnum start))
117  (if max
118      (do ((beg start) obj res (num 0 (1+ num)))
119          ((or (= max num) (and end (>= beg end)))
120           (values (nreverse res) beg))
121        (declare (fixnum beg num))
122        (setf (values obj beg)
123              (read-from-string string nil +eof+ :start beg :end end))
124        (if (eq obj +eof+)
125            (return (values (nreverse res) beg))
126            (push obj res)))
127      (with-input-from-string (st string :start start :end end)
128        (loop :for obj = (read st nil st)
129	   :until (eq obj st) :collect obj))))
130
131
132
133(defmacro compose (&rest functions)
134  "Macro: compose functions or macros of 1 argument into a lambda.
135E.g., (compose abs (dl-val zz) 'key) ==>
136  (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))"
137  (labels ((rec (xx yy)
138             (let ((rr (list (car xx) (if (cdr xx) (rec (cdr xx) yy) yy))))
139               (if (consp (car xx))
140                   (cons 'funcall (if (eq (caar xx) 'quote)
141                                      (cons (cadar xx) (cdr rr)) rr))
142                   rr))))
143    (with-gensyms ("COMPOSE-" arg)
144      `(lambda (,arg) ,(rec functions arg)))))
145
146
147
148
149;;;
150;;; {{{ name resolution
151;;;
152
153(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
154                ipaddr-to-dotted))
155(defun ipaddr-to-dotted (ipaddr)
156  "Number --> string."
157  (declare (type (unsigned-byte 32) ipaddr))
158  #+allegro (socket:ipaddr-to-dotted ipaddr)
159  #+(or openmcl ccl) (ccl:ipaddr-to-dotted ipaddr)
160  #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:ipaddr-to-dot-string ipaddr)
161  #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets))
162  (format nil "~d.~d.~d.~d"
163          (logand #xff (ash ipaddr -24)) (logand #xff (ash ipaddr -16))
164          (logand #xff (ash ipaddr -8)) (logand #xff ipaddr)))
165
166(declaim (ftype (function (string) (values (unsigned-byte 32)))
167                dotted-to-ipaddr))
168(defun dotted-to-ipaddr (dotted)
169  "String --> number."
170  (declare (string dotted))
171  #+allegro (socket:dotted-to-ipaddr dotted)
172  #+(or openmcl ccl) (ccl:dotted-to-ipaddr dotted)
173  #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:dot-string-to-ipaddr dotted)
174  #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets))
175  (let ((ll (string-tokens (substitute #\Space #\. dotted))))
176    (+ (ash (first ll) 24) (ash (second ll) 16)
177       (ash (third ll) 8) (fourth ll))))
178
179;#+(and sbcl (or db-sockets sb-bsd-sockets))
180;(declaim (ftype (function (vector) (values (unsigned-byte 32)))
181;                vector-to-ipaddr))
182#+(and sbcl (or db-sockets sb-bsd-sockets))
183(defun vector-to-ipaddr (vector)
184  (+ (ash (aref vector 0) 24)
185     (ash (aref vector 1) 16)
186     (ash (aref vector 2) 8)
187     (aref vector 3)))
188
189;#+(and sbcl (or db-sockets sb-bsd-sockets))
190;(declaim (ftype (function (vector) (values (unsigned-byte 32)))
191;                ipaddr-to-vector))
192#+(and sbcl (or db-sockets sb-bsd-sockets))
193(defun ipaddr-to-vector (ipaddr)
194  (vector (ldb (byte 8 24) ipaddr)
195          (ldb (byte 8 16) ipaddr)
196          (ldb (byte 8 8) ipaddr)
197          (ldb (byte 8 0) ipaddr)))
198
199(defstruct hostent
200  "see gethostbyname(3) for details"
201  (name "" :type simple-string) ; canonical name of host
202  (aliases nil :type list)      ; alias list
203  (addr-list nil :type list)    ; list of addresses
204  (addr-type 2 :type fixnum))   ; host address type
205
206(defun resolve-host-ipaddr (host)
207  "Call gethostbyname(3) or gethostbyaddr(3)."
208  #+allegro
209  (let* ((ipaddr
210          (etypecase host
211            (string
212             (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch)))
213                        host)
214                 (socket:dotted-to-ipaddr host)
215                 (socket:lookup-hostname host)))
216            (integer host)))
217         (name (socket:ipaddr-to-hostname ipaddr)))
218    (make-hostent :name name :addr-list
219                  (list (socket:ipaddr-to-dotted ipaddr))))
220  #+(and clisp syscalls)
221  (let ((he (posix:resolve-host-ipaddr host)))
222    (make-hostent :name (posix::hostent-name he)
223                  :aliases (posix::hostent-aliases he)
224                  :addr-list (posix::hostent-addr-list he)
225                  :addr-type (posix::hostent-addrtype he)))
226  #+(or cmu scl)
227  (let ((he (ext:lookup-host-entry host)))
228    (make-hostent :name (ext:host-entry-name he)
229                  :aliases (ext:host-entry-aliases he)
230                  :addr-list (mapcar #'ipaddr-to-dotted
231                                     (ext:host-entry-addr-list he))
232                  :addr-type (ext::host-entry-addr-type he)))
233  #+gcl (make-hostent :name (or (si:hostid-to-hostname host) host)
234                      :addr-list (list (si:hostname-to-hostid host)))
235  #+lispworks
236  (multiple-value-bind (name addr aliases)
237      (comm:get-host-entry host :fields '(:name :address :aliases))
238    (make-hostent :name name :addr-list (list (ipaddr-to-dotted addr))
239                  :aliases aliases))
240  #+(or openmcl ccl)
241  (let* ((ipaddr
242          (etypecase host
243            (string
244             (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch)))
245                        host)
246                 (dotted-to-ipaddr host)
247                 (ccl:lookup-hostname host)))
248            (integer host)))
249         (name (ccl:ipaddr-to-hostname ipaddr)))
250    (make-hostent :name name :addr-list (list (ccl:lookup-hostname ipaddr))))
251  #+(and sbcl sb-bsd-sockets)
252  (let ((he (sb-bsd-sockets:get-host-by-name host)))
253    (make-hostent :name (sb-bsd-sockets:host-ent-name he)
254                  :addr-list
255                  (loop for ipaddr in (sb-bsd-sockets:host-ent-addresses he)
256                    collect (format nil "~{~a~^.~}"
257                                    (loop for octect
258                                      being the elements of ipaddr
259                                      collect octect)))))
260  #+(and sbcl db-sockets)
261  (let* ((ipaddr
262          (etypecase host
263            (string
264             (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch)))
265                        host)
266                 (dotted-to-ipaddr host)
267                 (let ((hostent
268                        (sockets:get-host-by-name host)))
269                   (when hostent
270                     (vector-to-ipaddr
271                      (sockets::host-ent-address hostent))))))
272            (integer host)))
273         (name
274          (when ipaddr
275            (let ((hostent
276                   (sockets:get-host-by-address
277                    (ipaddr-to-vector ipaddr))))
278              (when (and hostent
279                         (sockets::host-ent-aliases hostent))
280                (first (sockets::host-ent-aliases hostent)))))))
281    (make-hostent :name name :addr-list (list ipaddr)))
282  #+(and sbcl net.sbcl.sockets)
283  (let ((he (net.sbcl.sockets:lookup-host-entry host)))
284    (make-hostent :name (net.sbcl.sockets:host-entry-name he)
285                  :aliases (net.sbcl.sockets:host-entry-aliases he)
286                  :addr-list (mapcar #'ipaddr-to-dotted
287                                     (net.sbcl.sockets:host-entry-addr-list he))
288                  :addr-type (net.sbcl.sockets::host-entry-addr-type he)))
289  #-(or allegro (and clisp syscalls) cmu gcl lispworks openmcl ccl
290        (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl)
291  (error 'not-implemented :proc (list 'resolve-host-ipaddr host)))
292
293(defun ipaddr-closure (address)
294  "Resolve all addresses and names associated with the argument."
295  (let ((a2he (make-hash-table :test 'equalp))
296        (he2a (make-hash-table :test 'equalp)))
297    (labels ((handle (s)
298               (unless (gethash s a2he)
299                 (let ((he (resolve-host-ipaddr s)))
300                   (setf (gethash s a2he) he)
301                   (push s (gethash he he2a))
302                   (handle (hostent-name he))
303                   (mapc #'handle (hostent-aliases he))
304                   (mapc #'handle (hostent-addr-list he))))))
305      (handle address))
306    (values he2a a2he)))
307
308;;;
309;;; }}}{{{ sockets
310;;;
311
312(deftype socket ()
313  #+abcl 'to-way-stream
314  #+allegro 'excl::socket-stream
315  #+clisp 'stream
316  #+(or cmu scl) 'stream ; '(or stream:socket-simple-stream sys:fd-stream)
317  #+gcl 'stream
318  #+lispworks 'comm:socket-stream
319  #+(or openmcl ccl) 'ccl::socket
320  #+(and sbcl (or db-sockets sb-bsd-sockets)) 'sb-sys:fd-stream
321  #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:stream-socket
322  #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl
323        (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) 'stream)
324
325(defun open-socket (host port &optional bin)
326  "Open a socket connection to HOST at PORT."
327  (declare (type (or integer string) host) (fixnum port)
328           #+(or cmu scl) (ignore bin))
329  (let ((host (etypecase host
330                (string host)
331                (integer (hostent-name (resolve-host-ipaddr host))))))
332    #+abcl (ext:get-socket-stream
333            (sys:make-socket host port)
334            :element-type (if bin '(unsigned-byte 8) 'character))
335    #+allegro (socket:make-socket :remote-host host :remote-port port
336                                  :format (if bin :binary :text))
337    #+clisp (#+lisp=cl ext:socket-connect #-lisp=cl lisp:socket-connect
338                       port host :element-type
339                       (if bin '(unsigned-byte 8) 'character))
340    #+(or cmu scl)
341    (make-instance 'stream:socket-simple-stream :direction :io
342                   :remote-host host :remote-port port)
343    #+gcl (si:socket port :host host)
344    #+lispworks (comm:open-tcp-stream host port :direction :io :element-type
345                                      (if bin 'unsigned-byte 'base-char))
346    #+(or mcl ccl) (ccl:make-socket :remote-host host :remote-port port
347                           :format (if bin :binary :text))
348    #+(and sbcl db-sockets)
349    (let ((socket (make-instance 'sockets:inet-socket
350                                 :type :stream :protocol :tcp)))
351      (sockets:socket-connect socket
352                              (sockets::host-ent-address
353                               (sockets:get-host-by-name host))
354                              port)
355      (sockets:socket-make-stream
356       socket :input t :output t :buffering (if bin :none :line)
357       :element-type (if bin '(unsigned-byte 8) 'character)))
358    #+(and sbcl net.sbcl.sockets)
359    (net.sbcl.sockets:make-socket
360     (if bin
361         'net.sbcl.sockets:binary-stream-socket
362         'net.sbcl.sockets:character-stream-socket)
363     :port port :host host)
364    #+(and sbcl sb-bsd-sockets)
365    (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
366                                 :type :stream :protocol :tcp)))
367      (sb-bsd-sockets:socket-connect socket
368				     (sb-bsd-sockets::host-ent-address
369				      (sb-bsd-sockets:get-host-by-name host))
370				     port)
371      (sb-bsd-sockets:socket-make-stream
372       socket :input t :output t :buffering (if bin :none :line)
373       :element-type (if bin '(unsigned-byte 8) 'character)))
374    #-(or abcl allegro clisp cmu gcl lispworks mcl ccl
375          (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
376    (error 'not-implemented :proc (list 'open-socket host port bin))))
377
378(defun set-socket-stream-format (socket format)
379  "switch between binary and text output"
380  #+clisp (setf (stream-element-type socket) format)
381  #+(or acl cmu lispworks scl)
382  (declare (ignore socket format)) ; bivalent streams
383  #-(or acl clisp cmu lispworks scl)
384  (error 'not-implemented :proc (list 'set-socket-stream-format socket format)))
385
386#+(and sbcl sb-bsd-sockets)
387(defun funcall-on-sock (function sock)
388  "Apply function (getsockname/getpeername) on socket, return host/port as two values"
389  (let ((sockaddr (sockint::allocate-sockaddr-in)))
390    (funcall function (sb-sys:fd-stream-fd sock) sockaddr sockint::size-of-sockaddr-in)
391    (let ((host (coerce (loop :for i :from 0 :below 4
392                          :collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i))
393			'(vector (unsigned-byte 8) 4)))
394	  (port (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0))
395		   (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1))))
396      (sockint::free-sockaddr-in sockaddr)
397      (values host port))))
398
399(defun socket-host/port (sock)
400  "Return the remote and local host&port, as 4 values."
401  (declare (type socket sock))
402  #+allegro (values (socket:ipaddr-to-dotted (socket:remote-host sock))
403                    (socket:remote-port sock)
404                    (socket:ipaddr-to-dotted (socket:local-host sock))
405                    (socket:local-port sock))
406  #+clisp (flet ((ip (ho) (subseq ho 0 (position #\Space ho :test #'char=))))
407            (multiple-value-bind (ho1 po1)
408                (#+lisp=cl  ext:socket-stream-peer
409                 #-lisp=cl lisp:socket-stream-peer sock)
410              (multiple-value-bind (ho2 po2)
411                  (#+lisp=cl  ext:socket-stream-local
412                   #-lisp=cl lisp:socket-stream-local sock)
413                (values (ip ho1) po1
414                        (ip ho2) po2))))
415  #+(or cmu scl)
416  (let ((fd (sys:fd-stream-fd sock)))
417    (multiple-value-bind (ho1 po1) (ext:get-peer-host-and-port fd)
418      (multiple-value-bind (ho2 po2) (ext:get-socket-host-and-port fd)
419        (values (ipaddr-to-dotted ho1) po1
420                (ipaddr-to-dotted ho2) po2))))
421  #+gcl (let ((peer (si:getpeername sock))
422              (loc (si:getsockname sock)))
423          (values (car peer) (caddr peer)
424                  (car loc) (caddr loc)))
425  #+lispworks
426  (multiple-value-bind (ho1 po1) (comm:socket-stream-peer-address sock)
427    (multiple-value-bind (ho2 po2) (comm:socket-stream-address sock)
428      (values (ipaddr-to-dotted ho1) po1
429              (ipaddr-to-dotted ho2) po2)))
430  #+(or mcl ccl)
431  (values (ccl:ipaddr-to-dotted (ccl:remote-host sock))
432          (ccl:remote-port sock)
433          (ccl:ipaddr-to-dotted (ccl:local-host sock))
434          (ccl:local-port sock))
435  #+(and sbcl db-sockets)
436  (let ((sock (sb-sys:fd-stream-fd sock)))
437    (multiple-value-bind (remote remote-port) (sockets:socket-peername sock)
438      (multiple-value-bind (local local-port) (sockets:socket-name sock)
439        (values (ipaddr-to-dotted (vector-to-ipaddr remote))
440                remote-port
441                (ipaddr-to-dotted (vector-to-ipaddr local))
442                local-port))))
443  #+(and sbcl net.sbcl.sockets)
444  (net.sbcl.sockets:socket-host-port sock)
445  #+(and sbcl sb-bsd-sockets)
446  (multiple-value-bind (remote remote-port)
447      (funcall-on-sock #'sockint::getpeername sock)
448    (multiple-value-bind (local local-port)
449	(funcall-on-sock #'sockint::getsockname sock)
450      (values (ipaddr-to-dotted (vector-to-ipaddr remote))
451	      remote-port
452	      (ipaddr-to-dotted (vector-to-ipaddr local))
453	      local-port)))
454  #-(or allegro clisp cmu gcl lispworks mcl ccl
455        (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
456  (error 'not-implemented :proc (list 'socket-host/port sock)))
457
458(defun socket-string (sock)
459  "Print the socket local&peer host&port to a string."
460  (declare (type socket sock))
461  (with-output-to-string (stream)
462    (print-unreadable-object (sock stream :type t :identity t)
463      (multiple-value-bind (ho1 po1 ho2 po2) (socket-host/port sock)
464        (format stream "[local: ~a:~d] [peer: ~s:~d]" ho2 po2 ho1 po1)))))
465
466;;;
467;;; }}}{{{ socket-servers
468;;;
469
470#+lispworks (defstruct socket-server proc mbox port)
471#-lispworks
472(deftype socket-server ()
473  #+abcl 'ext:javaobject
474  #+allegro 'acl-socket::socket-stream-internet-passive
475  #+(and clisp      lisp=cl)   'ext:socket-server
476  #+(and clisp (not lisp=cl)) 'lisp:socket-server
477  #+(or cmu scl) 'integer
478  #+gcl 'si:socket-stream
479  #+(or mcl ccl) 'ccl::listener-socket
480  #+(and sbcl db-sockets) 'sb-sys:fd-stream
481  #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:passive-socket
482  #+(and sbcl sb-bsd-sockets) 'sb-bsd-sockets:inet-socket
483  #-(or abcl allegro clisp cmu gcl mcl ccl
484        (and sbcl (or net.sbcl.sockets db-sockets)) scl) t)
485
486(defun open-socket-server (&optional port)
487  "Open a `generic' socket server."
488  (declare (type (or null integer #-sbcl socket) port))
489  #+abcl (ext:make-server-socket port)
490  #+allegro (socket:make-socket :connect :passive :local-port
491                                (when (integerp port) port))
492  #+clisp (#+lisp=cl ext:socket-server #-lisp=cl lisp:socket-server port)
493  #+(or cmu scl) (ext:create-inet-listener (or port 0) :stream :reuse-address t)
494  #+gcl (si:make-socket-pair port) ; FIXME
495  #+lispworks (let ((mbox (mp:make-mailbox :size 1)))
496                (make-socket-server
497                 :mbox mbox :port port
498                 :proc (comm:start-up-server
499                        :function (lambda (sock) (mp:mailbox-send mbox sock))
500                        :service port)))
501  #+(or mcl ccl)
502  (ccl:make-socket :connect :passive
503                   :type :stream
504                   :reuse-address t
505                   :local-port (or port 0))
506  #+(and sbcl db-sockets)
507  (let ((socket (make-instance 'sockets:inet-socket
508                               :type :stream :protocol :tcp)))
509    (sockets:socket-bind socket (vector 0 0 0 0) (or port 0)))
510  #+(and sbcl net.sbcl.sockets)
511  (net.sbcl.sockets:make-socket 'net.sbcl.sockets:passive-socket :port port)
512  #+(and sbcl sb-bsd-sockets)
513  (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
514                             :type :stream
515                             :protocol :tcp)))
516    (setf (sb-bsd-sockets:sockopt-reuse-address sock) t)
517    (sb-bsd-sockets:socket-bind sock (vector 0 0 0 0) (or port 0))
518    (sb-bsd-sockets:socket-listen sock 15)
519    sock)
520  #-(or abcl allegro clisp cmu gcl lispworks mcl ccl
521        (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
522  (error 'not-implemented :proc (list 'open-socket-server port)))
523
524(defun socket-accept (serv &key bin wait)
525  "Accept a connection on a socket server (passive socket).
526Keyword arguments are:
527 BIN - create a binary stream;
528 WAIT - wait for the connection this many seconds
529        (the default is NIL - wait forever).
530Returns a socket stream or NIL."
531  (declare (type socket-server serv)
532           #+(or (and allegro (version>= 6)) openmcl ccl)
533           (ignore bin))
534  #+abcl (ext:get-socket-stream
535          (ext:socket-accept serv)
536          :element-type (if bin '(unsigned-byte 8) 'character))
537  #+allegro (let* ((fmt (if bin :binary :text))
538                   #+allegro-v5.0
539                   (excl:*default-external-format* fmt)
540                   (sock (if wait
541                             (if (plusp wait)
542                                 (mp:with-timeout (wait)
543                                   (socket:accept-connection serv :wait t))
544                                 (socket:accept-connection serv :wait nil))
545                             (socket:accept-connection serv :wait t))))
546              (when sock
547                ;; From: John Foderaro <jkf@franz.com>
548                ;; Date: Sun, 12 Nov 2000 16:58:28 -0800
549                ;; in ACL6 and later, all sockets are bivalent (both
550                ;; text and binary) and thus there's no need to convert
551                ;; between the element types.
552                #+allegro-v5.0
553                (unless (eq (socket:socket-format sock) fmt)
554                  (warn "~s: ACL5 cannot modify socket format"
555                        'socket-accept))
556                #+allegro-v4.3
557                (socket:set-socket-format sock fmt)
558                sock))
559  #+clisp (multiple-value-bind (sec usec) (floor (or wait 0))
560            (when (#+lisp=cl ext:socket-wait #-lisp=cl lisp:socket-wait
561                             serv (and wait sec) (round usec 1d-6))
562              (#+lisp=cl ext:socket-accept #-lisp=cl lisp:socket-accept
563                         serv :element-type
564                         (if bin '(unsigned-byte 8) 'character))))
565  #+(or cmu scl)
566  (when (sys:wait-until-fd-usable serv :input wait)
567    (sys:make-fd-stream (ext:accept-tcp-connection serv)
568                        :buffering (if bin :full :line)
569                        :input t :output t :element-type
570                        (if bin '(unsigned-byte 8) 'character)))
571  #+gcl (si:accept-socket-connection serv bin wait) ; FIXME
572  #+lispworks (make-instance
573               'comm:socket-stream :direction :io
574               :socket (mp:mailbox-read (socket-server-mbox serv))
575               :element-type (if bin 'unsigned-byte 'base-char))
576  ;; For ccl, as wait is a boolean, the time to wait is ignored.
577  #+(or mcl ccl) (ccl:accept-connection serv :wait (not wait))
578  #+(and sbcl db-sockets)
579  (let ((new-connection (sockets:socket-accept serv)))
580    ;; who needs WAIT and BIN anyway :-S
581    new-connection)
582  #+(and sbcl net.sbcl.sockets)
583  (net.sbcl.sockets:accept-connection
584   serv
585   (if bin
586       'net.sbcl.sockets:binary-stream-socket
587       'net.sbcl.sockets:character-stream-socket)
588   :wait wait)
589  #+(and sbcl sb-bsd-sockets)
590  (progn
591    (setf (sb-bsd-sockets:non-blocking-mode serv) wait)
592    (let ((s (sb-bsd-sockets:socket-accept serv)))
593      (if s
594	  (sb-bsd-sockets:socket-make-stream
595           s :input t :output t
596           :element-type (if bin '(unsigned-byte 8) 'character)
597           :buffering (if bin :full :line))
598	  (sleep wait))))
599  #-(or abcl allegro clisp cmu gcl lispworks mcl ccl
600        (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
601  (error 'not-implemented :proc (list 'socket-accept serv bin)))
602
603(defun socket-server-close (server)
604  "Close the server."
605  (declare (type socket-server server))
606  #+abcl (ext:server-socket-close server)
607  #+allegro (close server)
608  #+clisp (#+lisp=cl  ext:socket-server-close
609           #-lisp=cl lisp:socket-server-close server)
610  #+(or cmu scl) (unix:unix-close server)
611  #+gcl (close server)
612  #+lispworks (mp:process-kill (socket-server-proc server))
613  #+(or openmcl ccl) (close server)
614  #+(and sbcl db-sockets) (sockets:socket-close server)
615  #+(and sbcl net.sbcl.sockets) (close server)
616  #+(and sbcl sb-bsd-sockets) (sb-bsd-sockets:socket-close server)
617  #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl
618        (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
619  (error 'not-implemented :proc (list 'socket-server-close server)))
620
621(defun socket-server-host/port (server)
622  "Return the local host&port on which the server is running, as 2 values."
623  (declare (type socket-server server))
624  #+allegro (values (socket:ipaddr-to-dotted (socket:local-host server))
625                    (socket:local-port server))
626  #+(and clisp      lisp=cl)  (values  (ext:socket-server-host server)
627                                       (ext:socket-server-port server))
628  #+(and clisp (not lisp=cl)) (values (lisp:socket-server-host server)
629                                      (lisp:socket-server-port server))
630  #+(or cmu scl)
631  (values (ipaddr-to-dotted (car (ext:host-entry-addr-list
632                                  (ext:lookup-host-entry "localhost"))))
633          (nth-value 1 (ext:get-socket-host-and-port server)))
634  #+gcl (let ((sock (si:getsockname server)))
635          (values (car sock) (caddr sock)))
636  #+lispworks (values (ipaddr-to-dotted (comm:get-host-entry
637                                         "localhost" :fields '(:address)))
638                      (socket-server-port server))
639  #+(or openmcl ccl)
640  (values (ccl:ipaddr-to-dotted (ccl:local-host server))
641          (ccl:local-port server))
642  #+(and sbcl db-sockets)
643  (multiple-value-bind (addr port) (sockets:socket-name server)
644    (values (vector-to-ipaddr addr) port))
645  #+(and sbcl net.sbcl.sockets)
646  (net.sbcl.sockets:passive-socket-host-port server)
647  #+(and sbcl sb-bsd-sockets)
648  (multiple-value-bind (addr port) (sb-bsd-sockets:socket-name server)
649    (values (ipaddr-to-dotted (vector-to-ipaddr addr)) port))
650  #-(or allegro clisp cmu gcl lispworks openmcl ccl
651        (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl)
652  (error 'not-implemented :proc (list 'socket-server-host/port server)))
653
654;;;
655;;; }}}{{{ for CLX
656;;;
657
658(defun wait-for-stream (stream &optional timeout)
659  "Sleep until there is input on the STREAM, or for TIMEOUT seconds,
660whichever comes first. If there was a timeout, return NIL."
661  #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
662            (#+lisp=cl ext:socket-status #-lisp=cl lisp:socket-status
663                       stream (and timeout sec) (round usec 1d-6)))
664  #+(or cmu scl)
665  (#+mp mp:process-wait-until-fd-usable #-mp sys:wait-until-fd-usable
666        (system:fd-stream-fd stream) :input timeout)
667  #+(or openmcl ccl)
668  (ccl:make-socket :type :stream
669                   :address-family :file
670                   :connect :active
671                   :format :text ;;(if bin :binary :text)
672                   :remote-filename #P"");;path)
673  #+(and sbcl net.sbcl.sockets)
674  (net.sbcl.sockets:wait-for-input-data stream timeout)
675  #+(and sbcl db-sockets)
676  (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout)
677  #-(or clisp cmu (and sbcl (or net.sbcl.sockets db-sockets)) scl)
678  (error 'not-implemented :proc (list 'wait-for-stream stream timeout)))
679
680(defun open-unix-socket (path &key (kind :stream) bin)
681  "Opens a unix socket. Path is the location.
682Kind can be :stream or :datagram."
683  (declare (simple-string path) #-(or cmu sbcl) (ignore kind))
684  #+allegro (socket:make-socket :type :stream
685                                :address-family :file
686                                :connect :active
687                                :remote-filename path)
688  #+cmu (sys:make-fd-stream (ext:connect-to-unix-socket path kind)
689                            :input t :output t :element-type
690                            (if bin '(unsigned-byte 8) 'character))
691  #+(and sbcl net.sbcl.sockets)
692  (net.sbcl.sockets:make-socket 'net.sbcl.sockets:unix-stream-socket
693                                :buffering :full :path path :type kind)
694  #+(and sbcl db-sockets)
695  (let ((socket (make-instance 'sockets:unix-socket :type :stream)))
696    (sockets:socket-connect socket path)
697    (sockets:socket-make-stream socket :input t :output t
698                                :buffering :none
699                                :element-type '(unsigned-byte 8)))
700  #-(or allegro cmu (and sbcl (or net.sbcl.sockets db-sockets)))
701  (open path :element-type (if bin '(unsigned-byte 8) 'character)
702        :direction :io))
703
704;;;
705;;; }}}{{{ conditions
706;;;
707
708(defun report-network-condition (cc out)
709  (declare (stream out))
710  (format out "[~s] ~s:~d~@[ ~?~]" (net-proc cc) (net-host cc)
711          (net-port cc) (net-mesg cc) (net-args cc)))
712
713(define-condition network (error)
714  ((proc :type symbol :reader net-proc :initarg :proc :initform nil)
715   (host :type simple-string :reader net-host :initarg :host :initform "")
716   (port :type (unsigned-byte 16) :reader net-port :initarg :port :initform 0)
717   (mesg :type (or null simple-string) :reader net-mesg
718         :initarg :mesg :initform nil)
719   (args :type list :reader net-args :initarg :args :initform nil))
720  (:report report-network-condition))
721
722(define-condition timeout (network)
723  ((time :type (real 0) :reader timeout-time :initarg :time :initform 0))
724  (:report (lambda (cc out)
725             (declare (stream out))
726             (report-network-condition cc out)
727             (when (plusp (timeout-time cc))
728               (format out " [timeout ~a sec]" (timeout-time cc))))))
729
730(define-condition login (network) ())
731(define-condition net-path (network) ())
732
733;;;
734;;; }}}{{{ `socket-service-port'
735;;;
736
737(defstruct servent
738  "see getservbyname(3) for details"
739  (name "" :type simple-string) ; official name of service
740  (aliases nil :type list)      ; alias list
741  (port -1 :type fixnum)        ; port service resides at
742  (proto :tcp :type symbol))    ; protocol to use
743
744(defun socket-service-port (&optional service (protocol "tcp"))
745  "Return the SERVENT structure corresponding to the SERVICE.
746When SERVICE is NIL, return the list of all services."
747  (with-open-file (fl #+unix "/etc/services" #+(or win32 mswindows)
748                      (concatenate 'string (getenv "windir")
749                                   "/system32/drivers/etc/services")
750                      :direction :input)
751    (loop :with name :and aliases :and port :and prot :and tokens
752      :for st = (read-line fl nil nil)
753      :until (null st)
754      :unless (or (zerop (length st)) (char= #\# (schar st 0)))
755        :do (setq tokens (string-tokens
756                          (nsubstitute
757                           #\Space #\/ (subseq st 0 (position #\# st))))
758                  name (string-downcase (string (first tokens)))
759                  aliases (mapcar (compose string-downcase string)
760                                  (cdddr tokens))
761                  port (second tokens)
762                  prot (third tokens)) :and
763        :if service
764          :when (and (string-equal protocol prot)
765                     (or (string-equal service name)
766                         (member service aliases :test #'string-equal)))
767            :return (make-servent :name name :aliases aliases :port port
768                                  :proto prot)
769          :end
770          :else :collect (make-servent :name name :aliases aliases :port port
771                                       :proto prot)
772        :end
773      :end
774      :finally (when service
775                 (error "~s: service ~s is not found for protocol ~s"
776                        'socket-service-port service protocol)))))
777
778;;; }}}
779
780(provide :port-net)
781;;; file net.lisp ends here