cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

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))