1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: sockets.lisp
6 ;;;; Purpose: Socket functions
7 ;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve
8 ;;;; Date Started: Jun 2003
11 ;;;; *************************************************************************
15 (eval-when (:compile-toplevel :load-toplevel :execute)
16 #+sbcl (require :sb-bsd-sockets)
17 #+lispworks (require "comm")
18 #+allegro (require :socket))
22 (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
23 "Create, bind and listen to an inet socket on *:PORT.
24 setsockopt SO_REUSEADDR if :reuse is not nil"
25 (declare (ignore kind))
26 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
30 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
31 (sb-bsd-sockets:socket-bind
32 socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
33 (sb-bsd-sockets:socket-listen socket 15)
36 (defun create-inet-listener (port &key (format :text) (reuse-address t))
37 #+cmu (declare (ignore format reuse-address))
38 #+cmu (ext:create-inet-listener port)
40 (socket:make-socket :connect :passive :local-port port :format format
44 (if (or (null port) (integerp port))
46 (error "illegal value for port: ~s" port)))
47 :reuse-address reuse-address)
48 #+sbcl (declare (ignore format))
49 #+sbcl (listen-to-inet-port :port port :reuse reuse-address)
50 #+clisp (declare (ignore format reuse-address))
51 #+clisp (ext:socket-server port)
53 (declare (ignore format))
55 (ccl:make-socket :connect :passive :local-port port
56 :reuse-address reuse-address)
57 #-(or allegro clisp cmu sbcl openmcl)
58 (warn "create-inet-listener not supported on this implementation")
61 (defun make-fd-stream (socket &key input output element-type)
63 (sys:make-fd-stream socket :input input :output output
64 :element-type element-type)
66 (sb-bsd-sockets:socket-make-stream socket :input input :output output
67 :element-type element-type)
68 #-(or cmu sbcl) (declare (ignore input output element-type))
69 #-(or cmu sbcl) socket
73 (defun accept-tcp-connection (listener)
74 "Returns (VALUES stream socket)"
76 (let ((sock (socket:accept-connection listener)))
79 (let ((sock (ext:socket-accept listener)))
83 (mp:process-wait-until-fd-usable listener :input)
84 (let ((sock (nth-value 0 (ext:accept-tcp-connection listener))))
85 (values (sys:make-fd-stream sock :input t :output t) sock)))
87 (when (sb-sys:wait-until-fd-usable
88 (sb-bsd-sockets:socket-file-descriptor listener) :input)
89 (let ((sock (sb-bsd-sockets:socket-accept listener)))
91 (sb-bsd-sockets:socket-make-stream
92 sock :element-type :default :input t :output t)
95 (let ((sock (ccl:accept-connection listener :wait t)))
97 #-(or allegro clisp cmu sbcl openmcl)
98 (warn "accept-tcp-connection not supported on this implementation")
102 (defmacro errorset (form display)
106 (declare (ignorable e))
108 (format t "~&Error: ~A~%" e)))))
110 (defun close-passive-socket (socket)
111 #+allegro (close socket)
112 #+clisp (ext:socket-server-close socket)
113 #+cmu (unix:unix-close socket)
114 #+sbcl (sb-unix:unix-close
115 (sb-bsd-sockets:socket-file-descriptor socket))
116 #+openmcl (close socket)
117 #-(or allegro clisp cmu sbcl openmcl)
118 (warn "close-passive-socket not supported on this implementation")
122 (defun close-active-socket (socket)
123 #+sbcl (sb-bsd-sockets:socket-close socket)
124 #-sbcl (close socket))
126 (defun ipaddr-to-dotted (ipaddr &key values)
127 "Convert from 32-bit integer to dotted string."
128 (declare (type (unsigned-byte 32) ipaddr))
129 (let ((a (logand #xff (ash ipaddr -24)))
130 (b (logand #xff (ash ipaddr -16)))
131 (c (logand #xff (ash ipaddr -8)))
132 (d (logand #xff ipaddr)))
135 (format nil "~d.~d.~d.~d" a b c d))))
137 (defun dotted-to-ipaddr (dotted &key (errorp t))
138 "Convert from dotted string to 32-bit integer."
139 (declare (string dotted))
141 (let ((ll (delimited-string-to-list dotted #\.)))
142 (+ (ash (parse-integer (first ll)) 24)
143 (ash (parse-integer (second ll)) 16)
144 (ash (parse-integer (third ll)) 8)
145 (parse-integer (fourth ll))))
147 (let ((ll (delimited-string-to-list dotted #\.)))
148 (+ (ash (parse-integer (first ll)) 24)
149 (ash (parse-integer (second ll)) 16)
150 (ash (parse-integer (third ll)) 8)
151 (parse-integer (fourth ll)))))))
154 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
156 (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
157 (sb-bsd-sockets:host-ent-name
158 (sb-bsd-sockets:get-host-by-address
159 (sb-bsd-sockets:make-inet-address ipaddr))))
162 (defun lookup-hostname (host &key ignore-cache)
164 (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
166 (sb-bsd-sockets:host-ent-address
167 (sb-bsd-sockets:get-host-by-name host))
168 (dotted-to-ipaddr (ipaddr-to-dotted host))))
171 (defun make-active-socket (server port)
172 "Returns (VALUES STREAM SOCKET)"
174 (let ((sock (socket:make-socket :remote-host server
178 (let ((sock (comm:open-tcp-stream server port)))
181 (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
184 (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port)
186 (sb-bsd-sockets:socket-make-stream
187 sock :input t :output t :element-type :default)
190 (let ((sock (ext:connect-to-inet-socket server port)))
192 (sys:make-fd-stream sock :input t :output t :element-type 'base-char)
195 (let ((sock (ext:socket-connect port server)))
198 (let ((sock (ccl:make-socket :remote-host server :remote-port port )))
202 (defun ipaddr-array-to-dotted (array)
203 (format nil "~{~D~^.~}" (coerce array 'list))
205 (format nil "~D.~D.~D.~D"
206 (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
208 (defun remote-host (socket)
209 #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket))
210 #+lispworks (nth-value 0 (comm:get-socket-peer-address socket))
211 #+sbcl (ipaddr-array-to-dotted
212 (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
213 #+cmu (nth-value 0 (ext:get-peer-host-and-port socket))
214 #+clisp (let* ((peer (ext:socket-stream-peer socket t))
215 (stop (position #\Space peer)))
216 ;; 2.37-2.39 had do-not-resolve-p backwards
217 (if stop (subseq peer 0 stop) peer))
218 #+openmcl (ccl:remote-host socket)