allegro.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
---
allegro.lisp (8591B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 #+cormanlisp
6 (eval-when (:compile-toplevel :load-toplevel :execute)
7 (require :acl-socket))
8
9 #+allegro
10 (eval-when (:compile-toplevel :load-toplevel :execute)
11 (require :sock)
12 ;; for wait-for-input:
13 (require :process)
14 ;; note: the line below requires ACL 6.2+
15 (require :osi))
16
17 (defun get-host-name ()
18 ;; note: the line below requires ACL 7.0+ to actually *work* on windows
19 #+allegro (excl.osi:gethostname)
20 #+cormanlisp "")
21
22 (defparameter +allegro-identifier-error-map+
23 '((:address-in-use . address-in-use-error)
24 (:address-not-available . address-not-available-error)
25 (:network-down . network-down-error)
26 (:network-reset . network-reset-error)
27 (:network-unreachable . network-unreachable-error)
28 (:connection-aborted . connection-aborted-error)
29 (:connection-reset . connection-reset-error)
30 (:no-buffer-space . no-buffers-error)
31 (:shutdown . shutdown-error)
32 (:connection-timed-out . timeout-error)
33 (:connection-refused . connection-refused-error)
34 (:host-down . host-down-error)
35 (:host-unreachable . host-unreachable-error)))
36
37 ;; TODO: what's the error class of Corman Lisp?
38 (defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
39 "Dispatch correct usocket condition."
40 (typecase condition
41 #+allegro
42 (excl:socket-error
43 (let ((usock-error
44 (cdr (assoc (excl:stream-error-identifier condition)
45 +allegro-identifier-error-map+))))
46 (declare (type symbol usock-error))
47 (if usock-error
48 (cond ((subtypep usock-error 'ns-error)
49 (error usock-error :socket socket :host-or-ip host-or-ip))
50 (t
51 (error usock-error :socket socket)))
52 (error 'unknown-error
53 :real-error condition
54 :socket socket))))))
55
56 (defun to-format (element-type)
57 (if (subtypep element-type 'character)
58 :text
59 :binary))
60
61 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
62 timeout deadline
63 (nodelay t) ;; nodelay == t is the ACL default
64 local-host local-port)
65 (when timeout (unsupported 'timeout 'socket-connect))
66 (when deadline (unsupported 'deadline 'socket-connect))
67 (when (eq nodelay :if-supported)
68 (setf nodelay t))
69
70 (let ((socket))
71 (setf socket
72 (with-mapped-conditions (socket (or host local-host))
73 (ecase protocol
74 (:stream
75 (labels ((make-socket ()
76 (socket:make-socket :remote-host (host-to-hostname host)
77 :remote-port port
78 :local-host (when local-host
79 (host-to-hostname local-host))
80 :local-port local-port
81 :format (to-format element-type)
82 :nodelay nodelay)))
83 #+allegro
84 (if timeout
85 (mp:with-timeout (timeout nil)
86 (make-socket))
87 (make-socket))
88 #+cormanlisp (make-socket)))
89 (:datagram
90 (apply #'socket:make-socket
91 (nconc (list :type protocol
92 :address-family :internet
93 :local-host (when local-host
94 (host-to-hostname local-host))
95 :local-port local-port
96 :format (to-format element-type))
97 (if (and host port)
98 (list :connect :active
99 :remote-host (host-to-hostname host)
100 :remote-port port)
101 (list :connect :passive))))))))
102 (ecase protocol
103 (:stream
104 (make-stream-socket :socket socket :stream socket))
105 (:datagram
106 (make-datagram-socket socket :connected-p (and host port t))))))
107
108 ;; One socket close method is sufficient,
109 ;; because socket-streams are also sockets.
110 (defmethod socket-close ((usocket usocket))
111 "Close socket."
112 (with-mapped-conditions (usocket)
113 (close (socket usocket))))
114
115 (defmethod socket-shutdown ((usocket stream-usocket) direction)
116 (with-mapped-conditions (usocket)
117 (socket:shutdown (socket usocket) :direction direction)))
118
119 (defun socket-listen (host port
120 &key reuseaddress
121 (reuse-address nil reuse-address-supplied-p)
122 (backlog 5)
123 (element-type 'character))
124 ;; Allegro and OpenMCL socket interfaces bear very strong resemblence
125 ;; whatever you change here, change it also for OpenMCL
126 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
127 (sock (with-mapped-conditions (nil host)
128 (apply #'socket:make-socket
129 (append (list :connect :passive
130 :reuse-address reuseaddress
131 :local-port port
132 :backlog backlog
133 :format (to-format element-type)
134 ;; allegro now ignores :format
135 )
136 (when (ip/= host *wildcard-host*)
137 (list :local-host host)))))))
138 (make-stream-server-socket sock :element-type element-type)))
139
140 (defmethod socket-accept ((socket stream-server-usocket) &key element-type)
141 (declare (ignore element-type)) ;; allegro streams are multivalent
142 (let ((stream-sock
143 (with-mapped-conditions (socket)
144 (socket:accept-connection (socket socket)))))
145 (make-stream-socket :socket stream-sock :stream stream-sock)))
146
147 (defmethod get-local-address ((usocket usocket))
148 (hbo-to-vector-quad (socket:local-host (socket usocket))))
149
150 (defmethod get-peer-address ((usocket stream-usocket))
151 (hbo-to-vector-quad (socket:remote-host (socket usocket))))
152
153 (defmethod get-local-port ((usocket usocket))
154 (socket:local-port (socket usocket)))
155
156 (defmethod get-peer-port ((usocket stream-usocket))
157 #+allegro
158 (socket:remote-port (socket usocket)))
159
160 (defmethod get-local-name ((usocket usocket))
161 (values (get-local-address usocket)
162 (get-local-port usocket)))
163
164 (defmethod get-peer-name ((usocket stream-usocket))
165 (values (get-peer-address usocket)
166 (get-peer-port usocket)))
167
168 #+allegro
169 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
170 (with-mapped-conditions (usocket host)
171 (let ((s (socket usocket)))
172 (socket:send-to s
173 (if (zerop offset)
174 buffer
175 (subseq buffer offset (+ offset size)))
176 size
177 :remote-host host
178 :remote-port port))))
179
180 #+allegro
181 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
182 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
183 (integer 0) ; size
184 (unsigned-byte 32) ; host
185 (unsigned-byte 16))) ; port
186 (with-mapped-conditions (usocket)
187 (let ((s (socket usocket)))
188 (socket:receive-from s length :buffer buffer :extract t))))
189
190 (defun get-host-by-address (address)
191 (with-mapped-conditions (nil address)
192 (socket:ipaddr-to-hostname (host-to-hbo address))))
193
194 (defun get-hosts-by-name (name)
195 ;;###FIXME: ACL has the acldns module which returns all A records
196 ;; only problem: it doesn't fall back to tcp (from udp) if the returned
197 ;; structure is too long.
198 (with-mapped-conditions (nil name)
199 (list (hbo-to-vector-quad (socket:lookup-hostname
200 (host-to-hostname name))))))
201
202 (defun %setup-wait-list (wait-list)
203 (declare (ignore wait-list)))
204
205 (defun %add-waiter (wait-list waiter)
206 (push (socket waiter) (wait-list-%wait wait-list)))
207
208 (defun %remove-waiter (wait-list waiter)
209 (setf (wait-list-%wait wait-list)
210 (remove (socket waiter) (wait-list-%wait wait-list))))
211
212 #+allegro
213 (defun wait-for-input-internal (wait-list &key timeout)
214 (with-mapped-conditions ()
215 (let ((active-internal-sockets
216 (if timeout
217 (mp:wait-for-input-available (wait-list-%wait wait-list)
218 :timeout timeout)
219 (mp:wait-for-input-available (wait-list-%wait wait-list)))))
220 ;; this is quadratic, but hey, the active-internal-sockets
221 ;; list is very short and it's only quadratic in the length of that one.
222 ;; When I have more time I could recode it to something of linear
223 ;; complexity.
224 ;; [Same code is also used in openmcl.lisp]
225 (dolist (x active-internal-sockets)
226 (setf (state (gethash x (wait-list-map wait-list)))
227 :read))
228 wait-list)))