genera.lisp - clic - Clic is an command line interactive client for gopher writ… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
genera.lisp (9940B) | |
--- | |
1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: USOCKET; Base: 1… | |
2 | |
3 | |
4 ;;;; See LICENSE for licensing information. | |
5 | |
6 (in-package :usocket) | |
7 | |
8 (defclass genera-socket () | |
9 ((foreign-address :initform 0 :initarg :foreign-address :accessor gs… | |
10 (foreign-port :initform 0 :initarg :foreign-port :accessor gs-forei… | |
11 (local-address :initform 0 :initarg :local-address :accessor gs-loc… | |
12 (local-port :initform 0 :initarg :local-port :accessor gs-local-por… | |
13 ) | |
14 | |
15 (defclass genera-stream-socket (genera-socket) | |
16 ((stream :initform nil :initarg :stream :accessor gs-stream)) | |
17 ) | |
18 | |
19 (defclass genera-stream-server-socket (genera-socket) | |
20 ((backlog :initform nil :initarg :backlog :accessor gs-backlog) | |
21 (element-type :initform nil :initarg :element-type :accessor gs-ele… | |
22 (pending-connections :initform nil :accessor gs-pending-connections… | |
23 ) | |
24 | |
25 (defclass genera-datagram-socket (genera-socket) | |
26 ((connection :initform nil :initarg :connection :accessor gs-connect… | |
27 ) | |
28 | |
29 (defun host-to-host-object (host) | |
30 (let ((host (host-to-hostname host))) | |
31 (cond ((string-equal host "localhost") | |
32 net:*local-host*) | |
33 ((ip-address-string-p host) | |
34 (let ((quad (dotted-quad-to-vector-quad host))) | |
35 ;;---*** NOTE: This test is temporary until we have a loopb… | |
36 (if (= (aref quad 0) 127) | |
37 net:*local-host* | |
38 (net:parse-host (format nil "INTERNET|~A" host))))) | |
39 (t | |
40 (net:parse-host host))))) | |
41 | |
42 (defun element-type-to-format (element-type protocol) | |
43 (cond ((null element-type) | |
44 (ecase protocol | |
45 (:stream :text) | |
46 (:datagram :binary))) | |
47 ((subtypep element-type 'character) | |
48 :text) | |
49 (t :binary))) | |
50 | |
51 (defun handle-condition (condition &optional (socket nil) (host-or-ip ni… | |
52 (typecase condition | |
53 ;;---*** TODO: Add additional conditions as appropriate | |
54 (sys:connection-refused | |
55 (error 'connection-refused-error :socket socket)) | |
56 ((or tcp::tcp-destination-unreachable-during-connection tcp::udp-des… | |
57 (error 'host-unreachable-error :socket socket)) | |
58 (sys:host-not-responding-during-connection | |
59 (error 'timeout-error :socket socket)) | |
60 (sys:unknown-host-name | |
61 (error 'ns-host-not-found-error :host-or-ip host-or-ip)) | |
62 (sys:network-error | |
63 (error 'unknown-error :socket socket :real-error condition :errno … | |
64 | |
65 (defun socket-connect (host port &key (protocol :stream) element-type | |
66 timeout deadline (nodelay nil nodelay-p) | |
67 local-host local-port) | |
68 (declare (ignore local-host)) | |
69 (when deadline | |
70 (unsupported 'deadline 'socket-connect)) | |
71 (when (and nodelay-p (not (eq nodelay :if-supported))) | |
72 (unsupported 'nodelay 'socket-connect)) | |
73 (with-mapped-conditions (nil host) | |
74 (ecase protocol | |
75 (:stream | |
76 (let* ((host-object (host-to-host-object host)) | |
77 (format (element-type-to-format element-type protocol)) | |
78 (characters (eq format :text)) | |
79 (timeout (if timeout | |
80 (* 60 timeout) | |
81 tcp:*tcp-connect-timeout*)) | |
82 (stream (tcp:open-tcp-stream host-object port local-port | |
83 :characters characters | |
84 :ascii-translation characters | |
85 :timeout timeout)) | |
86 (gs (make-instance 'genera-stream-socket | |
87 :stream stream))) | |
88 (setf (gs-foreign-address gs) (scl:send stream :foreign-addres… | |
89 (setf (gs-foreign-port gs) (scl:send stream :foreign-port)) | |
90 (setf (gs-local-address gs) (scl:send stream :local-address)) | |
91 (setf (gs-local-port gs) (scl:send stream :local-port)) | |
92 (make-stream-socket :socket gs :stream stream))) | |
93 (:datagram | |
94 ;;---*** TODO | |
95 (unsupported 'datagram 'socket-connect))))) | |
96 | |
97 (defmethod socket-close ((usocket usocket)) | |
98 (with-mapped-conditions (usocket) | |
99 (socket-close (socket usocket)))) | |
100 | |
101 (defmethod socket-close ((socket genera-stream-socket)) | |
102 (with-slots (stream) socket | |
103 (when stream | |
104 (scl:send (shiftf stream nil) :close nil)))) | |
105 | |
106 (defmethod socket-close ((socket genera-stream-server-socket)) | |
107 (with-slots (local-port pending-connections) socket | |
108 (when local-port | |
109 (tcp:remove-tcp-port-listener local-port)) | |
110 (dolist (tcb pending-connections) | |
111 (tcp::reject-tcb tcb)))) | |
112 | |
113 (defmethod socket-close ((socket genera-datagram-socket)) | |
114 (with-slots (connection) socket | |
115 (when connection | |
116 (scl:send (shiftf connection nil) :close nil)) | |
117 ;;---*** TODO: listening? | |
118 )) | |
119 | |
120 ;;; Cribbed from TCP::MAKE-TCB | |
121 (defun gensym-tcp-port () | |
122 (loop as number = (incf tcp::*last-gensym-port-number*) then tcp::*las… | |
123 do (cond ((loop for existing-tcb in tcp::*tcb-list* | |
124 thereis (= number (tcp::tcb-local-port existing-… | |
125 ((and (<= #.(expt 2 10) number) (< number #.(expt 2 16)… | |
126 (return number)) | |
127 (t | |
128 (setq tcp::*last-gensym-port-number* #.(expt 2 10)))))) | |
129 | |
130 (defun socket-listen (host port &key (reuse-address nil reuse-address-p) | |
131 (reuseaddress nil reuseaddress-p) | |
132 (backlog 5) (element-type 'characte… | |
133 (let ((host-object (host-to-host-object host)) | |
134 (port (if (zerop port) (gensym-tcp-port) port)) | |
135 (reuse-address (cond (reuse-address-p reuse-address) | |
136 (reuseaddress-p reuseaddress) | |
137 (t nil)))) | |
138 (when (<= port 1024) | |
139 ;; Don't allow listening on "privileged" ports to mimic Unix/Linux… | |
140 (error 'operation-not-permitted-error :socket nil)) | |
141 (when (tcp:tcp-port-protocol-name port) | |
142 ;; Can't replace a Genera server | |
143 (error 'address-in-use-error :socket nil)) | |
144 (when (tcp:tcp-port-listener port) | |
145 (unless reuse-address | |
146 (error 'address-in-use-error :socket nil))) | |
147 (let ((gs (make-instance 'genera-stream-server-socket | |
148 :backlog backlog | |
149 :element-type element-type))) | |
150 (setf (gs-local-address gs) | |
151 (loop for (network address) in (scl:send host-object :networ… | |
152 when (typep network 'tcp:internet-network) | |
153 return address)) | |
154 (setf (gs-local-port gs) port) | |
155 (flet ((add-to-queue (tcb) | |
156 (cond ((and (not (zerop (gs-local-address gs))) | |
157 (not (= (gs-local-address gs) (tcp::tcb-local… | |
158 ;; Reject if not destined for the proper address | |
159 (tcp::reject-tcb tcb)) | |
160 ((<= (length (gs-pending-connections gs)) (gs-backl… | |
161 (tcp::accept-tcb tcb) | |
162 (tcp::tcb-travel-through-states tcb "Accept" nil :… | |
163 (setf (gs-pending-connections gs) | |
164 (append (gs-pending-connections gs) (list tc… | |
165 (t | |
166 ;; Reject if backlog is full | |
167 (tcp::reject-tcb tcb))))) | |
168 (tcp:add-tcp-port-listener port #'add-to-queue)) | |
169 (make-stream-server-socket gs :element-type element-type)))) | |
170 | |
171 (defmethod socket-accept ((socket stream-server-usocket) &key element-ty… | |
172 (with-slots (pending-connections) (socket socket) | |
173 (loop | |
174 (process:process-block "Wait for connection" #'(lambda () | |
175 (not (null pendin… | |
176 (let ((tcb (pop pending-connections))) | |
177 (when tcb | |
178 (let* ((format (element-type-to-format (or element-type (eleme… | |
179 :stream)) | |
180 (characters (eq format :text)) | |
181 (stream (tcp::make-tcp-stream tcb | |
182 :characters characters | |
183 :ascii-translation charac… | |
184 (gs (make-instance 'genera-stream-socket | |
185 :stream stream))) | |
186 (setf (gs-foreign-address gs) (scl:send stream :foreign-addr… | |
187 (setf (gs-foreign-port gs) (scl:send stream :foreign-port)) | |
188 (setf (gs-local-address gs) (scl:send stream :local-address)) | |
189 (setf (gs-local-port gs) (scl:send stream :local-port)) | |
190 (return (make-stream-socket :socket gs :stream stream)))))))) | |
191 | |
192 (defmethod get-local-address ((usocket usocket)) | |
193 (hbo-to-vector-quad (gs-local-address (socket usocket)))) | |
194 | |
195 (defmethod get-peer-address ((usocket stream-usocket)) | |
196 (hbo-to-vector-quad (gs-foreign-address (socket usocket)))) | |
197 | |
198 (defmethod get-local-port ((usocket usocket)) | |
199 (gs-local-port (socket usocket))) | |
200 | |
201 (defmethod get-peer-port ((usocket stream-usocket)) | |
202 (gs-foreign-port (socket usocket))) | |
203 | |
204 (defmethod get-local-name ((usocket usocket)) | |
205 (values (get-local-address usocket) | |
206 (get-local-port usocket))) | |
207 | |
208 (defmethod get-peer-name ((usocket stream-usocket)) | |
209 (values (get-peer-address usocket) | |
210 (get-peer-port usocket))) | |
211 | |
212 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host… | |
213 ;;---*** TODO | |
214 (unsupported 'datagram 'socket-send)) | |
215 | |
216 (defmethod socket-receive ((socket datagram-usocket) buffer length &key) | |
217 ;;---*** TODO | |
218 (unsupported 'datagram 'socket-receive)) | |
219 | |
220 (defun get-host-by-address (address) | |
221 ) ;; TODO | |
222 | |
223 (defun get-hosts-by-name (name) | |
224 (with-mapped-conditions (nil name) | |
225 (let ((host-object (host-to-host-object name))) | |
226 (loop for (network address) in (scl:send host-object :network-addr… | |
227 when (typep network 'tcp:internet-network) | |
228 collect (hbo-to-vector-quad address))))) | |
229 | |
230 (defun %setup-wait-list (wait-list) | |
231 (declare (ignore wait-list))) | |
232 | |
233 (defun %add-waiter (wait-list waiter) | |
234 (declare (ignore wait-list waiter))) | |
235 | |
236 (defun %remove-waiter (wait-list waiter) | |
237 (declare (ignore wait-list waiter))) | |
238 | |
239 (defun wait-for-input-internal (wait-list &key timeout) | |
240 (with-mapped-conditions () | |
241 (process:process-block-with-timeout timeout "Wait for input" | |
242 #'(lambda (wait-list) | |
243 (let ((ready-sockets nil)) | |
244 (dolist (waiter (wait-list-waiters wait-list) ready-sockets) | |
245 (setf (state waiter) | |
246 (cond ((stream-usocket-p waiter) | |
247 (if (listen (socket-stream waiter)) | |
248 :read | |
249 nil)) | |
250 ((datagram-usocket-p waiter) | |
251 (let ((connection (gs-connection (socket wait… | |
252 (if (and connection | |
253 (not (scl:send connection :connect… | |
254 :read | |
255 nil))) | |
256 ((stream-server-usocket-p waiter) | |
257 (if (gs-pending-connections (socket waiter)) | |
258 :read | |
259 nil)))) | |
260 (when (not (null (state waiter))) | |
261 (setf ready-sockets t))))) | |
262 wait-list) | |
263 wait-list)) | |
264 |