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