genera.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
genera.lisp (9940B)
---
1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: USOCKET; Base: 10 -*-
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-foreign-address)
10 (foreign-port :initform 0 :initarg :foreign-port :accessor gs-foreign-port)
11 (local-address :initform 0 :initarg :local-address :accessor gs-local-address)
12 (local-port :initform 0 :initarg :local-port :accessor gs-local-port))
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-element-type)
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-connection))
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 loopback interface
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 nil))
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-destination-unreachable)
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 -1))))
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-address))
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::*last-gensym-port-number*
123 do (cond ((loop for existing-tcb in tcp::*tcb-list*
124 thereis (= number (tcp::tcb-local-port existing-tcb))))
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 'character))
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 semantics
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 :network-addresses)
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-address tcb))))
158 ;; Reject if not destined for the proper address
159 (tcp::reject-tcb tcb))
160 ((<= (length (gs-pending-connections gs)) (gs-backlog gs))
161 (tcp::accept-tcb tcb)
162 (tcp::tcb-travel-through-states tcb "Accept" nil :listen :syn-received)
163 (setf (gs-pending-connections gs)
164 (append (gs-pending-connections gs) (list tcb))))
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-type)
172 (with-slots (pending-connections) (socket socket)
173 (loop
174 (process:process-block "Wait for connection" #'(lambda ()
175 (not (null pending-connections))))
176 (let ((tcb (pop pending-connections)))
177 (when tcb
178 (let* ((format (element-type-to-format (or element-type (element-type socket))
179 :stream))
180 (characters (eq format :text))
181 (stream (tcp::make-tcp-stream tcb
182 :characters characters
183 :ascii-translation characters))
184 (gs (make-instance 'genera-stream-socket
185 :stream stream)))
186 (setf (gs-foreign-address gs) (scl:send stream :foreign-address))
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 port (offset 0))
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-addresses)
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 waiter))))
252 (if (and connection
253 (not (scl:send connection :connection-pending-p)))
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