socket.lisp (15156B)
1 ;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :rw.socket 24 (:use :cl) 25 (:export :accept 26 :close-socket 27 :ipv4-address 28 :ipv4-address-string 29 :ipv6-address 30 :ipv6-address-string 31 :make-ipv4-address 32 :make-ipv6-address 33 :make-tcp-client-socket 34 :make-tcp-server-socket 35 :make-udp-socket 36 :udp-receive 37 :udp-send 38 :using-socket)) 39 40 (in-package :rw.socket) 41 42 (defstruct (ipv4-address (:constructor %make-ipv4-address)) native string) 43 (defstruct (ipv6-address (:constructor %make-ipv6-address)) native string) 44 45 (defun next-ipv4-address (r) 46 (#-(or allegro ccl cmucl) 47 ipv4-integer-to-vector 48 #+(or allegro ccl cmucl) 49 progn 50 (flet ((one () 51 (cond 52 ((eql #\0 (rw:peek r)) 53 (rw:next r) 54 (cond 55 ((member (rw:peek r) '(nil #\.)) 56 0) 57 ((member (rw:peek r) '(#\x #\X)) 58 (rw:next r) 59 (rw:next-z0 r 16)) 60 (t (rw:next-z0 r 8)))) 61 (t (rw:next-z0 r))))) 62 (let ((a (one))) 63 (cond 64 ((eql #\. (rw:peek r)) 65 (rw:next r) 66 (let ((b (one))) 67 (cond 68 ((eql #\. (rw:peek r)) 69 (rw:next r) 70 (let ((c (one))) 71 (cond 72 ((eql #\. (rw:peek r)) 73 (rw:next r) 74 (logior (ash a 24) (ash b 16) (ash c 8) (one))) 75 (t 76 (logior (ash a 24) (ash b 16) c))))) 77 (t 78 (logior (ash a 24) b))))) 79 (t a)))))) 80 81 (defun parse-ipv4-address (x) 82 (let ((r (rw:peek-reader (rw:reader x)))) 83 (prog1 (next-ipv4-address r) 84 (assert (not (rw:peek r)))))) 85 86 ;;(parse-ipv4-address "172.31.53.254") 87 ;;(parse-ipv4-address "172.2045438") 88 ;;(parse-ipv4-address "172.31.13822") 89 ;;(parse-ipv4-address "0xac1f35fe") 90 ;;(parse-ipv4-address "025407632776") 91 ;;(parse-ipv4-address "2887726590") 92 ;;(parse-ipv4-address "192.0.2.235") 93 ;;(parse-ipv4-address "0xC0.0x00.0x02.0xEB") 94 ;;(parse-ipv4-address "0300.0000.0002.0353") 95 ;;(parse-ipv4-address "0xC00002EB") 96 ;;(parse-ipv4-address "3221226219") 97 ;;(parse-ipv4-address "030000001353") 98 ;;(parse-ipv4-address "127.1") 99 ;;(parse-ipv4-address "127.0.1") 100 ;;(parse-ipv4-address "127.0.0.1") 101 102 (defun ipv4-integer-to-dotted (x) 103 (format nil "~d.~d.~d.~d" 104 (ldb (byte 8 24) x) 105 (ldb (byte 8 16) x) 106 (ldb (byte 8 8) x) 107 (ldb (byte 8 0) x))) 108 109 (defun ipv4-vector-to-dotted (x) 110 (format nil "~d.~d.~d.~d" (aref x 0) (aref x 1) (aref x 2) (aref x 3))) 111 112 (defun ipv4-integer-to-vector (x) 113 (vector (ldb (byte 8 24) x) 114 (ldb (byte 8 16) x) 115 (ldb (byte 8 8) x) 116 (ldb (byte 8 0) x))) 117 118 (defun ipv4-vector-to-integer (x) 119 (logior (ash (aref x 0) 24) 120 (ash (aref x 1) 16) 121 (ash (aref x 2) 8) 122 (aref x 3))) 123 124 (defun make-ipv4-address (x) 125 (etypecase x 126 (string (%make-ipv4-address :native (parse-ipv4-address x) :string x)) 127 (integer 128 (%make-ipv4-address :native 129 #-(or allegro ccl) (ipv4-integer-to-vector x) 130 #+(or allegro ccl) x 131 :string (ipv4-integer-to-dotted x))) 132 (vector 133 (assert (= 4 (length x))) 134 (%make-ipv4-address :native 135 #-(or allegro ccl) x 136 #+(or allegro ccl) (ipv4-vector-to-integer x) 137 :string (ipv4-vector-to-dotted x))))) 138 139 ;;(make-ipv4-address "127.0.0.1") 140 ;;(make-ipv4-address #(127 0 0 1)) 141 ;;(make-ipv4-address #x7f000001) 142 ;;(make-ipv4-address 0) 143 144 (defun next-ipv6-address (r) 145 (#-(or allegro ccl cmucl) 146 ipv6-integer-to-vector 147 #+(or allegro ccl cmucl) 148 progn 149 (flet ((chain (n) 150 (loop 151 with z = 0 152 for i from 0 153 for p = (unless (member (rw:peek r) '(nil #\:)) 154 (let ((z (rw:next-z0 r 16))) 155 (assert z) 156 (assert (member (rw:next r) '(nil #\:))) 157 z)) 158 while p 159 do (assert (< i n)) 160 do (setq z (logior (ash z 16) p)) 161 finally (return (values z (- n i)))))) 162 (cond 163 ((eql #\: (rw:peek r)) 164 (rw:next r) 165 (assert (eql #\: (rw:next r))) 166 (chain 6)) 167 (t 168 (multiple-value-bind (hx hn) (chain 8) 169 (let ((x (ash hx (* hn 16)))) 170 (ecase (rw:peek r) 171 ((nil) x) 172 (#\: 173 (rw:next r) 174 (logior x (chain hn))))))))))) 175 176 (defun parse-ipv6-address (x) 177 (let ((r (rw:peek-reader (rw:reader x)))) 178 (prog1 (next-ipv6-address r) 179 (assert (not (rw:peek r)))))) 180 181 ;;(parse-ipv6-address "::") 182 ;;(parse-ipv6-address "::1") 183 ;;(parse-ipv6-address "::1:2") 184 ;;(parse-ipv6-address "0:0:0:0:0:0:0:0") 185 ;;(parse-ipv6-address "0:0:0:0:0:0:0:1") 186 ;;(parse-ipv6-address "f:e:d:c:b:a:9:8") 187 ;;(parse-ipv6-address "2605:2700:0:3::4713:93e3") 188 ;;(parse-ipv6-address "2001:503:ba3e::2:30") 189 ;;(parse-ipv6-address "fc00::") 190 191 (defun ipv6-integer-to-string (x) 192 (format nil "~(~x:~x:~x:~x:~x:~x:~x:~x~)" 193 (ldb (byte 16 112) x) 194 (ldb (byte 16 96) x) 195 (ldb (byte 16 80) x) 196 (ldb (byte 16 64) x) 197 (ldb (byte 16 48) x) 198 (ldb (byte 16 32) x) 199 (ldb (byte 16 16) x) 200 (ldb (byte 16 0) x))) 201 202 (defun ipv6-vector-to-string (x) 203 (format nil "~(~x:~x:~x:~x:~x:~x:~x:~x~)" 204 (aref x 0) 205 (aref x 1) 206 (aref x 2) 207 (aref x 3) 208 (aref x 4) 209 (aref x 5) 210 (aref x 6) 211 (aref x 7))) 212 213 (defun ipv6-integer-to-vector (x) 214 (vector (ldb (byte 16 112) x) 215 (ldb (byte 16 96) x) 216 (ldb (byte 16 80) x) 217 (ldb (byte 16 64) x) 218 (ldb (byte 16 48) x) 219 (ldb (byte 16 32) x) 220 (ldb (byte 16 16) x) 221 (ldb (byte 16 0) x))) 222 223 (defun ipv6-vector-to-integer (x) 224 (logior (ash (aref x 0) 112) 225 (ash (aref x 1) 96) 226 (ash (aref x 2) 80) 227 (ash (aref x 3) 64) 228 (ash (aref x 4) 48) 229 (ash (aref x 5) 32) 230 (ash (aref x 6) 16) 231 (aref x 7))) 232 233 (defun make-ipv6-address (x) 234 (etypecase x 235 (string (%make-ipv6-address :native (parse-ipv6-address x) :string x)) 236 (integer 237 (%make-ipv6-address :native 238 #-(or allegro ccl) (ipv6-integer-to-vector x) 239 #+(or allegro ccl) x 240 :string (ipv6-integer-to-string x))) 241 (vector 242 (assert (= 8 (length x))) 243 (%make-ipv6-address :native 244 #-(or allegro ccl) x 245 #+(or allegro ccl) (ipv6-vector-to-integer x) 246 :string (ipv6-vector-to-string x))))) 247 248 ;;(make-ipv6-address "f:e:d:c:b:a:9:8") 249 ;;(make-ipv6-address #(1 2 3 4 5 6 7 8)) 250 ;;(make-ipv6-address #x10002) 251 ;;(make-ipv6-address 0) 252 ;;(make-ipv6-address "2001:503:ba3e::2:30") 253 254 (defun native-ip-address (x) 255 (when x 256 (etypecase x 257 (ipv4-address (ipv4-address-native x)) 258 (ipv6-address (ipv6-address-native x))))) 259 260 (defun close-socket (socket) 261 #-(or allegro ccl ecl mkcl cmucl sbcl) 262 (error "RW.SOCKET::CLOSE-SOCKET not ported") 263 ;; clisp socket:socket-server-close? 264 #+(or allegro ccl) 265 (close socket) 266 #+cmucl 267 (ext:close-socket socket) 268 #+(or ecl sbcl mkcl) 269 (sb-bsd-sockets:socket-close socket)) 270 271 (defun using-socket (socket thunk) 272 (unwind-protect (funcall thunk) 273 (close-socket socket))) 274 275 (defun make-tcp-server-socket (local-host local-port &key backlog) 276 #-(or allegro clisp sbcl ecl mkcl cmucl ccl) 277 (error "RW.SOCKET:MAKE-TCP-SERVER-SOCKET not ported") 278 #+allegro 279 (socket:make-socket :connect :passive 280 :address-family :internet 281 :type :stream 282 :format :bivalent ;; TODO :binary 283 :local-host (native-ip-address local-host) 284 :local-port local-port 285 :reuse-address t) 286 #+clisp 287 (socket:socket-server local-port :interface local-host :backlog backlog) 288 #+(or sbcl ecl mkcl) 289 (let ((x (make-instance 'sb-bsd-sockets:inet-socket 290 :type :stream 291 :protocol :tcp))) 292 (setf (sb-bsd-sockets:sockopt-reuse-address x) t) 293 (sb-bsd-sockets:socket-bind 294 x 295 (car (sb-bsd-sockets:host-ent-addresses 296 (sb-bsd-sockets:get-host-by-name (ipv4-address-string local-host)))) 297 local-port) 298 (sb-bsd-sockets:socket-listen x (or backlog 5)) 299 x) 300 #+cmucl 301 (ext:create-inet-listener local-port :stream 302 :host (ipv4-address-native local-host)) 303 #+ccl 304 (ccl:make-socket :connect :passive 305 :address-family :internet 306 :type :stream 307 :format :bivalent ;; TODO :binary 308 :local-host (native-ip-address local-host) 309 :local-port local-port 310 :reuse-address t)) 311 312 (defun make-tcp-client-socket (remote-host remote-port) 313 #-(or allegro clisp sbcl ecl mkcl cmucl ccl) 314 (error "RW.SOCKET:MAKE-TCP-CLIENT-SOCKET not ported") 315 #+allegro 316 (socket:make-socket :connect :active 317 :address-family :internet 318 :type :stream 319 :format :bivalent ;; TODO :binary 320 :remote-host (native-ip-address remote-host) 321 :remote-port remote-port) 322 #+clisp 323 (socket:socket-connect remote-port remote-host) 324 #+(or sbcl ecl mkcl) 325 (let ((x (make-instance 'sb-bsd-sockets:inet-socket 326 :type :stream 327 :protocol :tcp))) 328 (sb-bsd-sockets:socket-connect 329 x 330 (car (sb-bsd-sockets:host-ent-addresses 331 (sb-bsd-sockets:get-host-by-name remote-host))) 332 remote-port) 333 (sb-bsd-sockets:socket-make-stream x 334 :input t 335 :output t 336 ;;:buffering :none 337 :element-type '(unsigned-byte 8))) 338 #+cmucl 339 (let ((x (ext:connect-to-inet-socket remote-host remote-port))) 340 (sys:make-fd-stream x :input x :output x :element-type '(unsigned-byte 8))) 341 #+ccl 342 (ccl:make-socket :connect :active 343 :address-family :internet 344 :type :stream 345 :format :bivalent ;; TODO :binary 346 :remote-host (native-ip-address remote-host) 347 :remote-port remote-port)) 348 349 (defun make-udp-socket (&key local-host local-port remote-host remote-port) 350 #-(or allegro ccl ecl mkcl sbcl) 351 (error "RW.SOCKET:MAKE-PASSIVE-UDP-SOCKET not ported") 352 #+allegro 353 (socket:make-socket :address-family :internet 354 :type :datagram 355 :local-host (native-ip-address local-host) 356 :local-port local-port 357 :remote-host (native-ip-address remote-host) 358 :remote-port remote-port) 359 ;; #+clisp ;; rawsock not present by default 360 ;; (rawsock:socket :inet :dgram 0) 361 #+ccl 362 (ccl:make-socket :address-family :internet 363 :type :datagram 364 :local-host (native-ip-address local-host) 365 :local-port local-port 366 :remote-host (native-ip-address remote-host) 367 :remote-port remote-port) 368 #+(or ecl mkcl sbcl) 369 (let ((x (make-instance 'sb-bsd-sockets:inet-socket 370 :type :datagram 371 :protocol :udp))) 372 (when (and local-host local-port) 373 (sb-bsd-sockets:socket-bind 374 x 375 (car (sb-bsd-sockets:host-ent-addresses 376 (sb-bsd-sockets:get-host-by-name local-host))) 377 local-port)) 378 (when (and remote-host remote-port) 379 (sb-bsd-sockets:socket-connect x remote-host remote-port)) 380 x)) 381 382 ;; eol 383 ;; keepalive nodelay broadcast linger 384 ;; backlog class out-of-band-inline 385 ;; local-filename remote-filename 386 ;; sharing basic 387 ;; external-format (auto-close t) 388 ;; connect-timeout input-timeout output-timeout deadline 389 ;; fd 390 391 (defun accept (socket) 392 #-(or allegro clisp sbcl ecl mkcl cmucl ccl) 393 (error "RW.SOCKET:ACCEPT not ported") 394 #+allegro 395 (socket:accept-connection socket) 396 #+clisp 397 (socket:socket-accept socket) 398 #+(or sbcl ecl mkcl) 399 (sb-bsd-sockets:socket-make-stream (sb-bsd-sockets:socket-accept socket) 400 :element-type '(unsigned-byte 8) 401 :input t 402 :output t 403 :auto-close t) 404 #+cmucl 405 (ext:accept-network-stream socket) 406 #+nil 407 (let ((x (ext:accept-tcp-connection socket))) 408 (ext:accept-network-stream socket) 409 #+nil 410 (sys:make-fd-stream x :input x :output x:element-type '(unsigned-byte 8))) 411 #+ccl 412 (ccl:accept-connection socket)) 413 414 (defun udp-send (socket buf len &key remote-host remote-port) 415 #-(or allegro ccl ecl mkcl sbcl) 416 (error "RW.SOCKET:UDP-SEND not ported") 417 #+allegro 418 (socket:send-to socket buf len 419 :remote-host (native-ip-address remote-host) 420 :remote-port remote-port) 421 #+ccl 422 (ccl:send-to socket buf len 423 :remote-host (native-ip-address remote-host) 424 :remote-port remote-port) 425 #+(or ecl mkcl sbcl) 426 (sb-bsd-sockets:socket-send socket buf len 427 :address (list (native-ip-address remote-host) 428 remote-port))) 429 430 (defun udp-receive (socket buf len) 431 #-(or allegro ccl ecl mkcl sbcl) 432 (error "RW.SOCKET:UDP-RECEIVE not ported") 433 #+allegro 434 (socket:receive-from socket len :buffer buf) 435 #+ccl 436 (ccl:receive-from socket len :buffer buf) 437 #+(or ecl mkcl sbcl) 438 (sb-bsd-sockets:socket-receive socket buf len))