/contrib/server/net.lisp
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