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