contrib/server/net.lisp

   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.
  77 This 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.
  90 Inspired 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.
 108 To 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.
 113 Return the list of objects read and the final index in STRING.
 114 Binds `*package*' to the KEYWORD package (or argument),
 115 so 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.
 135 E.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).
 526 Keyword arguments are:
 527  BIN - create a binary stream;
 528  WAIT - wait for the connection this many seconds
 529         (the default is NIL - wait forever).
 530 Returns 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,
 660 whichever 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.
 682 Kind 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.
 746 When 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