├── .gitignore ├── tests ├── packages.lisp ├── asdf.lisp ├── poll-sockets.lisp ├── posix.lisp ├── poller.lisp ├── local.lisp ├── ipv4.lisp └── overlapped-io.lisp ├── src ├── epoll-cffi.lisp ├── epoll-grovel.lisp ├── kqueue-cffi.lisp ├── overlapped-io.c ├── kqueue-grovel.lisp ├── packages.lisp ├── overlapped-io-packages.lisp ├── posix-helpers.lisp ├── protocols.lisp ├── posix-socket-options.lisp ├── posix-cffi.lisp ├── overlapped-io-errors.lisp ├── posix-grovel.lisp ├── system-calls.lisp ├── overlapped-io-cffi.lisp ├── overlapped-io-grovel.lisp ├── epoll-poller.lisp ├── posix-poll.lisp ├── kqueue-poller.lisp └── posix-sockets.lisp ├── .travis.yml ├── basic-binary-ipc-tests.asd ├── LICENCE ├── basic-binary-ipc.asd ├── examples └── echo-example.lisp ├── README.md └── doc ├── overlapped-io.org └── basic-binary-ipc.org /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl 3 | *.fas 4 | *.dx64fsl 5 | *.fx64fsl 6 | *.lx64fsl 7 | doc/overlapped-io.html 8 | *# -------------------------------------------------------------------------------- /tests/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage "BASIC-BINARY-IPC.TESTS" 2 | (:use "COMMON-LISP" 3 | "LISP-UNIT" 4 | "BASIC-BINARY-IPC")) 5 | 6 | #+windows 7 | (defpackage "BASIC-BINARY-IPC.OVERLAPPED-IO.TESTS" 8 | (:use "COMMON-LISP" 9 | "LISP-UNIT" 10 | "BASIC-BINARY-IPC.OVERLAPPED-IO") 11 | (:import-from "BASIC-BINARY-IPC" 12 | #:system-function-error)) 13 | -------------------------------------------------------------------------------- /tests/asdf.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.TESTS") 2 | 3 | (defmethod asdf:perform ((operation asdf:test-op) (component (eql (asdf:find-system "basic-binary-ipc-tests")))) 4 | (dolist (pkg (list "BASIC-BINARY-IPC.TESTS" 5 | #+windows "BASIC-BINARY-IPC.OVERLAPPED-IO.TESTS")) 6 | (format t "~&;;;; Running tests in package ~A~%" pkg) 7 | (let ((report (lisp-unit:run-tests :all pkg))) 8 | (print-failures report) 9 | (print-errors report)))) 10 | -------------------------------------------------------------------------------- /src/epoll-cffi.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (define-posix-system-call (%ff-epoll-create "epoll_create") :int 4 | (size :int)) 5 | 6 | (define-posix-system-call (%ff-epoll-ctl "epoll_ctl") :int 7 | (epfd :int) 8 | (op epoll-operation) 9 | (fd :int) 10 | (event (:pointer (:struct epoll-event)))) 11 | 12 | (define-posix-system-call (%ff-epoll-wait "epoll_wait") :int 13 | (epfd :int) 14 | (events (:pointer (:struct epoll-event))) 15 | (maxevents :int) 16 | (timeout :int)) 17 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: required 3 | 4 | env: 5 | matrix: 6 | - LISP=sbcl 7 | - LISP=ccl 8 | - LISP=clisp 9 | 10 | install: 11 | # Install cl-travis 12 | - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | bash 13 | 14 | script: 15 | - cl -e '(setf *debugger-hook* 16 | (lambda (c h) 17 | (declare (ignore c h)) 18 | (uiop:quit -1)))' 19 | -e '(asdf:compile-system :basic-binary-ipc :force t)' 20 | -e '(ql:quickload :basic-binary-ipc-tests)' 21 | -e '(lisp-unit:run-tests :all :basic-binary-ipc.tests)' 22 | -------------------------------------------------------------------------------- /basic-binary-ipc-tests.asd: -------------------------------------------------------------------------------- 1 | (in-package "ASDF") 2 | 3 | (defsystem "basic-binary-ipc-tests" 4 | :author "Mark Cox" 5 | :description "A collection of tests for the BASIC-BINARY-IPC system." 6 | :license "Simplified BSD License variant" 7 | :depends-on ("basic-binary-ipc" "bordeaux-threads" "lisp-unit") 8 | :serial t 9 | :components ((:module "tests" 10 | :serial t 11 | :components ((:file "packages") 12 | (:file "asdf") 13 | #-windows 14 | (:file "posix") 15 | (:file "ipv4") 16 | (:file "local") 17 | (:file "poll-sockets") 18 | (:file "poller"))) 19 | 20 | #+windows 21 | (:module "tests/windows" 22 | :serial t 23 | :pathname "tests/" 24 | :components ((:file "overlapped-io"))))) 25 | -------------------------------------------------------------------------------- /src/epoll-grovel.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (include "sys/epoll.h") 4 | 5 | (cunion epoll-data "union epoll_data" 6 | (ptr "ptr" :type :pointer) 7 | (fd "fd" :type :int) 8 | (u32 "u32" :type :uint32) 9 | (u64 "u64" :type :uint64)) 10 | 11 | (constantenum (epoll-operation :base-type :int) 12 | ((:epoll-ctl-add "EPOLL_CTL_ADD")) 13 | ((:epoll-ctl-mod "EPOLL_CTL_MOD")) 14 | ((:epoll-ctl-del "EPOLL_CTL_DEL"))) 15 | 16 | (bitfield (epoll-events :base-type :uint32) 17 | ((:epollin "EPOLLIN")) 18 | ((:epollout "EPOLLOUT")) 19 | ((:epollrdhup "EPOLLRDHUP")) 20 | ((:epollerr "EPOLLERR")) 21 | ((:epollhup "EPOLLHUP"))) 22 | 23 | (cstruct epoll-event "struct epoll_event" 24 | (events "events" :type epoll-events) 25 | (data "data" :type (:union epoll-data))) -------------------------------------------------------------------------------- /src/kqueue-cffi.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (define-posix-system-call (%ff-kqueue "kqueue") :int) 4 | 5 | #+freebsd 6 | (define-posix-system-call (%ff-kevent "kevent") :int 7 | (kq :int) 8 | (change-list (:pointer (:struct kevent))) 9 | (number-of-changes :int) 10 | (event-list (:pointer (:struct kevent))) 11 | (number-of-events :int) 12 | (timeout (:pointer (:struct timespec)))) 13 | 14 | #+darwin 15 | (define-posix-system-call (%ff-kevent64 "kevent64") :int 16 | (kq :int) 17 | (change-list (:pointer (:struct kevent64-s))) 18 | (number-of-changes :int) 19 | (event-list (:pointer (:struct kevent64-s))) 20 | (number-of-events :int) 21 | (flags :unsigned-int) 22 | (timeout (:pointer (:struct timespec)))) 23 | 24 | (defun kevent-wrapper (kq change-list number-of-changes event-list number-of-events timeout) 25 | #+darwin 26 | (%ff-kevent64 kq change-list number-of-changes event-list number-of-events 0 timeout) 27 | #+freebsd 28 | (%ff-kevent kq change-list number-of-changes event-list number-of-events timeout)) 29 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013, Mark Cox 2 | ;; All rights reserved. 3 | 4 | ;; Redistribution and use in source and binary forms, with or without 5 | ;; modification, are permitted provided that the following conditions are 6 | ;; met: 7 | 8 | ;; - Redistributions of source code must retain the above copyright 9 | ;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;; - Redistributions in binary form must reproduce the above copyright 12 | ;; notice, this list of conditions and the following disclaimer in the 13 | ;; documentation and/or other materials provided with the distribution. 14 | 15 | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 16 | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 17 | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 18 | ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 19 | ;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 20 | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 21 | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 22 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 23 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /src/overlapped-io.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #define STOLEN_WSAID_GETACCEPTEXSOCKADDRS {0xb5367df2,0xcbac,0x11cf,{0x95,0xca,0x00,0x80,0x5f,0x48,0xa1,0x92}} 6 | #define STOLEN_WSAID_ACCEPTEX {0xb5367df1,0xcbac,0x11cf,{0x95,0xca,0x00,0x80,0x5f,0x48,0xa1,0x92}} 7 | #define STOLEN_WSAID_CONNECTEX {0x25a207b9,0xddf3,0x4660,{0x8e,0xe9,0x76,0xe5,0x8c,0x74,0x06,0x3e}} 8 | 9 | #ifndef WSAID_GETACCEPTEXSOCKADDRS 10 | #define WSAID_GETACCEPTEXSOCKADDRS STOLEN_WSAID_GETACCEPTEXSOCKADDRS 11 | #endif 12 | 13 | #ifndef WSAID_ACCEPTEX 14 | #define WSAID_ACCEPTEX STOLEN_WSAID_ACCEPTEX 15 | #endif 16 | 17 | #ifndef WSAID_CONNECTEX 18 | #define WSAID_CONNECTEX STOLEN_WSAID_CONNECTEX 19 | #endif 20 | 21 | void 22 | output_guid(const char *name, GUID guid) 23 | { 24 | size_t i; 25 | unsigned char *p = (unsigned char *)(&guid); 26 | 27 | printf(";; %s\n", name); 28 | printf("#("); 29 | for (i = 0; i < sizeof(GUID); i++) { 30 | printf("%u",p[i]); 31 | if (i < (sizeof(GUID) - 1)) 32 | printf(" "); 33 | 34 | } 35 | printf(")\n"); 36 | } 37 | 38 | int 39 | main(int argc, char **argv) 40 | { 41 | { 42 | GUID guid = WSAID_GETACCEPTEXSOCKADDRS; 43 | output_guid("WSAID_GETACCEPTEXSOCKADDRS", guid); 44 | } 45 | 46 | { 47 | GUID guid = WSAID_ACCEPTEX; 48 | output_guid("WSAID_ACCEPTEX", guid); 49 | } 50 | 51 | { 52 | GUID guid = WSAID_CONNECTEX; 53 | output_guid("WSAID_CONNECTEX", guid); 54 | } 55 | 56 | 57 | return 0; 58 | } 59 | -------------------------------------------------------------------------------- /src/kqueue-grovel.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (include "sys/types.h") 4 | (include "sys/event.h") 5 | (include "sys/time.h") 6 | 7 | #+freebsd 8 | (progn 9 | (ctype uintptr-t "uintptr_t") 10 | (ctype intptr-t "intptr_t") 11 | (ctype u-short "u_short") 12 | (ctype u-int "u_int") 13 | 14 | (cstruct kevent "struct kevent" 15 | (ident "ident" :type uintptr-t) 16 | (filter "filter" :type :short) 17 | (flags "flags" :type u-short) 18 | (fflags "fflags" :type u-int) 19 | (data "data" :type intptr-t) 20 | (udata "udata" :type :pointer))) 21 | 22 | #+darwin 23 | (cstruct kevent64-s "struct kevent64_s" 24 | (ident "ident" :type :uint64) 25 | (filter "filter" :type :int16) 26 | (flags "flags" :type :uint16) 27 | (fflags "fflags" :type :uint32) 28 | (data "data" :type :int64) 29 | (udata "udata" :type :uint64) 30 | (ext "ext" :type :uint64 :count 2)) 31 | 32 | (ctype time-t "time_t") 33 | 34 | (cstruct timespec "struct timespec" 35 | (tv-sec "tv_sec" :type time-t) 36 | (tv-nsec "tv_nsec" :type :long)) 37 | 38 | (constantenum (kevent-flags :base-type 39 | #+darwin :uint16 40 | #+freebsd u-short) 41 | ((:ev-add "EV_ADD")) 42 | ((:ev-enable "EV_ENABLE")) 43 | ((:ev-disable "EV_DISABLE")) 44 | ((:ev-delete "EV_DELETE")) 45 | ((:ev-clear "EV_CLEAR")) 46 | ((:ev-eof "EV_EOF")) 47 | ((:ev-error "EV_ERROR"))) 48 | 49 | (constantenum (kevent-filters :base-type 50 | #+darwin :int16 51 | #+freebsd :short) 52 | ((:evfilt-read "EVFILT_READ")) 53 | ((:evfilt-write "EVFILT_WRITE"))) 54 | -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage "BASIC-BINARY-IPC" 2 | (:use "COMMON-LISP") 3 | 4 | ;; Sockets 5 | (:export #:socket 6 | #:close-socket 7 | #:socket-closed-p 8 | #:socket-error) 9 | 10 | ;; Stream servers 11 | (:export #:stream-server 12 | #:accept-connection 13 | #:connection-available-p 14 | #:no-connection-available-error 15 | #:socket) 16 | 17 | ;; Streams 18 | (:export #:stream-socket 19 | 20 | ;; - connecting state 21 | #:determinedp 22 | #:connection-failed-p 23 | #:connection-succeeded-p 24 | 25 | ;; - connected state 26 | #:remote-disconnected-p 27 | #:ready-to-write-p 28 | #:data-available-p 29 | 30 | #:read-from-stream 31 | #:write-to-stream 32 | 33 | #:would-block-error) 34 | 35 | ;; Polling 36 | (:export #:poll-socket 37 | #:poll-sockets) 38 | 39 | ;; Pollers 40 | (:export #:make-poller 41 | #:wait-for-events 42 | #:monitor-socket 43 | #:unmonitor-socket 44 | #:monitored-events 45 | #:monitored-sockets 46 | #:close-poller) 47 | 48 | ;; IPv4 49 | (:export #:ipv4-tcp-server 50 | #:make-ipv4-tcp-server 51 | 52 | #:ipv4-tcp-stream 53 | #:connect-to-ipv4-tcp-server 54 | #:host-address 55 | #:port 56 | 57 | #:+ipv4-loopback+ 58 | #:+ipv4-any+ 59 | 60 | #:local-host-address 61 | #:local-port 62 | #:remote-host-address 63 | #:remote-port 64 | 65 | #:resolve-ipv4-address) 66 | 67 | ;; Local Sockets 68 | (:export #:local-server 69 | #:make-local-server 70 | 71 | #:local-stream 72 | #:connect-to-local-server 73 | #:no-local-server-error 74 | 75 | #:local-pathname) 76 | 77 | ;; Helpers 78 | (:export #:with-socket 79 | #:do-with-socket 80 | #:with-poller 81 | #:do-with-poller)) 82 | -------------------------------------------------------------------------------- /basic-binary-ipc.asd: -------------------------------------------------------------------------------- 1 | (in-package "ASDF") 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (asdf:load-system "cffi-grovel")) 5 | 6 | (defsystem "basic-binary-ipc" 7 | :author "Mark Cox" 8 | :description "A inter-process communication library for transmitting binary data over a stream." 9 | :license "Simplified BSD License variant" 10 | :depends-on ("cffi-grovel") 11 | :serial t 12 | :components ((:module "src" 13 | :serial t 14 | :components ((:file "packages") 15 | (:file "protocols") 16 | (:file "system-calls"))) 17 | #+(or darwin freebsd linux) 18 | (:module "src/posix" 19 | :serial t 20 | :pathname "src" 21 | :components ((:file "posix-helpers") 22 | (cffi-grovel:grovel-file "posix-grovel") 23 | (:file "posix-cffi") 24 | (:file "posix-socket-options") 25 | (:file "posix-sockets") 26 | (:file "posix-poll"))) 27 | #+(or darwin freebsd) 28 | (:module "src/kqueue" 29 | :serial t 30 | :pathname "src" 31 | :components ((cffi-grovel:grovel-file "kqueue-grovel") 32 | (:file "kqueue-cffi") 33 | (:file "kqueue-poller"))) 34 | #+linux 35 | (:module "src/epoll" 36 | :serial t 37 | :pathname "src" 38 | :components ((cffi-grovel:grovel-file "epoll-grovel") 39 | (:file "epoll-cffi") 40 | (:file "epoll-poller"))) 41 | 42 | #+windows 43 | (:module "src/overlapped-io" 44 | :serial t 45 | :pathname "src" 46 | :components ((:file "overlapped-io-packages") 47 | (cffi-grovel:grovel-file "overlapped-io-grovel") 48 | (:file "overlapped-io-errors") 49 | (:file "overlapped-io-cffi") 50 | (:file "overlapped-io") 51 | (:file "windows")))) 52 | :in-order-to ((test-op (test-op "basic-binary-ipc-tests")))) 53 | -------------------------------------------------------------------------------- /examples/echo-example.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel :load-toplevel :execute) 2 | (asdf:load-system "basic-binary-ipc")) 3 | 4 | (defpackage "ECHO-EXAMPLE" 5 | (:use "COMMON-LISP" 6 | "BASIC-BINARY-IPC") 7 | (:export #:run-server 8 | #:send-to-server)) 9 | (in-package "ECHO-EXAMPLE") 10 | 11 | (defun run-server (port &optional (host-address +ipv4-loopback+)) 12 | (check-type port (unsigned-byte 16)) 13 | (check-type host-address string) 14 | 15 | (with-socket (server (make-ipv4-tcp-server host-address port :reuse-address t)) 16 | (loop 17 | :with buffer-size := 10000 18 | :with buffer := (make-array buffer-size :element-type '(unsigned-byte 8)) 19 | :for result := (poll-socket server 'connection-available-p 10) 20 | :when result 21 | :do 22 | (with-socket (client (accept-connection server)) 23 | (loop 24 | :for attempts :from 0 :below 3 25 | :for data-available := (poll-socket client 'data-available-p 10) 26 | :when data-available 27 | :do 28 | (let ((bytes-read (read-from-stream client buffer))) 29 | (write-to-stream client buffer :end bytes-read))))))) 30 | 31 | (defun send-to-server (string host-address port) 32 | (check-type string string) 33 | (check-type host-address string) 34 | (check-type port (unsigned-byte 16)) 35 | 36 | (with-socket (client (connect-to-ipv4-tcp-server host-address port)) 37 | (unless (poll-socket client 'connection-succeeded-p 10) 38 | (error "Failed to connect to address ~A:~d" host-address port)) 39 | 40 | (write-to-stream client (babel:string-to-octets string)) 41 | 42 | (loop 43 | :for attempts :from 0 :below 3 44 | :for data-available := (poll-socket client 'data-available-p 10) 45 | :until data-available 46 | :finally (unless data-available 47 | (error "Echo server not working."))) 48 | 49 | (let* ((buffer (make-array 100000 :element-type '(unsigned-byte 8))) 50 | (bytes-read (read-from-stream client buffer))) 51 | (babel:octets-to-string buffer :end bytes-read)))) 52 | -------------------------------------------------------------------------------- /src/overlapped-io-packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage "BASIC-BINARY-IPC.OVERLAPPED-IO" 2 | (:use "COMMON-LISP") 3 | (:import-from "BASIC-BINARY-IPC" 4 | #:system-function-error 5 | #:define-check-system-call 6 | #:define-system-call) 7 | 8 | ;; Requests 9 | (:export #:request 10 | #:descriptor 11 | #:free-request 12 | #:invalidp 13 | #:waitingp 14 | #:completedp 15 | #:succeededp 16 | #:failedp 17 | #:reset-event 18 | #:set-event 19 | 20 | #:with-request 21 | #:do-with-request) 22 | 23 | ;; Synchronising 24 | (:export #:wait-for-request 25 | #:wait-for-requests 26 | 27 | #:+infinite+) 28 | 29 | ;; Monitor Synchronising 30 | (:export #:monitor 31 | #:unmonitor 32 | #:pop-notification 33 | #:free-monitor 34 | #:do-with-monitor 35 | #:with-monitor) 36 | 37 | ;; Generic handle stuff 38 | (:export #:close-handle 39 | #:with-handle 40 | #:do-with-handle 41 | #:cancel-all-io) 42 | 43 | ;; Named Pipes 44 | (:export #:connect-to-named-pipe 45 | 46 | #:valid-pipe-name-p 47 | #:canonical-windows-pipe-name 48 | 49 | #:valid-named-pipe-handle-p 50 | 51 | ;; Servers 52 | #:make-named-pipe-server 53 | #:connect-named-pipe 54 | 55 | #:buffer 56 | #:buffer-length 57 | 58 | #:read-file 59 | #:read-file-request 60 | #:bytes-read 61 | 62 | #:write-file 63 | #:write-file-request 64 | #:bytes-written) 65 | 66 | ;; Sockets 67 | (:export #:make-socket 68 | #:close-socket) 69 | 70 | ;; IPv4 Sockets 71 | (:export #:+inaddr-none+ 72 | #:+inaddr-any+ 73 | #:+inaddr-loopback+ 74 | 75 | #:with-sockaddr-in 76 | #:do-with-sockaddr-in 77 | 78 | #:make-ipv4-server 79 | 80 | #:accept-ipv4-request 81 | #:local-address 82 | #:local-port 83 | #:remote-address 84 | #:remote-port 85 | #:client-descriptor 86 | #:buffer 87 | #:buffer-length 88 | #:bytes-read 89 | 90 | #:minimum-accept-ipv4-buffer-size 91 | #:accept-ipv4 92 | 93 | #:connect-ipv4-request 94 | #:connect-ipv4 95 | 96 | #:resolve-ipv4-address)) 97 | -------------------------------------------------------------------------------- /tests/poll-sockets.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.TESTS") 2 | 3 | (define-test poll-sockets 4 | (:tag :poll-sockets) 5 | (let ((port (random-server-port))) 6 | (labels ((wait-for-clients (tcp-server local-server) 7 | (let ((sockets (list tcp-server local-server)) 8 | (events '(connection-available-p connection-available-p))) 9 | (assert-equal '(nil nil) (poll-sockets sockets events 0)) 10 | (let ((tcp-client (connect-to-ipv4-tcp-server +ipv4-loopback+ port))) 11 | (unwind-protect 12 | (progn 13 | (assert-equal '(connection-available-p nil) (poll-sockets sockets events 1)) 14 | (let ((local-client (connect-to-local-server (local-socket-pathname)))) 15 | (unwind-protect 16 | (progn 17 | (assert-equal events (poll-sockets sockets events 1)) 18 | (close-socket (accept-connection tcp-server)) 19 | (assert-equal '(nil connection-available-p) (poll-sockets sockets events 1)) 20 | (close-socket (accept-connection local-server)) 21 | (assert-equal '(nil nil) (poll-sockets sockets events 0))) 22 | (close-socket local-client)))) 23 | (close-socket tcp-client)))))) 24 | (let ((tcp-server (make-ipv4-tcp-server +ipv4-loopback+ port))) 25 | (unwind-protect 26 | (let ((local-server (make-local-server (local-socket-pathname)))) 27 | (unwind-protect 28 | (wait-for-clients tcp-server local-server) 29 | (close-socket local-server))) 30 | (close-socket tcp-server)))))) 31 | 32 | #+(and thread-support (not windows)) 33 | (define-test poll-sockets/interrupt 34 | (let ((finished-properly nil)) 35 | (labels ((start-thread () 36 | (let ((port (random-server-port))) 37 | (bordeaux-threads:make-thread #'(lambda () 38 | (with-socket (s (make-ipv4-tcp-server +ipv4-loopback+ port)) 39 | (poll-socket s 'connection-available-p 60) 40 | (setf finished-properly t))))))) 41 | (let ((thread (start-thread))) 42 | (sleep 5) 43 | (assert-true (bordeaux-threads:thread-alive-p thread)) 44 | (bordeaux-threads:interrupt-thread thread #'(lambda () 45 | nil)) 46 | (ignore-errors (bordeaux-threads:join-thread thread)) 47 | (assert-true finished-properly))))) 48 | -------------------------------------------------------------------------------- /tests/posix.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.TESTS") 2 | 3 | (define-test define-system-call 4 | (let ((fd (basic-binary-ipc::%ff-socket :pf-inet :sock-stream 0))) 5 | (assert-true (plusp fd)) 6 | (assert-true (zerop (basic-binary-ipc::%ff-close fd))) 7 | (assert-error 'socket-error (basic-binary-ipc::%ff-close fd)))) 8 | 9 | (define-test poll-fd-event-test/sexp 10 | (labels ((true (expression revents) 11 | (assert-true (basic-binary-ipc::poll-fd-event-test expression revents nil))) 12 | (false (expression revents) 13 | (assert-false (basic-binary-ipc::poll-fd-event-test expression revents nil)))) 14 | (true 'pollin '(pollin)) 15 | (false 'pollhup '(pollin)) 16 | (true '(or pollin pollhup) '(pollin)) 17 | (true '(or pollin pollhup) '(pollhup)) 18 | (false '(or pollin pollhup) '()) 19 | (true '(or pollin (not pollhup)) '()) 20 | (false '(and pollin (not pollhup)) '()) 21 | (true '(and pollin (not pollhup)) '(pollin)) 22 | (false '(and pollin (not pollhup)) '(pollin pollhup)) 23 | 24 | (true '(or pollin pollhup) '(pollin)) 25 | (true '(not (and (not pollin) (not pollhup))) '(pollin)) 26 | (true '(or pollin pollhup) '(pollhup)) 27 | (true '(not (and (not pollin) (not pollhup))) '(pollhup)) 28 | 29 | (true '(and pollhup (lambda (socket) 30 | (null socket))) 31 | '(pollhup)))) 32 | 33 | (define-test poll-fd-event-test/compiled 34 | (labels ((true (expression revents) 35 | (let ((fn (basic-binary-ipc::compile-poll-fd-event-expression expression))) 36 | (assert-true (basic-binary-ipc::poll-fd-event-test fn revents nil)))) 37 | (false (expression revents) 38 | (let ((fn (basic-binary-ipc::compile-poll-fd-event-expression expression))) 39 | (assert-false (basic-binary-ipc::poll-fd-event-test fn revents nil))))) 40 | (true 'pollin '(pollin)) 41 | (false 'pollhup '(pollin)) 42 | (true '(or pollin pollhup) '(pollin)) 43 | (true '(or pollin pollhup) '(pollhup)) 44 | (false '(or pollin pollhup) '()) 45 | (true '(or pollin (not pollhup)) '()) 46 | (false '(and pollin (not pollhup)) '()) 47 | (true '(and pollin (not pollhup)) '(pollin)) 48 | (false '(and pollin (not pollhup)) '(pollin pollhup)) 49 | 50 | (true '(or pollin pollhup) '(pollin)) 51 | (true '(not (and (not pollin) (not pollhup))) '(pollin)) 52 | (true '(or pollin pollhup) '(pollhup)) 53 | (true '(not (and (not pollin) (not pollhup))) '(pollhup)) 54 | 55 | (true '(and pollhup (lambda (socket) 56 | (null socket))) 57 | '(pollhup)))) 58 | -------------------------------------------------------------------------------- /src/posix-helpers.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | ;; All of the ERRNO wrapper stuff is inspired by the one in OSICAT. 4 | 5 | #+ (or darwin freebsd) 6 | (cffi:defcfun (%ff-get-errno-pointer "__error") (:pointer :int)) 7 | #+linux 8 | (cffi:defcfun (%ff-get-errno-pointer "__errno_location") (:pointer :int)) 9 | 10 | (defun %ff-get-errno () 11 | (cffi:mem-ref (%ff-get-errno-pointer) :int)) 12 | 13 | (cffi:defcfun (%ff-strerror "strerror_r") :string 14 | (errnum :int) 15 | (buffer :pointer) 16 | (buffer-size :unsigned-int)) 17 | 18 | (defun strerror (errnum) 19 | "Obtain the POSIX error string for the error with integer ERRNUM." 20 | (let ((buffer (make-array 1000 :element-type '(unsigned-byte 8)))) 21 | (cffi:with-pointer-to-vector-data (ptr buffer) 22 | (%ff-strerror errnum ptr (length buffer))) 23 | (babel:octets-to-string buffer :end (position 0 buffer)))) 24 | 25 | (defun errnum-symbol (errnum) 26 | "Map the error with integer ERRNUM to a symbol from the grovelled 27 | ERRNO-ENUM type." 28 | (cffi:foreign-enum-keyword 'errno-enum errnum)) 29 | 30 | (defgeneric lisp-function-name (object) 31 | (:documentation "The name of the LISP function that wraps the 32 | foreign posix function.")) 33 | 34 | (defgeneric c-function-name (object) 35 | (:documentation "The name of the foreign function that signalled the 36 | posix error.")) 37 | 38 | (define-condition posix-error (socket-error system-function-error) 39 | () 40 | (:documentation 41 | "This error class provides a lisp representation of POSIX errors.")) 42 | 43 | (defun posix-error-code (condition) 44 | (cffi:foreign-enum-keyword 'errno-enum (system-function-error-value condition))) 45 | 46 | (defun posix-error-code-p (condition code) 47 | (declare (type keyword code)) 48 | (eql (posix-error-code condition) 49 | code)) 50 | 51 | (defun posix-error-interrupted-p (condition) 52 | (posix-error-code-p condition :eintr)) 53 | 54 | (define-check-system-call check-posix (caller foreign-name return-value) 55 | (if (/= -1 return-value) 56 | return-value 57 | (let ((v (%ff-get-errno))) 58 | (error 'posix-error 59 | :name foreign-name 60 | :caller caller 61 | :error-value v 62 | :error-message (strerror v))))) 63 | 64 | (defmacro define-posix-system-call (name return-value &body arguments) 65 | `(define-system-call ,name (check-posix ,return-value) 66 | ,@arguments)) 67 | 68 | ;; Memory 69 | (defun zero-memory (pointer cffi-type) 70 | (dotimes (i (cffi:foreign-type-size cffi-type)) 71 | (setf (cffi:mem-aref pointer :uint8 i) 0)) 72 | pointer) 73 | -------------------------------------------------------------------------------- /src/protocols.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (defgeneric socket (object)) 4 | 5 | ;; Socket protocol 6 | (defclass socket () 7 | ()) 8 | 9 | (defgeneric close-socket (socket)) 10 | (defgeneric socket-closed-p (socket)) 11 | 12 | (define-condition socket-error (error) 13 | ((socket 14 | :initarg :socket 15 | :reader socket))) 16 | 17 | ;; Stream server protocol 18 | (defclass stream-server (socket) 19 | ()) 20 | 21 | (defgeneric accept-connection (server)) 22 | (defgeneric connection-available-p (server)) 23 | 24 | (define-condition no-connection-available-error (error) 25 | ((socket 26 | :initarg :socket 27 | :reader socket))) 28 | 29 | ;; Stream socket protocol 30 | (defclass stream-socket (socket) 31 | ()) 32 | 33 | ;; - Future connection protocol 34 | (defgeneric determinedp (stream-socket)) 35 | (defgeneric connection-failed-p (stream-socket)) 36 | (defgeneric connection-succeeded-p (stream-socket)) 37 | (defgeneric connection-stream (stream-socket)) 38 | 39 | ;; - Connected protocol 40 | (defgeneric data-available-p (stream-socket)) 41 | (defgeneric ready-to-write-p (stream-socket)) 42 | (defgeneric remote-disconnected-p (stream-socket)) 43 | (defgeneric read-from-stream (stream-socket buffer &key start end)) 44 | (defgeneric write-to-stream (stream-socket buffer &key start end)) 45 | 46 | ;; Polling protocol 47 | (defgeneric poll-socket (socket socket-events timeout)) 48 | (defgeneric poll-sockets (all-sockets all-socket-events timeout)) 49 | 50 | ;; IPv4 protocol 51 | (defgeneric host-address (server)) 52 | (defgeneric port (server)) 53 | (defgeneric local-host-address (stream)) 54 | (defgeneric local-port (stream)) 55 | (defgeneric remote-host-address (stream)) 56 | (defgeneric remote-port (stream)) 57 | 58 | ;; Poller protocol 59 | (defclass poller () 60 | ()) 61 | 62 | (defgeneric wait-for-events (poller timeout)) 63 | (defgeneric monitoredp (poller socket)) 64 | (defgeneric monitor-socket (poller socket socket-events)) 65 | (defgeneric unmonitor-socket (poller socket)) 66 | (defgeneric monitored-events (poller socket)) 67 | (defgeneric (setf monitored-events) (value poller socket)) 68 | (defgeneric monitored-sockets (poller)) 69 | (defgeneric close-poller (poller)) 70 | 71 | ;; Helper functions 72 | (defun do-with-socket (socket function) 73 | (unwind-protect 74 | (funcall function socket) 75 | (close-socket socket))) 76 | 77 | (defmacro with-socket ((var form) &body body) 78 | `(do-with-socket ,form #'(lambda (,var) 79 | ,@body))) 80 | 81 | (defun do-with-poller (function poller) 82 | (unwind-protect 83 | (funcall function poller) 84 | (close-poller poller))) 85 | 86 | (defmacro with-poller ((var form) &body body) 87 | `(do-with-poller #'(lambda (,var) 88 | ,@body) 89 | ,form)) 90 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Basic Binary IPC 2 | ================ 3 | 4 | The basic binary IPC system provides an interface for performing inter 5 | process communication using IPv4 or local streams. The interface 6 | follows a non-blocking pattern which allows applications to 7 | communicate either synchronously or asynchronously. 8 | 9 | The interface has been implemented for the following platforms: 10 | - Linux (poll and epoll) 11 | - OSX (poll and kqueue) 12 | - FreeBSD (poll and kqueue) 13 | - Windows 8 (Overlapped I/O) 14 | 15 | The complete documentation to this system can be found in 16 | `doc/basic-binary-ipc.html` or 17 | [online](http://markcox80.github.io/basic-binary-ipc/). 18 | 19 | The only requirement for this system is `CFFI`. 20 | 21 | Example 22 | ------- 23 | The file `examples/echo-example.lisp` contains an example echo server 24 | and echo client. The code for the server and client is shown below. 25 | 26 | The echo server can be started using 27 | ```common-lisp 28 | (load "examples/echo-example.lisp") 29 | (echo-example:run-server 12345) 30 | ``` 31 | 32 | The echo client can be executed using 33 | ```common-lisp 34 | (load "examples/echo-example.lisp") 35 | (echo-example:send-to-server "Hello World" basic-binary-ipc:+ipv4-loopback+ 12345) 36 | ``` 37 | 38 | ### Server 39 | 40 | ```common-lisp 41 | (defun run-server (port &optional (host-address +ipv4-loopback+)) 42 | (check-type port (unsigned-byte 16)) 43 | (check-type host-address string) 44 | 45 | (with-socket (server (make-ipv4-tcp-server host-address port :reuse-address t)) 46 | (loop 47 | :with buffer-size := 10000 48 | :with buffer := (make-array buffer-size :element-type '(unsigned-byte 8)) 49 | :for result := (poll-socket server 'connection-available-p 10) 50 | :when result 51 | :do 52 | (with-socket (client (accept-connection server)) 53 | (loop 54 | :for attempts :from 0 :below 3 55 | :for data-available := (poll-socket client 'data-available-p 10) 56 | :when data-available 57 | :do 58 | (let ((bytes-read (read-from-stream client buffer))) 59 | (write-to-stream client buffer :end bytes-read))))))) 60 | ``` 61 | 62 | ### Client 63 | 64 | ```common-lisp 65 | (defun send-to-server (string host-address port) 66 | (check-type string string) 67 | (check-type host-address string) 68 | (check-type port (unsigned-byte 16)) 69 | 70 | (with-socket (client (connect-to-ipv4-tcp-server host-address port)) 71 | (unless (poll-socket client 'connection-succeeded-p 10) 72 | (error "Failed to connect to address ~A:~d" host-address port)) 73 | 74 | (write-to-stream client (babel:string-to-octets string)) 75 | 76 | (loop 77 | :for attempts :from 0 :below 3 78 | :for data-available := (poll-socket client 'data-available-p 10) 79 | :until data-available 80 | :finally (unless data-available 81 | (error "Echo server not working."))) 82 | 83 | (let* ((buffer (make-array 100000 :element-type '(unsigned-byte 8))) 84 | (bytes-read (read-from-stream client buffer))) 85 | (babel:octets-to-string buffer :end bytes-read)))) 86 | ``` -------------------------------------------------------------------------------- /src/posix-socket-options.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | ;; Socket option arguments 4 | (defgeneric soa-base-type (soa)) 5 | (defgeneric soa-size (soa)) 6 | (defgeneric soa-translate-from-memory (soa pointer)) 7 | (defgeneric soa-translate-to-memory (soa value pointer)) 8 | 9 | (defclass socket-option-argument () 10 | ((base-type 11 | :initarg :base-type 12 | :reader soa-base-type))) 13 | 14 | (defmethod soa-size ((object socket-option-argument)) 15 | (cffi:foreign-type-size (soa-base-type object))) 16 | 17 | (defun socket-option-argument (symbol) 18 | (get symbol 'socket-option-argument)) 19 | 20 | (defun (setf socket-option-argument) (value symbol) 21 | (setf (get symbol 'socket-option-argument) value)) 22 | 23 | (defun ensure-socket-option-argument (name &key base-type) 24 | (setf (socket-option-argument name) (make-instance 'socket-option-argument 25 | :base-type base-type))) 26 | 27 | (defmacro define-socket-option-argument (name &body options) 28 | (labels ((option-values (key) 29 | (let ((v (find key options :key #'first))) 30 | (assert v) 31 | (rest v))) 32 | (option-value (key) 33 | (let ((v (option-values key))) 34 | (assert (= 1 (length v))) 35 | (first v)))) 36 | (let ((soa-object (gensym))) 37 | `(progn 38 | (ensure-socket-option-argument ',name :base-type ,(option-value :base-type)) 39 | ,(destructuring-bind ((value pointer) &rest body) (option-values :writer) 40 | `(defmethod soa-translate-to-memory ((,soa-object (eql ',name)) ,value ,pointer) 41 | ,@body)) 42 | ,(destructuring-bind ((pointer) &rest body) (option-values :reader) 43 | `(defmethod soa-translate-from-memory ((,soa-object (eql ',name)) ,pointer) 44 | ,@body)))))) 45 | 46 | ;; Socket options 47 | (defun do-define-socket-option/reader (name socket-option-name socket-option-argument &key (level :sol-socket)) 48 | `(defmethod ,name ((object posix-socket)) 49 | (let ((soa (socket-option-argument ',socket-option-argument))) 50 | (cffi:with-foreign-object (ptr (soa-base-type soa)) 51 | (cffi:with-foreign-object (ptr-length 'socklen-t) 52 | (setf (cffi:mem-ref ptr-length 'socklen-t) (soa-size soa)) 53 | (%ff-getsockopt (file-descriptor object) ,level ,socket-option-name ptr ptr-length) 54 | (assert (= (cffi:mem-ref ptr-length 'socklen-t) 55 | (soa-size soa))) 56 | (soa-translate-from-memory ',socket-option-argument ptr)))))) 57 | 58 | (defun do-define-socket-option/writer (name socket-option-name socket-option-argument &key (level :sol-socket)) 59 | `(defmethod (setf ,name) (value (object posix-socket)) 60 | (let ((soa (socket-option-argument ',socket-option-argument))) 61 | (cffi:with-foreign-object (ptr (soa-base-type soa)) 62 | (soa-translate-to-memory ',socket-option-argument value ptr) 63 | (%ff-setsockopt (file-descriptor object) ,level ,socket-option-name ptr (soa-size soa))) 64 | value))) 65 | 66 | (defmacro define-socket-option ((name socket-option-name socket-option-argument) &rest args &key (level :sol-socket)) 67 | (declare (ignore level)) 68 | `(progn 69 | ,(apply #'do-define-socket-option/reader name socket-option-name socket-option-argument args) 70 | ,(apply #'do-define-socket-option/writer name socket-option-name socket-option-argument args))) 71 | 72 | 73 | -------------------------------------------------------------------------------- /src/posix-cffi.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (cffi:defctype posix-socket-protocol :int) 4 | 5 | (define-posix-system-call (%ff-socket "socket") :int 6 | (domain posix-socket-namespace) 7 | (type posix-socket-type) 8 | (protocol posix-socket-protocol)) 9 | 10 | (define-posix-system-call (%ff-close "close") :int 11 | (file-descriptor :int)) 12 | 13 | (define-posix-system-call (%ff-bind "bind") :int 14 | (socket :int) 15 | (socket-address :pointer) 16 | (socket-address-length socklen-t)) 17 | 18 | (define-posix-system-call (%ff-listen "listen") :int 19 | (socket :int) 20 | (backlog :int)) 21 | 22 | (cffi:defcfun (%ff-inet-aton "inet_aton") :int 23 | (name :string) 24 | (addr (:pointer (:struct in-addr)))) 25 | 26 | (cffi:defcfun (%ff-htons "htons") :uint16 27 | (host-short :uint16)) 28 | 29 | (cffi:defcfun (%ff-ntohs "ntohs") :uint16 30 | (network-short :uint16)) 31 | 32 | (cffi:defcfun (%ff-ntohl "ntohl") :uint32 33 | (network-long :uint32)) 34 | 35 | ;; This is a potential source of problems. 36 | ;; The prototype for inet_ntoa is 37 | ;; char *inet_ntoa(struct in_addr addr) 38 | (cffi:defcfun (%ff-inet-ntoa "inet_ntoa") :string 39 | (addr :uint32)) 40 | 41 | ;; This should at least check if the hack with %ff-inet-ntoa (above) 42 | ;; works. 43 | (assert (= (cffi:foreign-type-size :uint32) 44 | (cffi:foreign-type-size '(:struct in-addr)))) 45 | 46 | ;; FCNTL 47 | (define-posix-system-call (%ff-fcntl-noarg "fcntl") :int 48 | (file-descriptor :int) 49 | (command fcntl-command)) 50 | 51 | (define-posix-system-call (%ff-fcntl-setfl "fcntl") :int 52 | (file-descriptor :int) 53 | (command fcntl-command) 54 | (mode operating-mode)) 55 | 56 | 57 | ;; Socket options 58 | (define-posix-system-call (%ff-getsockopt "getsockopt") :int 59 | (socket :int) 60 | (level socket-level) 61 | (option-name socket-option) 62 | (option-value :pointer) 63 | (option-length (:pointer socklen-t))) 64 | 65 | (define-posix-system-call (%ff-setsockopt "setsockopt") :int 66 | (socket :int) 67 | (level socket-level) 68 | (option-name socket-option) 69 | (option-value :pointer) 70 | (option-length socklen-t)) 71 | 72 | 73 | ;; connecting 74 | (define-posix-system-call (%ff-connect "connect") :int 75 | (socket :int) 76 | (address :pointer) 77 | (address-len socklen-t)) 78 | 79 | (define-posix-system-call (%ff-getsockname "getsockname") :int 80 | (socket :int) 81 | (address :pointer) 82 | (address-length (:pointer socklen-t))) 83 | 84 | ;; accept 85 | (define-posix-system-call (%ff-accept "accept") :int 86 | (socket :int) 87 | (address :pointer) 88 | (address-len (:pointer socklen-t))) 89 | 90 | ;; poll 91 | (define-posix-system-call (%ff-poll "poll") :int 92 | (fds (:pointer (:struct pollfd))) 93 | (nfds nfds-t) 94 | (timeout :int)) 95 | 96 | ;; reading 97 | (define-posix-system-call (%ff-recvfrom "recvfrom") :int 98 | (socket :int) 99 | (buffer :pointer) 100 | (length size-t) 101 | (flags message-flags) 102 | (address :pointer) 103 | (address-len (:pointer socklen-t))) 104 | 105 | ;; writing 106 | (define-posix-system-call (%ff-sendto "sendto") :int 107 | (socket :int) 108 | (buffer :pointer) 109 | (length size-t) 110 | (flags message-flags) 111 | (dest-addr :pointer) 112 | (dest-len socklen-t)) 113 | 114 | ;;;; Resolving addresses 115 | (cffi:defcfun (%ff-getaddrinfo "getaddrinfo") :int 116 | (hostname :string) 117 | (service-name :string) 118 | (hints (:pointer (:struct addrinfo))) 119 | (result :pointer)) 120 | 121 | (cffi:defcfun (%ff-freeaddrinfo "freeaddrinfo") :void 122 | (address-info (:pointer (:struct addrinfo)))) 123 | 124 | (cffi:defcfun (%ff-gai-strerror "gai_strerror") :string 125 | (code :int)) 126 | -------------------------------------------------------------------------------- /src/overlapped-io-errors.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.OVERLAPPED-IO") 2 | 3 | ;;;; Size checks 4 | ;; nSize in %FF-FORMAT-MESSAGE is the number of TCHARs in 5 | ;; LPTSTR. Make sure TCHAR is an unsigned byte. 6 | (assert (= 1 (cffi:foreign-type-size 'tchar))) 7 | 8 | ;; DWORD is a pain. The Micorsoft documentation states that it should 9 | ;; be a 32 bit unsigned integer. Unfortunately, the groveller (as of 10 | ;; 2013-09-08) does not handle unsigned types properly. I have sent a 11 | ;; patch to CFFI to fix CONSTANTENUM to print the correct value but it 12 | ;; relies on :UNSIGNED-INT rather than the stricter :uint32. These two 13 | ;; assertions check that this hack is correct. 14 | (assert (= 4 (cffi:foreign-type-size :unsigned-int))) 15 | (assert (= 4 (cffi:foreign-type-size 'dword))) 16 | 17 | ;;;; Obtaining the error message for a given ERRNUM. 18 | (cffi:defcfun (%ff-format-message "FormatMessageA") dword 19 | (dwFlags dword) 20 | (lpSource lpcvoid) 21 | (dwMessageId dword) 22 | (dwLanguageId dword) 23 | (lpBuffer lptstr) 24 | (nSize dword) 25 | (arguments :pointer)) 26 | 27 | (defun %error-message (errnum) 28 | "Obtain the message for the error represented by ERRNUM." 29 | (check-type errnum (integer 0)) 30 | (let ((buffer (make-array 1000 :element-type '(unsigned-byte 8)))) 31 | (cffi:with-pointer-to-vector-data (ptr buffer) 32 | (let ((number-of-characters 33 | (%ff-format-message (cffi:foreign-bitfield-value 'format-message-flags '(:format-message-from-system 34 | :format-message-ignore-inserts)) 35 | 0 36 | errnum 37 | 0 38 | (cffi:pointer-address ptr) (length buffer) 39 | (cffi:null-pointer)))) 40 | (assert (plusp number-of-characters)) 41 | (string-trim '(#\Return #\Newline) (babel:octets-to-string buffer :end number-of-characters)))))) 42 | 43 | ;;;; Functions for obtaining the last error 44 | (cffi:defcfun (%ff-wsa-get-last-error "WSAGetLastError") winsock-error-codes) 45 | (cffi:defcfun (%ff-get-last-error "GetLastError") error-codes) 46 | 47 | (defun error-message (error-code) 48 | (check-type error-code keyword) 49 | (%error-message (cffi:foreign-enum-value 'error-codes error-code))) 50 | 51 | (defun winsock-error-message (error-code) 52 | (check-type error-code keyword) 53 | (%error-message (cffi:foreign-enum-value 'winsock-error-codes error-code))) 54 | 55 | ;;;; System call checkers 56 | (defun signal-foreign-function-error (caller name) 57 | (let ((v (%ff-get-last-error))) 58 | (error 'system-function-error 59 | :caller caller 60 | :name name 61 | :error-value v 62 | :error-message (error-message v)))) 63 | 64 | (defun signal-socket-foreign-function-error (caller name) 65 | (let ((error-code (%ff-wsa-get-last-error))) 66 | (error 'system-function-error 67 | :caller caller 68 | :name name 69 | :error-value error-code 70 | :error-message (winsock-error-message error-code)))) 71 | 72 | ;; File system call checkers 73 | (define-check-system-call check-valid-handle (caller name return-value) 74 | (if (eql return-value +invalid-handle-value+) 75 | (signal-foreign-function-error caller name) 76 | return-value)) 77 | 78 | (define-check-system-call check-true (caller name return-value) 79 | (if (eql return-value +false+) 80 | (signal-foreign-function-error caller name) 81 | return-value)) 82 | 83 | (define-check-system-call check-non-null (caller name return-value) 84 | (if (= +null+ return-value) 85 | (signal-foreign-function-error caller name) 86 | return-value)) 87 | 88 | (define-check-system-call check-overlapped (caller name return-value &key (pass-errors '(:error-io-pending))) 89 | (cond 90 | ((= +false+ return-value) 91 | (let ((v (%ff-get-last-error))) 92 | (if (find v pass-errors) 93 | (values +false+ v) 94 | (signal-foreign-function-error caller name)))) 95 | (t 96 | (values +true+ :no-error)))) 97 | 98 | (define-check-system-call check-socket-zero (caller name return-value) 99 | (if (/= 0 return-value) 100 | (signal-socket-foreign-function-error caller name) 101 | return-value)) 102 | 103 | (define-check-system-call check-socket-overlapped (caller name return-value &key (pass-errors '(:wsa-io-pending))) 104 | 105 | (cond 106 | ((= +false+ return-value) 107 | (let ((v (%ff-wsa-get-last-error))) 108 | (if (find v pass-errors) 109 | (values +false+ v) 110 | (signal-socket-foreign-function-error caller name)))) 111 | (t 112 | (values +true+ :no-error)))) 113 | -------------------------------------------------------------------------------- /src/posix-grovel.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | #+linux (define "_GNU_SOURCE" 1) 4 | #+freebsd (include "sys/types.h") 5 | 6 | (include "errno.h") 7 | 8 | (constantenum (errno-enum :base-type :int) 9 | ((:eagain "EAGAIN")) 10 | ((:ewouldblock "EWOULDBLOCK")) 11 | ((:ebadf "EBADF")) 12 | ((:eintr "EINTR")) 13 | ((:eio "EIO")) 14 | ((:eacces "EACCES")) 15 | ((:eafnosupport "EAFNOSUPPORT")) 16 | ((:eisconn "EISCONN")) 17 | ((:emfile "EMFILE")) 18 | ((:enfile "ENFILE")) 19 | ((:enobufs "ENOBUFS")) 20 | ((:enomem "ENOMEM")) 21 | ((:enospc "ENOSPC")) 22 | ((:eprotonosupport "EPROTONOSUPPORT")) 23 | ((:eprototype "EPROTOTYPE")) 24 | ((:eaddrinuse "EADDRINUSE")) 25 | ((:eaddrnotavail "EADDRNOTAVAIL")) 26 | ((:edestaddrreq "EDESTADDRREQ")) 27 | ((:efault "EFAULT")) 28 | ((:emsgsize "EMSGSIZE")) 29 | ((:einval "EINVAL")) 30 | ((:enotsock "ENOTSOCK")) 31 | ((:eopnotsupp "EOPNOTSUPP")) 32 | ((:ealready "EALREADY")) 33 | ((:econnrefused "ECONNREFUSED")) 34 | ((:ehostunreach "EHOSTUNREACH")) 35 | ((:einprogress "EINPROGRESS")) 36 | ((:ehostdown "EHOSTDOWN")) 37 | ((:enetdown "ENETDOWN")) 38 | ((:enetunreach "ENETUNREACH")) 39 | ((:etimedout "ETIMEDOUT")) 40 | ((:econnreset "ECONNRESET")) 41 | ((:eloop "ELOOP")) 42 | ((:enametoolong "ENAMETOOLONG")) 43 | ((:enoent "ENOENT")) 44 | ((:enotdir "ENOTDIR")) 45 | ((:epipe "EPIPE")) 46 | ((:enoprotoopt "ENOPROTOOPT")) 47 | ((:eperm "EPERM")) 48 | ((:enotconn "ENOTCONN"))) 49 | 50 | (include "fcntl.h") 51 | 52 | (constantenum (fcntl-command :base-type :int) 53 | ((:f-getfl "F_GETFL")) 54 | ((:f-setfl "F_SETFL"))) 55 | 56 | (bitfield (operating-mode :base-type :int) 57 | ((o-nonblock "O_NONBLOCK"))) 58 | 59 | (include "sys/socket.h") 60 | 61 | (constantenum (posix-socket-namespace :base-type :int) 62 | ((:pf-inet "PF_INET")) 63 | ((:pf-local "PF_LOCAL"))) 64 | 65 | (constantenum (posix-socket-type :base-type :int) 66 | ((:sock-stream "SOCK_STREAM")) 67 | ((:sock-dgram "SOCK_DGRAM"))) 68 | 69 | (constantenum (socket-level :base-type :int) 70 | ((:sol-socket "SOL_SOCKET"))) 71 | 72 | (constantenum (socket-option :base-type :int) 73 | ((:so-reuseaddr "SO_REUSEADDR")) 74 | ((:so-keepalive "SO_KEEPALIVE"))) 75 | 76 | (ctype socklen-t "socklen_t") 77 | 78 | (include "netinet/in.h") 79 | 80 | (ctype sa-family-t "sa_family_t") 81 | (constantenum (posix-socket-address-family :base-type sa-family-t) 82 | ((:af-inet "AF_INET")) 83 | ((:af-local "AF_LOCAL"))) 84 | 85 | (constantenum (posix-socket-protocols :base-type :int) 86 | ((:default "NULL")) 87 | ((:ipproto-tcp "IPPROTO_TCP"))) 88 | 89 | (cstruct in-addr "struct in_addr" 90 | (s-addr "s_addr" :type :uint32)) 91 | 92 | (cstruct sockaddr-in "struct sockaddr_in" 93 | (sin-family "sin_family" :type posix-socket-address-family) 94 | (sin-addr "sin_addr" :type (:struct in-addr)) 95 | (sin-port "sin_port" :type :unsigned-short)) 96 | 97 | (constant (inaddr-loopback "INADDR_LOOPBACK")) 98 | (constant (inaddr-any "INADDR_ANY")) 99 | (constant (inaddr-broadcast "INADDR_BROADCAST")) 100 | (constant (inaddr-none "INADDR_NONE")) 101 | 102 | ; Local Sockets 103 | (include "sys/un.h") 104 | 105 | (cstruct sockaddr-un "struct sockaddr_un" 106 | (sun-family "sun_family" :type posix-socket-address-family) 107 | (sun-path "sun_path" :type :char)) 108 | 109 | ; poll 110 | #+linux (define "__USE_XOPEN" 1) 111 | (include "poll.h") 112 | 113 | (ctype nfds-t "nfds_t") 114 | 115 | (bitfield (poll-events :base-type :short) 116 | ((pollerr "POLLERR")) 117 | ((pollhup "POLLHUP")) 118 | ((pollin "POLLIN")) 119 | ((pollnval "POLLNVAL")) 120 | ((pollout "POLLOUT")) 121 | ((pollpri "POLLPRI")) 122 | ((pollrdband "POLLRDBAND")) 123 | ((pollrdnorm "POLLRDNORM")) 124 | ((pollwrband "POLLWRBAND")) 125 | ((pollwrnorm "POLLWRNORM"))) 126 | 127 | (cstruct pollfd "struct pollfd" 128 | (fd "fd" :type :int) 129 | (events "events" :type poll-events) 130 | (revents "revents" :type poll-events)) 131 | 132 | (ctype size-t "size_t") 133 | (bitfield (message-flags :base-type :int) 134 | ((msg-oob "MSG_OOB")) 135 | ((msg-peek "MSG_PEEK")) 136 | ((msg-waitall "MSG_WAITALL")) 137 | ((msg-dontroute "MSG_DONTROUTE"))) 138 | 139 | ; getaddrinfo 140 | (include "netdb.h") 141 | (bitfield (addrinfo-flags :base-type :int) 142 | ((ai-addrconfig "AI_ADDRCONFIG")) 143 | ((ai-all "AI_ALL")) 144 | ((ai-canonname "AI_CANONNAME")) 145 | ((ai-numerichost "AI_NUMERICHOST")) 146 | ((ai-numericserv "AI_NUMERICSERV")) 147 | ((ai-passive "AI_PASSIVE")) 148 | ((ai-v4mapped "AI_V4MAPPED"))) 149 | 150 | (cstruct addrinfo "struct addrinfo" 151 | (ai-flags "ai_flags" :type addrinfo-flags) 152 | (ai-family "ai_family" :type posix-socket-namespace) 153 | (ai-socktype "ai_socktype" :type posix-socket-type) 154 | (ai-protocol "ai_protocol" :type posix-socket-protocols) 155 | (ai-addrlen "ai_addrlen" :type socklen-t) 156 | (ai-addr "ai_addr" :type :pointer) 157 | (ai-canonname "ai_canonname" :type :string) 158 | (ai-next "ai_next" :type :pointer)) 159 | 160 | (constantenum (addrinfo-error-codes :base-type :int) 161 | ((:eai-noname "EAI_NONAME")) 162 | #+linux 163 | ((:eai-nodata "EAI_NODATA"))) 164 | -------------------------------------------------------------------------------- /src/system-calls.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | ;; The code in this file provides an abstraction for invoking 4 | ;; functions provided by the operating system, or more succinctly, 5 | ;; system calls. A common pattern with system calls is the manner in 6 | ;; which errors are communicated from the operating system to the 7 | ;; calling process. Below are examples on different operating systems 8 | ;; and also different APIs on the same operating system. 9 | ;; 10 | ;; // On Posix based systems: 11 | ;; ssize_t rv = read(fd, buffer, buffer_size); 12 | ;; if (rv == -1) { 13 | ;; printf("ERROR: %s\n", strerror(errno)); 14 | ;; return FAILED; 15 | ;; } 16 | ;; 17 | ;; // On Windows (Winsock): 18 | ;; SOCKET s = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); 19 | ;; if (s == INVALID_SOCKET) { 20 | ;; int last_error = WSAGetLastError(); 21 | ;; WCHAR buffer[1024]; 22 | ;; FormatMessage(FORMAT_MESSAGE_FROM_STRING | FORMAT_MESSAGE_IGNORE_INSERTS, 23 | ;; 0, last_error, 0, buffer, 1024, NULL); 24 | ;; return FAILED; 25 | ;; } 26 | ;; 27 | ;; // On Windows (Named Pipes) 28 | ;; HANDLE h = CreateFileA(pipe_name, GENERIC_READ | GENERIC_WRITE, ... ); 29 | ;; if (h == INVALID_HANDLE_ERROR) { 30 | ;; DWORD last_error = GetLastError(); 31 | ;; WCHAR buffer[1024]; 32 | ;; FormatMessage(FORMAT_MESSAGE_FROM_STRING | FORMAT_MESSAGE_IGNORE_INSERTS, 33 | ;; 0, last_error, 0, buffer, 1024, NULL); 34 | ;; return FAILED; 35 | ;; } 36 | ;; 37 | ;; The goal of this file is to provide a convenient method of defining 38 | ;; a foreign function which signals an appropriate Lisp condition when 39 | ;; an error occurs rather than the style of programming demonstrated 40 | ;; above. 41 | ;; 42 | ;; All examples can use the common foreign function interface (CFFI) 43 | ;; to interface with the operating system. Customisation is needed to 44 | ;; determine if an error has occurred, and if so, signal the 45 | ;; appropriate condition. 46 | ;; 47 | ;; The class of the signalled condition should be a subclass of 48 | ;; SYSTEM-FUNCTION-ERROR. Instances of this class encapsulate the 49 | ;; information pertinent to the user: the foreign function that 50 | ;; failed, the caller of the foreign function, the value of the error 51 | ;; returned, and a nice user friendly message describing the error 52 | ;; returned. 53 | 54 | (defgeneric system-function-caller (condition) 55 | (:documentation "The name of the function which invoked the 56 | system function that failed.")) 57 | 58 | (defgeneric system-function-name (condition) 59 | (:documentation "The name of the system call that failed.")) 60 | 61 | (defgeneric system-function-error-value (condition) 62 | (:documentation "The error value communicated by the system call.")) 63 | 64 | (defgeneric system-function-error-message (condition) 65 | (:documentation "A user friendly message describing the system call 66 | failure.")) 67 | 68 | (define-condition system-function-error (error) 69 | ((caller 70 | :initarg :caller 71 | :reader system-function-caller) 72 | (name 73 | :initarg :name 74 | :reader system-function-name) 75 | (error-value 76 | :initarg :error-value 77 | :reader system-function-error-value) 78 | (error-message 79 | :initarg :error-message 80 | :reader system-function-error-message)) 81 | (:report (lambda (condition stream) 82 | (format stream "The system function ~S failed. (~S ~A)" 83 | (system-function-name condition) 84 | (system-function-error-value condition) 85 | (system-function-error-message condition))))) 86 | 87 | ;; Creating a Lisp function which performs the system call and checks 88 | ;; the return value requires two macros, DEFINE-SYSTEM-CALL and 89 | ;; DEFINE-CHECK-SYSTEM-CALL. The DEFINE-SYSTEM-CALL macro defines the 90 | ;; lisp function and DEFINE-CHECK-SYSTEM-CALL defines a function that 91 | ;; is used to evaluate the return value of the foreign function, and 92 | ;; if required, signal a condition. 93 | ;; 94 | ;; The prototypes for the two macros are: 95 | ;; 96 | ;; (defmacro define-system-call name-and-options (name-of-check-system-call return-type &rest args &key) &body args) 97 | ;; (defmacro define-check-system-call (name lambda-args &body body)) 98 | ;; 99 | ;; DEFINE-SYSTEM-CALL requires a name of a system call checker created 100 | ;; with DEFINE-CHECK-SYSTEM-CALL. 101 | ;; 102 | ;; An example of DEFINE-CHECK-SYSTEM-CALL is as follows 103 | ;; 104 | ;; (define-check-system-call check-posix (caller name return-value) 105 | ;; (if (/= return-value -1) 106 | ;; return-value 107 | ;; (let ((errno (%ff-get-errno))) 108 | ;; (error 'posix-error 109 | ;; :caller caller 110 | ;; :name name 111 | ;; :error-value 112 | ;; :error-message (strerror errno))))) 113 | ;; 114 | ;; With a "checker" defined, the DEFINE-SYSTEM-CALL macro can be 115 | ;; used. The only difference between DEFINE-SYSTEM-CALL and 116 | ;; CFFI:DEFCFUN is in the processing of the RETURN-TYPE argument. The 117 | ;; return type argument is used to select the "checker" for the system 118 | ;; call. 119 | ;; 120 | ;; (define-system-call (%ff-read "read") (check-posix :int) 121 | ;; (fd :int) 122 | ;; (buffer (:pointer :uint8)) 123 | ;; (length :unsigned-int)) 124 | 125 | (defmacro define-check-system-call (name (caller foreign-name return-value &rest args) &body body) 126 | `(defun ,name (,caller ,foreign-name ,return-value ,@args) 127 | ,@body)) 128 | 129 | (defmacro define-system-call (name-and-options return-type-info &body args) 130 | (destructuring-bind (lisp-name ff-name) (if (stringp (first name-and-options)) 131 | (reverse name-and-options) 132 | name-and-options) 133 | (destructuring-bind (checker-name return-type &rest checker-args) return-type-info 134 | (let ((act-ff-name (gensym (symbol-name lisp-name))) 135 | (argument-names (mapcar #'first args))) 136 | `(progn 137 | (cffi:defcfun (,act-ff-name ,ff-name) ,return-type ,@args) 138 | (defun ,lisp-name ,argument-names 139 | (let ((rv (,act-ff-name ,@argument-names))) 140 | (,checker-name ',lisp-name ,ff-name rv ,@checker-args)))))))) 141 | -------------------------------------------------------------------------------- /tests/poller.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.TESTS") 2 | 3 | (defun poller-test-helper (server-fn client-fn) 4 | (labels ((transmit-data (poller client remote-client) 5 | (assert-equal nil (monitored-events poller client)) 6 | (assert-equal nil (monitored-events poller remote-client)) 7 | 8 | (monitor-socket poller client '(connection-succeeded-p data-available-p ready-to-write-p)) 9 | (monitor-socket poller remote-client '(connection-succeeded-p data-available-p ready-to-write-p)) 10 | 11 | (assert-equal '(connection-succeeded-p data-available-p ready-to-write-p) (monitored-events poller client)) 12 | (assert-equal '(connection-succeeded-p data-available-p ready-to-write-p) (monitored-events poller remote-client)) 13 | 14 | (let ((events (wait-for-events poller 10))) 15 | (assert-equal '(connection-succeeded-p ready-to-write-p) (second (find client events :key #'first))) 16 | (assert-equal '(connection-succeeded-p ready-to-write-p) (second (find remote-client events :key #'first)))) 17 | 18 | (setf (monitored-events poller client) '(data-available-p) 19 | (monitored-events poller remote-client) '(data-available-p)) 20 | 21 | (assert-equal '(data-available-p) (monitored-events poller client)) 22 | (assert-equal '(data-available-p) (monitored-events poller remote-client)) 23 | 24 | (let ((buffer (make-array 5 :element-type '(unsigned-byte 8) :initial-contents '(0 1 2 3 4)))) 25 | (write-to-stream client buffer)) 26 | 27 | (let ((events (wait-for-events poller 2))) 28 | (assert-equal 1 (length events)) 29 | (assert-equal '(data-available-p) (second (find remote-client events :key #'first)))) 30 | 31 | (let ((buffer (make-array 10 :element-type '(unsigned-byte 8)))) 32 | (assert-equal 5 (read-from-stream remote-client buffer))) 33 | 34 | (assert-equal nil (wait-for-events poller :immediate))) 35 | 36 | (use-client (poller server client) 37 | (let* ((events (wait-for-events poller 2)) 38 | (v (find server events :key #'first))) 39 | (assert-true (second v)) 40 | (let ((remote-client (accept-connection server))) 41 | (unwind-protect 42 | (transmit-data poller client remote-client) 43 | (close-socket remote-client) 44 | (unmonitor-socket poller remote-client)))) 45 | 46 | (setf (monitored-events poller client) '(connection-failed-p connection-succeeded-p remote-disconnected-p)) 47 | (let* ((events (wait-for-events poller 2)) 48 | (v (find client events :key #'first))) 49 | (assert-true (find 'remote-disconnected-p (second v))) 50 | (assert-true (find 'connection-failed-p (second v))) 51 | (assert-false (find 'connection-succeeded-p (second v)))))) 52 | 53 | (with-poller (poller (make-poller)) 54 | (with-socket (server (funcall server-fn)) 55 | (monitor-socket poller server 'connection-available-p) 56 | (assert-true (null (wait-for-events poller 0))) 57 | (with-socket (client (funcall client-fn)) 58 | (use-client poller server client)))))) 59 | 60 | (define-test poller/ipv4 61 | (:tag :poller) 62 | (let ((port (random-server-port))) 63 | (poller-test-helper #'(lambda () 64 | (make-ipv4-tcp-server +ipv4-loopback+ port)) 65 | #'(lambda () 66 | (connect-to-ipv4-tcp-server +ipv4-loopback+ port))))) 67 | 68 | (define-test poller/local 69 | (:tag :poller) 70 | (let ((path (local-socket-pathname))) 71 | (poller-test-helper #'(lambda () 72 | (make-local-server path)) 73 | #'(lambda () 74 | (connect-to-local-server path))))) 75 | 76 | (define-test poller/no-server 77 | (:tag :poller) 78 | (labels ((run-test (poller client) 79 | (format *standard-output* "~&; This test pauses for a maximum of 2 minutes, do not panic.~%") 80 | (let ((events (wait-for-events poller 120))) 81 | (assert-true events) 82 | (destructuring-bind (&optional socket matched-events) (first events) 83 | (assert-equal client socket) 84 | (assert-true (find 'determinedp matched-events)) 85 | (assert-false (find 'connection-succeeded-p matched-events)) 86 | (assert-true (find 'connection-failed-p matched-events)) 87 | 88 | (assert-false (connection-succeeded-p client)) 89 | (assert-true (connection-failed-p client)))))) 90 | (let ((client (connect-to-ipv4-tcp-server +ipv4-address-with-no-server+ (random-server-port))) 91 | (poller (make-poller))) 92 | (monitor-socket poller client '(determinedp connection-succeeded-p connection-failed-p)) 93 | (unwind-protect 94 | (run-test poller client) 95 | (close-socket client) 96 | (close-poller poller))))) 97 | 98 | #-freebsd 99 | (define-test poller/no-server/loopback 100 | (:tag :poller) 101 | (labels ((run-test (poller client) 102 | (format *standard-output* "~&; This test pauses for a maximum of 2 minutes, do not panic.~%") 103 | (let ((events (wait-for-events poller 120))) 104 | (assert-equal 1 (length events)) 105 | (destructuring-bind (&optional socket matched-events) (first events) 106 | (assert-equal client socket) 107 | (assert-true (find 'determinedp matched-events)) 108 | (assert-false (find 'connection-succeeded-p matched-events)) 109 | (assert-true (find 'connection-failed-p matched-events)) 110 | 111 | (assert-false (connection-succeeded-p client)) 112 | (assert-true (connection-failed-p client)))))) 113 | (let ((client (connect-to-ipv4-tcp-server +ipv4-loopback+ (random-server-port))) 114 | (poller (make-poller))) 115 | (unwind-protect 116 | (progn 117 | (monitor-socket poller client '(determinedp connection-succeeded-p connection-failed-p)) 118 | (run-test poller client)) 119 | (close-socket client) 120 | (close-poller poller))))) 121 | 122 | #+freebsd 123 | (define-test poller/no-server/loopback 124 | (:tag :poller) 125 | (warn "POLLER/NO-SERVER-LOOPBACK on FreeBSD is different to other 126 | hosts. For some reason EINVAL is signalled during MONITOR-SOCKET 127 | when it shouldn't be. I need to investigate this further, but for 128 | now, I just test for the presence of the bug.") 129 | (let ((client (connect-to-ipv4-tcp-server +ipv4-loopback+ (random-server-port))) 130 | (poller (make-poller))) 131 | (unwind-protect 132 | (assert-error 'error (monitor-socket poller client '(determinedp connection-succeeded-p connection-failed-p))) 133 | (close-socket client) 134 | (close-poller poller)))) 135 | 136 | #+(and thread-support (not windows)) 137 | (define-test poller/interrupt 138 | (:tag :poller) 139 | (let ((finished-properly nil)) 140 | (labels ((start-thread () 141 | (let ((port (random-server-port))) 142 | (bordeaux-threads:make-thread #'(lambda () 143 | (with-poller (poller (make-poller)) 144 | (with-socket (s (make-ipv4-tcp-server +ipv4-loopback+ port)) 145 | (monitor-socket poller s 'connection-available-p) 146 | (let ((rv (wait-for-events poller 60))) 147 | (setf finished-properly (list :poller rv)))))))))) 148 | (let ((thread (start-thread))) 149 | (sleep 5) 150 | (assert-true (bordeaux-threads:thread-alive-p thread)) 151 | (bordeaux-threads:interrupt-thread thread #'(lambda () 152 | nil)) 153 | (ignore-errors (bordeaux-threads:join-thread thread)) 154 | (destructuring-bind (&optional keyword rv) finished-properly 155 | (assert-eql :poller keyword) 156 | (assert-true (null rv))))))) 157 | -------------------------------------------------------------------------------- /src/overlapped-io-cffi.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.OVERLAPPED-IO") 2 | 3 | ;;;; Type size checks. 4 | ;;;; 5 | ;;;; The CFFI groveller can't use types that it has already found for 6 | ;;;; some reason. 7 | (assert (= (cffi:foreign-type-size 'dword) 8 | (cffi:foreign-type-size :unsigned-int))) 9 | 10 | ;;;; Handles 11 | (define-system-call (%ff-close-handle "CloseHandle") (check-true bool) 12 | (object handle)) 13 | 14 | ;;;; Overlapped Structures 15 | (cffi:defcfun (%ff-wait-for-single-object "WaitForSingleObject") wait 16 | (handle handle) 17 | (milliseconds dword)) 18 | 19 | (cffi:defcfun (%ff-wait-for-multiple-objects "WaitForMultipleObjects") dword 20 | (number-of-handles dword) 21 | (handles (:pointer handle)) 22 | (wait-for-all bool) 23 | (milliseconds dword)) 24 | 25 | (define-system-call (%ff-cancel-io "CancelIo") (check-true bool) 26 | (object handle)) 27 | 28 | (cffi:defcfun (%ff-get-overlapped-result "GetOverlappedResult") bool 29 | (handle handle) 30 | (overlapped (:pointer (:struct overlapped))) 31 | (ptr-bytes-transferred (:pointer dword)) 32 | (wait bool)) 33 | 34 | ;;;; Named Pipes 35 | (define-system-call (%ff-create-named-pipe "CreateNamedPipeA") (check-valid-handle handle) 36 | (name :string) 37 | (open-mode named-pipe-open-mode) 38 | (mode named-pipe-mode) 39 | (max-instances dword) 40 | (output-buffer-size dword) 41 | (in-buffer-size dword) 42 | (default-timeout dword) 43 | (security-attributes :pointer)) 44 | 45 | (define-system-call (%ff-create-file "CreateFileA") (check-valid-handle handle) 46 | (name :string) 47 | (desired-access file-desired-access) 48 | (share-mode file-share-mode) 49 | (security-attributes :pointer) 50 | (creation-disposition file-creation-disposition) 51 | (flags-and-attributes file-attribute) 52 | (template-file handle)) 53 | 54 | (define-system-call (%ff-connect-named-pipe "ConnectNamedPipe") 55 | (check-overlapped bool :pass-errors '(:error-io-pending :error-pipe-connected)) 56 | (server-handle handle) 57 | (overlapped (:pointer (:struct overlapped)))) 58 | 59 | (define-system-call (%ff-read-file "ReadFile") (check-overlapped bool) 60 | (handle handle) 61 | (buffer (:pointer :uint8)) 62 | (number-of-bytes-to-read dword) 63 | (number-of-bytes-read (:pointer dword)) 64 | (overlapped (:pointer (:struct overlapped)))) 65 | 66 | (define-system-call (%ff-write-file "WriteFile") (check-overlapped bool) 67 | (handle handle) 68 | (buffer (:pointer :uint8)) 69 | (number-of-bytes-to-write dword) 70 | (number-of-bytes-written (:pointer dword)) 71 | (overlapped (:pointer (:struct overlapped)))) 72 | 73 | ;;;; Events 74 | (define-system-call (%ff-create-event "CreateEventA") (check-non-null handle) 75 | (security-attributes :pointer) 76 | (manual-reset bool) 77 | (initial-state bool) 78 | (name :string)) 79 | 80 | (define-system-call (%ff-reset-event "ResetEvent") (check-true bool) 81 | (h-event handle)) 82 | 83 | (define-system-call (%ff-set-event "SetEvent") (check-true bool) 84 | (h-event handle)) 85 | 86 | ;;;; I/O Completion ports 87 | (define-system-call (%ff-create-io-completion-port "CreateIoCompletionPort") 88 | (check-valid-handle handle) 89 | (file-handle handle) 90 | (existing-completion-port handle) 91 | (completion-key (:pointer :unsigned-long)) 92 | (number-of-concurrent-threads dword)) 93 | 94 | (define-system-call (%ff-get-queued-completion-status "GetQueuedCompletionStatus") 95 | (check-overlapped bool :pass-errors '(:wait-timeout)) 96 | (completion-port handle) 97 | (ptr-number-of-bytes (:pointer dword)) 98 | (ptr-completion-key (:pointer (:pointer :unsigned-long))) 99 | (overlapped (:pointer (:struct overlapped))) 100 | (milliseconds dword)) 101 | 102 | ;;;; Sockets 103 | (cffi:defcfun (%%ff-wsa-socket "WSASocketA") socket 104 | (address-family socket-address-family) 105 | (type socket-type) 106 | (protocol socket-protocol) 107 | (protocol-info :pointer) 108 | (group socket-group) 109 | (flags socket-flags)) 110 | 111 | (defun %ff-socket (address-family type protocol) 112 | (let ((rv (%%ff-wsa-socket address-family type protocol 113 | (cffi:null-pointer) 0 :wsa-flag-overlapped))) 114 | (when (= rv +invalid-socket+) 115 | (signal-socket-foreign-function-error '%ff-socket "WSASocketA")) 116 | rv)) 117 | 118 | (cffi:defcfun (%%ff-close-socket "closesocket") :int 119 | (socket socket)) 120 | 121 | (defun %ff-close-socket (socket) 122 | (let ((rv (%%ff-close-socket socket))) 123 | (unless (zerop rv) 124 | (signal-socket-foreign-function-error '%ff-close-socket "closesocket")) 125 | rv)) 126 | 127 | (define-system-call (%ff-bind "bind") (check-socket-zero :int) 128 | (socket socket) 129 | (socket-address :pointer) 130 | (address-length :int)) 131 | 132 | (define-system-call (%ff-listen "listen") (check-socket-zero :int) 133 | (socket socket) 134 | (backlog :int)) 135 | 136 | ;; AcceptEx and GetAcceptExSockaddrs 137 | ;; http://msdn.microsoft.com/en-us/library/windows/desktop/ms738516(v=vs.85).aspx 138 | ;; http://msdn.microsoft.com/en-us/library/windows/desktop/ms737524(v=vs.85).aspx 139 | ;; 140 | ;; See the NOTE paragraphs in the above links. 141 | ;; 142 | ;; Microsoft! OMFG!!! YTF is it this hard?!! This is the last library 143 | ;; I am writing for your platform in my spare time. FormatMessage was 144 | ;; bad enough, now this BS! 145 | 146 | ;; I would like to be able to use this, but you can't. I'll leave it 147 | ;; here as a reminder of what things should have been like. 148 | #- (and) 149 | (define-system-call (%ff-accept-ex "AcceptEx") (check-socket-overlapped bool) 150 | (listen-socket socket) 151 | (accept-socket socket) 152 | (output-buffer (:pointer :uint8)) 153 | (received-data-length dword) 154 | (local-address-length dword) 155 | (remote-address-length dword) 156 | (ptr-bytes-received (:pointer dword)) 157 | (overlapped (:pointer (:struct overlapped)))) 158 | 159 | #- (and) 160 | (cffi:defcfun (%ff-get-accept-ex-sockaddrs "GetAcceptExSockaddrs") :void 161 | (buffer (:pointer :uint8)) 162 | (receive-data-length dword) 163 | (local-address-length dword) 164 | (remote-address-length dword) 165 | (local-sockaddr :pointer) 166 | (local-sockaddr-length dword) 167 | (remote-sockaddr :pointer) 168 | (remote-sockaddr-length dword)) 169 | 170 | (define-system-call (%ff-wsaioctl "WSAIoctl") (check-socket-zero :int) 171 | (socket socket) 172 | (io-control-code io-control-code) 173 | (in-buffer :pointer) 174 | (in-buffer-size dword) 175 | (out-buffer :pointer) 176 | (out-buffer-size dword) 177 | (bytes-returned-pointer (:pointer dword)) 178 | (overlapped (:pointer (:struct overlapped))) 179 | (completion-routine :pointer)) 180 | 181 | (define-system-call (%ff-setsockopt "setsockopt") (check-socket-zero :int) 182 | (socket socket) 183 | (level socket-level) 184 | (option-name socket-option) 185 | (value :pointer) 186 | (option-length :int)) 187 | 188 | (define-system-call (%ff-getpeername "getpeername") (check-socket-zero :int) 189 | (socket socket) 190 | (name :pointer) 191 | (name-length :pointer)) 192 | 193 | (define-system-call (%ff-getsockname "getsockname") (check-socket-zero :int) 194 | (socket socket) 195 | (name :pointer) 196 | (name-length :pointer)) 197 | 198 | ;; Socket number format stuff. I have never understood why the 199 | ;; application writer has to care about this crap. Even posix does it. 200 | (cffi:defcfun (%ff-htons "htons") :unsigned-short 201 | (host-short :unsigned-short)) 202 | 203 | (cffi:defcfun (%ff-ntohs "ntohs") :unsigned-short 204 | (network-short :unsigned-short)) 205 | 206 | (cffi:defcfun (%ff-htonl "htonl") :unsigned-long 207 | (host-long :unsigned-long)) 208 | 209 | (cffi:defcfun (%ff-ntohl "ntohl") :unsigned-long 210 | (network-long :unsigned-long)) 211 | 212 | (cffi:defcfun (%%ff-inet-addr "inet_addr") :unsigned-long 213 | (dotted-decimal :string)) 214 | 215 | (defun %ff-inet-addr (dotted-decimal &optional (error t) error-value) 216 | (let ((rv (%%ff-inet-addr dotted-decimal))) 217 | (cond 218 | ((and error (= rv %+inaddr-none+)) 219 | (error "Cannot convert value ~A to a network long using \"inet_addr\"." dotted-decimal)) 220 | ((= rv %+inaddr-none+) 221 | error-value) 222 | (t 223 | rv)))) 224 | 225 | (assert (= (cffi:foreign-type-size :unsigned-long) 226 | (cffi:foreign-type-size '(:struct in-addr)))) 227 | (cffi:defcfun (%ff-inet-ntoa "inet_ntoa") :string 228 | (in-addr :unsigned-long)) 229 | 230 | ;;;; GETADDRINFO 231 | (cffi:defcfun (%ff-getaddrinfoW "GetAddrInfoW") :int 232 | (host-name (:string :encoding :utf-16)) 233 | (service-name (:string :encoding :utf-16)) 234 | (hints :pointer) 235 | (result :pointer)) 236 | 237 | (cffi:defcfun (%ff-freeaddrinfoW "FreeAddrInfoW") :void 238 | (addr-info (:pointer (:struct addrinfoW)))) 239 | -------------------------------------------------------------------------------- /doc/overlapped-io.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Basic Binary IPC and Overlapped I/O 2 | #+AUTHOR: Mark Cox 3 | 4 | This document contains information about the module used to implement 5 | the Basic Binary IPC interface on Microsoft Windows. 6 | 7 | [TABLE-OF-CONTENTS] 8 | 9 | * Introduction 10 | It is clear that the programming interface defined by the Basic Binary 11 | IPC system is heavily inspired by the asynchronous interfaces found on 12 | Unix systems. The asynchronous I/O interfaces on Unix follow the 13 | pattern where the buffers used for reading and writing are only 14 | required to exist whilst ~read(2)~ and ~write(2)~ are on the call 15 | stack. This implies that the calling application must be notified when 16 | the I/O device is ready to perform I/O. This style of asynchronous I/O 17 | would be implemented in pseudo code as follows 18 | #+begin_src lisp 19 | (wait-until-data-available file-descriptor) 20 | (read file-descriptor buffer) 21 | #+end_src 22 | 23 | Unfortunately, this style is not employed on the Windows operating 24 | system. The pattern employed on Windows is one where the application 25 | queues a read or write operation and is notified when that operation 26 | has been performed. Obviously, this style of asynchronous programming 27 | requires any arguments passed to the request to exist until the 28 | operation is performed. The Windows style of asynchronous I/O would be 29 | implemented in pseudo code as follows 30 | #+begin_src lisp 31 | (let ((op (read-file file-descriptor buffer))) 32 | (wait-until-ready op :indefinite) 33 | (when (bytes-read-p op) 34 | (print (elt (buffer op) 0)))) 35 | #+end_src 36 | 37 | This different approach to the same problem raised questions about how 38 | to implement the ~BASIC-BINARY-IPC~ interface on top of the this style 39 | asynchronous I/O. The ~BASIC-BINARY-IPC.OVERLAPPED-IO~ system is 40 | introduced to begin to bridge the gap between the two styles. This 41 | system provides a direct implementation of the Windows asynchronous 42 | I/O interface without needing to consider the ~BASIC-BINARY-IPC~ 43 | interface. 44 | 45 | This separation also implies that all terms defined in this document 46 | are confined to this document. 47 | 48 | * Overlapped Operations 49 | Windows uses the term overlapped I/O to define their style of 50 | asynchronous I/O. Overlapped I/O involves passing an [[http://msdn.microsoft.com/en-us/library/windows/desktop/ms684342(v=vs.85).aspx][~OVERLAPPED~]] 51 | structure to a function that performs an action associated with 52 | I/O. The list of I/O functions that are needed to implement IPV4 and 53 | named pipe IPC are as follows 54 | 55 | |------------------+--------+--------------------------------------------------| 56 | | Function Name | Input | Output | 57 | |------------------+--------+--------------------------------------------------| 58 | | ReadFile | Buffer | Bytes read and errors. | 59 | | WriteFile | Buffer | Bytes written and errors. | 60 | | ConnectNamedPipe | N/A | N/A | 61 | | AcceptEx | Buffer | Received data, local address and remote address. | 62 | | WSASend | Buffer | Bytes written or errors. | 63 | | WSARecv | Buffer | Bytes read or errors. | 64 | | ConnectEx | Buffer | Bytes written. | 65 | |------------------+--------+--------------------------------------------------| 66 | 67 | The input column refers to the data that must persist for the duration 68 | of the overlapped I/O. The output column represents the data returned 69 | by the overlapped I/O operation upon completion. 70 | 71 | As can be seen, each overlapped I/O operation returns different data, 72 | making it a challenging abstraction. 73 | 74 | To make matters worse, the functions in the table above operate two 75 | ways. According to [[http://msdn.microsoft.com/en-us/library/windows/desktop/aa365683(v=vs.85).aspx][Microsoft documentation]] they can 76 | - return ~FALSE~ (meaning failure) with an error status of 77 | ~ERROR_IO_PENDING~. This states that the application will be 78 | notified when the operation has been performed. 79 | - return ~TRUE~ to indicate that the operation was 80 | successful. i.e. the operation was performed immediately. 81 | 82 | The next section outlines the design of the ~OVERLAPPED-IO~ system to 83 | remove this confusion. 84 | 85 | Details on how an application is notified are omitted from the 86 | section. The sections on [[*Inefficient Polling][inefficient]] and [[*Efficient Polling][efficient]] polling provide 87 | enough details on how to perform this from Lisp applications. 88 | 89 | * Design 90 | The interface presented in this section attempts to provide a uniform 91 | style of starting an overlapped I/O operation on any interprocess 92 | communication stream. 93 | 94 | The first component of the design is that an application issues a 95 | request to the OS to start an I/O operation. All requests to the 96 | operating system are accompanied with an instance of the ~REQUEST~ 97 | class. 98 | 99 | ~REQIEST~ objects are used by the application to obtain information 100 | about the status of the requested I/O operation. ~REQUEST~ objects are 101 | essentially wrappers over the ~OVERLAPPED~ structure mentioned in the 102 | previous section. The reason why the word "request" is used instead of 103 | the word "overlapped" is because "request" is a noun and overlapped is 104 | a verb and therefore not suitable as a /name/ of a class. 105 | 106 | The second component of the design is the removal of support for 107 | synchronous I/O. This simplifies the presentation and implementation. 108 | 109 | The third component is that a single overlapped I/O operation requires 110 | a specific subclass of ~REQUEST~. The reason for this is that all I/O 111 | operations communicate different data. The location of this data is 112 | encapsulated within the specific ~REQUEST~ class. 113 | 114 | New ~REQUEST~ objects are automatically created when issuing a request 115 | to perform an operation. Once performed, the ~REQUEST~ object can be 116 | reused when issuing another request, however, it is not possible to 117 | share a single ~REQUEST~ instance across multiple I/O 118 | operations. 119 | 120 | Lastly, the function ~FREE-REQUEST~ is used to reclaim operating 121 | system resources captured by each ~REQUEST~ instance. 122 | #+begin_src lisp 123 | (defun free-request (overlapped)) 124 | #+end_src 125 | 126 | * Inefficient Polling 127 | The last section detailed how to request an I/O operation. This 128 | section details how to receive notification when the operation has 129 | been completed. 130 | 131 | The lisp function ~WAIT-FOR-REQUESTS~ is used. This function invokes 132 | the foreign function [[http://msdn.microsoft.com/en-us/library/windows/desktop/ms687025(v=vs.85).aspx][~wait\_for\_multiple\_objects~]]. 133 | #+begin_src lisp 134 | (defun wait-for-requests (requests seconds &key wait-all)) 135 | #+end_src 136 | If ~WAIT-ALL~ is non ~NIL~ then calling process blocks until all 137 | overlapped objects in ~REQUESTS~ have been performed/triggered. 138 | 139 | Any subclass of ~REQUEST~ can be used in the sequence of ~REQUESTS~ 140 | argument passed to ~WAIT-FOR-REQUESTS~. 141 | 142 | The return value of ~WAIT-FOR-REQUESTS~ is a list of requests which 143 | are have now been performed. The results for the request can now be 144 | retrieved from the ~REQUEST~ object. 145 | 146 | The function ~WAIT-FOR-REQUEST~ can be used when only a single request 147 | is to be waited on. 148 | #+begin_src lisp 149 | (defun wait-for-request (request seconds)) 150 | #+end_src 151 | 152 | * Efficient Polling 153 | ~WAIT-FOR-REQUESTS~ is considered inefficient as the application must 154 | pass a list of ~REQUEST~ objects to the operating system. The larger 155 | the number of objects, the longer it takes the operating system to 156 | prepare to wait. To overcome this problem, support for [[http://msdn.microsoft.com/en-us/library/aa365198(VS.85).aspx][I/O Completion 157 | Ports]] is provided. 158 | 159 | The interface requires creating an instance of type ~MONITOR~. To 160 | monitor a request using ~MONITOR~ you use the function 161 | ~MONITOR~. 162 | #+begin_src lisp 163 | (defun monitor (monitor request)) 164 | #+end_src 165 | Unmonitoring a request is performed using the function 166 | ~UNMONITOR~. 167 | #+begin_src lisp 168 | (defun unmonitor (monitor request)) 169 | #+end_src 170 | 171 | Notifications are retrieved one at a time using the function 172 | ~POP-NOTIFICATION~. 173 | #+begin_src lisp 174 | (defun pop-notification (monitor wait-seconds)) 175 | #+end_src 176 | The value returned by ~POP-NOTIFICATION~ is the ~REQUEST~ that was 177 | completed. All completed requests are automatically unmonitored. 178 | 179 | When a monitor object is no longer required, the function 180 | ~FREE-MONITOR~ must be used to release all operating system resources 181 | associated with the ~MONITOR~ instance. 182 | #+begin_src lisp 183 | (defun free-monitor (monitor)) 184 | #+end_src 185 | -------------------------------------------------------------------------------- /tests/local.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.TESTS") 2 | 3 | (defun local-socket-pathname () 4 | #-windows 5 | "/tmp/test.socket" 6 | #+windows 7 | "//./pipe/test.socket") 8 | 9 | (define-test make-local-server 10 | (:tag :local-socket) 11 | (let ((server (make-local-server (local-socket-pathname)))) 12 | #-windows 13 | (assert-true (probe-file (local-socket-pathname))) 14 | (unwind-protect 15 | (progn 16 | (assert-true server) 17 | (assert-error 'no-connection-available-error (accept-connection server)) 18 | (assert-error 'socket-error (make-local-server (local-socket-pathname)))) 19 | (close-socket server) 20 | #-windows 21 | (assert-false (probe-file (local-socket-pathname)))))) 22 | 23 | (define-test local-test/sockets 24 | (:tag :local-socket) 25 | (labels ((channel-test (client remote-client) 26 | (assert-true (poll-socket client '(determinedp connection-succeeded-p) 10)) 27 | (assert-true (poll-socket remote-client 'determinedp 10)) 28 | (assert-false (connection-failed-p client)) 29 | (assert-false (connection-failed-p remote-client)) 30 | (assert-true (connection-succeeded-p client)) 31 | (assert-true (connection-succeeded-p remote-client))) 32 | (establish-channel (server client) 33 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 34 | (let ((remote-client (accept-connection server))) 35 | (assert-true (typep server 'stream-server)) 36 | (assert-true (typep client 'stream-socket)) 37 | (assert-true (typep remote-client 'stream-socket)) 38 | (unwind-protect 39 | (channel-test client remote-client) 40 | (close-socket remote-client))))) 41 | (let ((server (make-local-server (local-socket-pathname)))) 42 | (unwind-protect 43 | (progn 44 | (assert-false (poll-socket server 'connection-available-p 0)) 45 | (let ((client (connect-to-local-server (local-socket-pathname)))) 46 | (unwind-protect 47 | (establish-channel server client) 48 | (close-socket client)))) 49 | (close-socket server))))) 50 | 51 | (define-test local-test/stream 52 | (:tag :local-socket) 53 | (labels ((channel-test (client remote-client) 54 | (assert-true (poll-socket client 'ready-to-write-p 0)) 55 | (assert-false (poll-socket remote-client 'data-available-p 0)) 56 | 57 | (let ((buffer (make-array 10 :element-type '(unsigned-byte 8)))) 58 | (dotimes (i (length buffer)) 59 | (setf (elt buffer i) i)) 60 | 61 | (assert-error 'error (write-to-stream client buffer :start -1)) 62 | (assert-error 'error (write-to-stream client buffer :end -1)) 63 | (assert-error 'error (write-to-stream client buffer :start 3 :end 1)) 64 | (assert-error 'error (write-to-stream client buffer :start 3 :end 11)) 65 | 66 | (assert-equal 2 (write-to-stream client buffer :start 3 :end 5)) 67 | (assert-true (poll-socket remote-client 'data-available-p 10)) 68 | 69 | (assert-error 'error (read-from-stream remote-client buffer :start -1)) 70 | (assert-error 'error (read-from-stream remote-client buffer :end -1)) 71 | (assert-error 'error (read-from-stream remote-client buffer :start 3 :end 1)) 72 | (assert-error 'error (read-from-stream remote-client buffer :start 3 :end 11)) 73 | 74 | (assert-equal 2 (read-from-stream remote-client buffer :start 7 :end 10)) 75 | (dotimes (i 7) 76 | (assert-equal i (elt buffer i))) 77 | (assert-equal 3 (elt buffer 7)) 78 | (assert-equal 4 (elt buffer 8)) 79 | (assert-equal 9 (elt buffer 9)) 80 | 81 | (assert-false (data-available-p remote-client)) 82 | (assert-true (ready-to-write-p client)))) 83 | (establish-channel (server client) 84 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 85 | (let ((remote-client (accept-connection server))) 86 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 87 | (assert-true (poll-socket remote-client 'connection-succeeded-p 10)) 88 | (unwind-protect 89 | (channel-test client remote-client) 90 | (close-socket remote-client))))) 91 | (let ((server (make-local-server (local-socket-pathname)))) 92 | (assert-false (poll-socket server 'connection-available-p 0)) 93 | (unwind-protect 94 | (let ((client (connect-to-local-server (local-socket-pathname)))) 95 | (unwind-protect 96 | (establish-channel server client) 97 | (close-socket client))) 98 | (close-socket server))))) 99 | 100 | (define-test local-test/remote-disconnected 101 | (:tag :local-socket) 102 | (labels ((channel-test (client remote-client) 103 | (assert-true (poll-socket client 'ready-to-write-p 0)) 104 | (assert-false (poll-socket remote-client 'data-available-p 0)) 105 | 106 | (close-socket remote-client) 107 | 108 | (assert-false (poll-socket client 'connection-succeeded-p 10)) 109 | (assert-true (poll-socket client 'remote-disconnected-p 10)) 110 | (assert-false (poll-socket client 'ready-to-write-p 0)) 111 | (assert-false (poll-socket client 'data-available-p 0))) 112 | (establish-channel (server client) 113 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 114 | (let ((remote-client (accept-connection server))) 115 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 116 | (assert-true (poll-socket remote-client 'connection-succeeded-p 10)) 117 | 118 | (channel-test client remote-client)))) 119 | (let ((server (make-local-server (local-socket-pathname)))) 120 | (assert-false (poll-socket server 'connection-available-p 0)) 121 | (unwind-protect 122 | (let ((client (connect-to-local-server (local-socket-pathname)))) 123 | (unwind-protect 124 | (establish-channel server client) 125 | (close-socket client))) 126 | (close-socket server))))) 127 | 128 | (define-test connect-to-local-server/does-not-exist 129 | (:tag :local-socket) 130 | (assert-error 'no-local-server-error (connect-to-local-server (local-socket-pathname)))) 131 | 132 | (define-test local-test/pathname 133 | (:tag :local-socket) 134 | (labels ((perform-test (server client remote-client) 135 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 136 | (assert-true (pathname-match-p (local-pathname server) 137 | (local-pathname client))) 138 | (assert-true (pathname-match-p (local-pathname server) 139 | (local-pathname remote-client)))) 140 | (establish-channel (server client) 141 | (assert-true (poll-socket server 'connection-available-p 10)) 142 | (let ((remote-client (accept-connection server))) 143 | (unwind-protect 144 | (perform-test server client remote-client) 145 | (close-socket remote-client))))) 146 | (let ((server (make-local-server (local-socket-pathname)))) 147 | (unwind-protect 148 | (progn 149 | (assert-false (poll-socket server 'connection-available-p 0)) 150 | (let ((client (connect-to-local-server (local-socket-pathname)))) 151 | (unwind-protect 152 | (establish-channel server client) 153 | (close-socket client)))) 154 | (close-socket server))))) 155 | 156 | (define-test local-test/no-data 157 | (:tag :local-socket) 158 | (labels ((channel-test (client remote-client) 159 | (let ((buffer (make-array 10 :element-type '(unsigned-byte 8)))) 160 | (assert-equal 0 (read-from-stream client buffer)) 161 | (assert-equal 0 (read-from-stream remote-client buffer)))) 162 | (establish-channel (server client) 163 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 164 | (let ((remote-client (accept-connection server))) 165 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 166 | (assert-true (poll-socket remote-client 'connection-succeeded-p 10)) 167 | (unwind-protect 168 | (channel-test client remote-client) 169 | (close-socket remote-client))))) 170 | (let ((server (make-local-server (local-socket-pathname)))) 171 | (assert-false (poll-socket server 'connection-available-p 0)) 172 | (unwind-protect 173 | (let ((client (connect-to-local-server (local-socket-pathname)))) 174 | (unwind-protect 175 | (establish-channel server client) 176 | (close-socket client))) 177 | (close-socket server))))) 178 | 179 | #-windows 180 | (define-test local-test/full-write-buffer 181 | (:tag :local-socket) 182 | (labels ((channel-test (client remote-client) 183 | (declare (ignore remote-client)) 184 | (let ((buffer (make-array 100000 :element-type '(unsigned-byte 8))) 185 | (write-buffer-full nil)) 186 | (loop 187 | :for attempt :from 0 :below 1000 188 | :until write-buffer-full 189 | :do 190 | (when (zerop (write-to-stream client buffer)) 191 | (setf write-buffer-full t))) 192 | (assert-true write-buffer-full))) 193 | (establish-channel (server client) 194 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 195 | (let ((remote-client (accept-connection server))) 196 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 197 | (assert-true (poll-socket remote-client 'connection-succeeded-p 10)) 198 | (unwind-protect 199 | (channel-test client remote-client) 200 | (close-socket remote-client))))) 201 | (let ((server (make-local-server (local-socket-pathname)))) 202 | (assert-false (poll-socket server 'connection-available-p 0)) 203 | (unwind-protect 204 | (let ((client (connect-to-local-server (local-socket-pathname)))) 205 | (unwind-protect 206 | (establish-channel server client) 207 | (close-socket client))) 208 | (close-socket server))))) 209 | -------------------------------------------------------------------------------- /src/overlapped-io-grovel.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.OVERLAPPED-IO") 2 | 3 | (include "Winsock2.h") 4 | (include "mswsock.h") 5 | (include "Windows.h") 6 | 7 | ;; Shared CTypes 8 | (ctype word "WORD") 9 | (ctype dword "DWORD") ;; Should be an unsigned 32 bit integer. 10 | (ctype handle "HANDLE") 11 | (ctype bool "BOOL") 12 | 13 | #- (and) 14 | (cstruct guid "GUID" 15 | (data1 "Data1" :type dword) 16 | (data2 "Data2" :type word) 17 | (data3 "Data3" :type word) 18 | (data4 "Data4" :type :uint8 :count 8)) 19 | 20 | ;; Constants 21 | (constant (+true+ "TRUE")) 22 | (constant (+false+ "FALSE")) 23 | (constant (+invalid-handle-value+ "INVALID_HANDLE_VALUE")) 24 | (constant (+null+ "NULL")) 25 | (constant (+infinite+ "INFINITE")) 26 | (constant (+maximum-wait-objects+ "MAXIMUM_WAIT_OBJECTS")) 27 | (constant (+invalid-socket+ "INVALID_SOCKET")) 28 | 29 | ;; The constant WSA_GETACCEPTSOCKADDRS is a macro which represents a 30 | ;; GUID. Unfortunately grovelling for it is a waste of time. 31 | ;; The constant is defined inline. 32 | ;;(constant (+wsaid-getacceptxsockaddrs+ "WSA_GETACCEPTSOCKADDRS") :type guid) 33 | 34 | ;; Overlapped 35 | (cstruct overlapped "struct _OVERLAPPED" 36 | (h-event "hEvent" :type handle)) 37 | 38 | ;; WaitForSingleObject 39 | (constantenum (wait :base-type :unsigned-int) 40 | ((:wait-abandoned "WAIT_ABANDONED")) 41 | ((:wait-object-0 "WAIT_OBJECT_0")) 42 | ((:wait-timeout "WAIT_TIMEOUT")) 43 | ((:wait-failed "WAIT_FAILED"))) 44 | 45 | ;;;; Named Pipes 46 | (constant (+pipe-unlimited-instances+ "PIPE_UNLIMITED_INSTANCES")) 47 | 48 | (bitfield (named-pipe-open-mode :base-type :unsigned-int) 49 | ((:pipe-access-duplex "PIPE_ACCESS_DUPLEX")) 50 | ((:file-flag-first-pipe-instance "FILE_FLAG_FIRST_PIPE_INSTANCE")) 51 | ((:file-flag-overlapped "FILE_FLAG_OVERLAPPED"))) 52 | 53 | (bitfield (named-pipe-mode :base-type :unsigned-int) 54 | ((:pipe-type-byte "PIPE_TYPE_BYTE")) 55 | ((:pipe-readmode-byte "PIPE_READMODE_BYTE"))) 56 | 57 | (bitfield (file-desired-access :base-type :unsigned-int) 58 | ((:generic-read "GENERIC_READ")) 59 | ((:generic-write "GENERIC_WRITE"))) 60 | 61 | (bitfield (file-share-mode :base-type :unsigned-int) 62 | ((:file-share-delete "FILE_SHARE_DELETE")) 63 | ((:file-share-read "FILE_SHARE_READ")) 64 | ((:file-share-write "FILE_SHARE_WRITE"))) 65 | 66 | (constantenum (file-creation-disposition :base-type :unsigned-int) 67 | ((:create-always "CREATE_ALWAYS")) 68 | ((:create-new "CREATE_NEW")) 69 | ((:open-always "OPEN_ALWAYS")) 70 | ((:open-existing "OPEN_EXISTING")) 71 | ((:truncate-existing "TRUNCATE_EXISTING"))) 72 | 73 | (bitfield (file-attribute :base-type :unsigned-int) 74 | ((:file-flag-overlapped "FILE_FLAG_OVERLAPPED"))) 75 | 76 | ;;;; Sockets 77 | (ctype socket "SOCKET") 78 | (ctype socket-group "GROUP") 79 | 80 | (constant (%+inaddr-none+ "INADDR_NONE")) 81 | (constant (%+inaddr-any+ "INADDR_ANY")) 82 | (constant (%+inaddr-loopback+ "INADDR_LOOPBACK")) 83 | 84 | (constantenum (socket-address-family :base-type :int) 85 | ((:af-inet "AF_INET"))) 86 | 87 | (constantenum (socket-type :base-type :int) 88 | ((:sock-stream "SOCK_STREAM"))) 89 | 90 | (constantenum (socket-protocol :base-type :int) 91 | ((:ipproto-tcp "IPPROTO_TCP"))) 92 | 93 | (constantenum (socket-flags :base-type :unsigned-int) 94 | ((:wsa-flag-overlapped "WSA_FLAG_OVERLAPPED"))) 95 | 96 | (cstruct in-addr "struct in_addr" 97 | (s-addr "S_un.S_addr" :type :unsigned-long)) 98 | 99 | (cstruct sockaddr-in "struct sockaddr_in" 100 | (sin-family "sin_family" :type :unsigned-short) 101 | (sin-port "sin_port" :type :unsigned-short) 102 | (in-addr "sin_addr" :type (:struct in-addr))) 103 | 104 | (constantenum (io-control-code :base-type :unsigned-int) 105 | ((:sio-get-extension-function-pointer "SIO_GET_EXTENSION_FUNCTION_POINTER"))) 106 | 107 | (constantenum (socket-level :base-type :int) 108 | ((:sol-socket "SOL_SOCKET"))) 109 | 110 | (constantenum (socket-option :base-type :int) 111 | ((:so-update-accept-context "SO_UPDATE_ACCEPT_CONTEXT")) 112 | ((:so-update-connect-context "SO_UPDATE_CONNECT_CONTEXT"))) 113 | 114 | ;;;; ERRORS 115 | ;; Winsock Errors 116 | ;; These constants are found in 117 | ;; - ( x86_64 ) mingw64/x86_64-w64-mingw32/include/winsock2.h 118 | ;; - ( x86 ) MinGW/include/winsock2.h 119 | (constantenum (winsock-error-codes :base-type :unsigned-int) 120 | ((:error-success "ERROR_SUCCESS")) 121 | ((:no-error "NO_ERROR")) 122 | ((:wsa-invalid-handle "WSA_INVALID_HANDLE")) 123 | ((:wsa-not-enough-memory "WSA_NOT_ENOUGH_MEMORY")) 124 | ((:wsa-invalid-parameter "WSA_INVALID_PARAMETER")) 125 | ((:wsa-operation-aborted "WSA_OPERATION_ABORTED")) 126 | ((:wsa-io-incomplete "WSA_IO_INCOMPLETE")) 127 | ((:wsa-io-pending "WSA_IO_PENDING")) 128 | ((:wsaeintr "WSAEINTR")) 129 | ((:wsaebadf "WSAEBADF")) 130 | ((:wsaeacces "WSAEACCES")) 131 | ((:wsaefault "WSAEFAULT")) 132 | ((:wsaeinval "WSAEINVAL")) 133 | ((:wsaemfile "WSAEMFILE")) 134 | ((:wsaewouldblock "WSAEWOULDBLOCK")) 135 | ((:wsaeinprogress "WSAEINPROGRESS")) 136 | ((:wsaealready "WSAEALREADY")) 137 | ((:wsaenotsock "WSAENOTSOCK")) 138 | ((:wsaedestaddrreq "WSAEDESTADDRREQ")) 139 | ((:wsaemsgsize "WSAEMSGSIZE")) 140 | ((:wsaeprototype "WSAEPROTOTYPE")) 141 | ((:wsaenoprotoopt "WSAENOPROTOOPT")) 142 | ((:wsaeprotonosupport "WSAEPROTONOSUPPORT")) 143 | ((:wsaesocktnosupport "WSAESOCKTNOSUPPORT")) 144 | ((:wsaeopnotsupp "WSAEOPNOTSUPP")) 145 | ((:wsaepfnosupport "WSAEPFNOSUPPORT")) 146 | ((:wsaeafnosupport "WSAEAFNOSUPPORT")) 147 | ((:wsaeaddrinuse "WSAEADDRINUSE")) 148 | ((:wsaeaddrnotavail "WSAEADDRNOTAVAIL")) 149 | ((:wsaenetdown "WSAENETDOWN")) 150 | ((:wsaenetunreach "WSAENETUNREACH")) 151 | ((:wsaenetreset "WSAENETRESET")) 152 | ((:wsaeconnaborted "WSAECONNABORTED")) 153 | ((:wsaeconnreset "WSAECONNRESET")) 154 | ((:wsaenobufs "WSAENOBUFS")) 155 | ((:wsaeisconn "WSAEISCONN")) 156 | ((:wsaenotconn "WSAENOTCONN")) 157 | ((:wsaeshutdown "WSAESHUTDOWN")) 158 | ((:wsaetoomanyrefs "WSAETOOMANYREFS")) 159 | ((:wsaetimedout "WSAETIMEDOUT")) 160 | ((:wsaeconnrefused "WSAECONNREFUSED")) 161 | ((:wsaeloop "WSAELOOP")) 162 | ((:wsaenametoolong "WSAENAMETOOLONG")) 163 | ((:wsaehostdown "WSAEHOSTDOWN")) 164 | ((:wsaehostunreach "WSAEHOSTUNREACH")) 165 | ((:wsaenotempty "WSAENOTEMPTY")) 166 | ((:wsaeproclim "WSAEPROCLIM")) 167 | ((:wsaeusers "WSAEUSERS")) 168 | ((:wsaedquot "WSAEDQUOT")) 169 | ((:wsaestale "WSAESTALE")) 170 | ((:wsaeremote "WSAEREMOTE")) 171 | ((:wsasysnotready "WSASYSNOTREADY")) 172 | ((:wsavernotsupported "WSAVERNOTSUPPORTED")) 173 | ((:wsanotinitialised "WSANOTINITIALISED")) 174 | ((:wsaediscon "WSAEDISCON")) 175 | ((:wsaenomore "WSAENOMORE")) 176 | ((:wsaecancelled "WSAECANCELLED")) 177 | ((:wsaeinvalidproctable "WSAEINVALIDPROCTABLE")) 178 | ((:wsaeinvalidprovider "WSAEINVALIDPROVIDER")) 179 | ((:wsaeproviderfailedinit "WSAEPROVIDERFAILEDINIT")) 180 | ((:wsasyscallfailure "WSASYSCALLFAILURE")) 181 | ((:wsaservice-not-found "WSASERVICE_NOT_FOUND")) 182 | ((:wsatype-not-found "WSATYPE_NOT_FOUND")) 183 | ((:wsa-e-no-more "WSA_E_NO_MORE")) 184 | ((:wsa-e-cancelled "WSA_E_CANCELLED")) 185 | ((:wsaerefused "WSAEREFUSED")) 186 | ((:wsahost-not-found "WSAHOST_NOT_FOUND")) 187 | ((:wsatry-again "WSATRY_AGAIN")) 188 | ((:wsano-recovery "WSANO_RECOVERY")) 189 | ((:wsano-data "WSANO_DATA"))) 190 | 191 | ;;;; Errors 192 | ;; Have a look in the following files to find these constants: 193 | ;; - ( x86_64 ) mingw64/x86_64-w64-mingw32/include/winerror.h 194 | ;; - ( x86 ) MinGW/include/winerror.h 195 | (constantenum (error-codes :base-type :unsigned-int) 196 | ((:error-success "ERROR_SUCCESS")) 197 | ((:no-error "NO_ERROR")) 198 | ((:error-invalid-handle "ERROR_INVALID_HANDLE")) 199 | ((:error-access-denied "ERROR_ACCESS_DENIED")) 200 | ((:error-invalid-user-buffer "ERROR_INVALID_USER_BUFFER")) 201 | ((:error-not-enough-memory "ERROR_NOT_ENOUGH_MEMORY")) 202 | ((:error-operation-aborted "ERROR_OPERATION_ABORTED")) 203 | ((:error-not-enough-quota "ERROR_NOT_ENOUGH_QUOTA")) 204 | ((:error-insufficient-buffer "ERROR_INSUFFICIENT_BUFFER")) 205 | ((:error-io-incomplete "ERROR_IO_INCOMPLETE")) 206 | ((:error-io-pending "ERROR_IO_PENDING")) 207 | ((:error-handle-eof "ERROR_HANDLE_EOF")) 208 | ((:error-broken-pipe "ERROR_BROKEN_PIPE")) 209 | ((:error-more-data "ERROR_MORE_DATA")) 210 | ((:error-file-not-found "ERROR_FILE_NOT_FOUND")) 211 | ((:error-pipe-connected "ERROR_PIPE_CONNECTED")) 212 | ((:error-pipe-listening "ERROR_PIPE_LISTENING")) 213 | ((:error-pipe-busy "ERROR_PIPE_BUSY")) 214 | ((:error-pipe-not-connected "ERROR_PIPE_NOT_CONNECTED")) 215 | ((:error-connection-refused "ERROR_CONNECTION_REFUSED")) 216 | ((:error-sem-timeout "ERROR_SEM_TIMEOUT")) 217 | ((:error-unexp-net-err "ERROR_UNEXP_NET_ERR")) 218 | ((:error-netname-deleted "ERROR_NETNAME_DELETED")) 219 | ((:wait-timeout "WAIT_TIMEOUT"))) 220 | 221 | ;;;; Bloody FormatMessage crap. What a joke. 222 | (ctype lpcvoid "LPCVOID") 223 | (ctype lptstr "LPTSTR") 224 | (ctype tchar "TCHAR") 225 | (bitfield (format-message-flags :base-type :uint32) 226 | ((:format-message-allocate-buffer "FORMAT_MESSAGE_ALLOCATE_BUFFER")) 227 | ((:format-message-argument-array "FORMAT_MESSAGE_ARGUMENT_ARRAY")) 228 | ((:format-message-from-hmodule "FORMAT_MESSAGE_FROM_HMODULE")) 229 | ((:format-message-from-string "FORMAT_MESSAGE_FROM_STRING")) 230 | ((:format-message-from-system "FORMAT_MESSAGE_FROM_SYSTEM")) 231 | ((:format-message-ignore-inserts "FORMAT_MESSAGE_IGNORE_INSERTS"))) 232 | 233 | ;;;; GetAddrInfoW Stuff 234 | (include "Ws2tcpip.h") 235 | (ctype size-t "size_t") 236 | (constantenum (addrinfoW-flags :base-type :int) 237 | ((:ai-passive "AI_PASSIVE"))) 238 | 239 | (constantenum (addrinfoW-error-codes :base-type :int) 240 | ((:eai-again "EAI_AGAIN")) 241 | ((:eai-badflags "EAI_BADFLAGS")) 242 | ((:eai-fail "EAI_FAIL")) 243 | ((:eai-family "EAI_FAMILY")) 244 | ((:eai-memory "EAI_MEMORY")) 245 | ((:eai-noname "EAI_NONAME")) 246 | ((:eai-service "EAI_SERVICE")) 247 | ((:eai-socktype "EAI_SOCKTYPE"))) 248 | 249 | (cstruct addrinfoW "struct addrinfoW" 250 | (ai-flags "ai_flags" :type addrinfoW-flags) 251 | (ai-family "ai_family" :type socket-address-family) 252 | (ai-socktype "ai_socktype" :type socket-type) 253 | (ai-protocol "ai_protocol" :type socket-protocol) 254 | (ai-addrlen "ai_addrlen" :type size-t) 255 | (ai-canonname "ai_canonname" :type (:string :encoding :utf-16)) 256 | (ai-addr "ai_addr" :type :pointer) 257 | (ai-next "ai_next" :type :pointer)) 258 | -------------------------------------------------------------------------------- /tests/ipv4.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.TESTS") 2 | 3 | (defvar *used-server-ports* nil 4 | "A list of all server ports returned by RANDOM-SERVER-PORT.") 5 | 6 | (defvar +ipv4-address-with-no-server+ "169.254.0.1") 7 | 8 | (defun random-server-port () 9 | (let ((port (loop 10 | :for port := (+ 30000 (random 10000)) 11 | :while (find port *used-server-ports* :test #'=) 12 | :finally (return port)))) 13 | (push port *used-server-ports*) 14 | port)) 15 | 16 | (define-test make-ipv4-tcp-server 17 | (:tag :ipv4-tcp-socket) 18 | (let* ((port (random-server-port)) 19 | (server (make-ipv4-tcp-server +ipv4-loopback+ port))) 20 | (unwind-protect 21 | (progn 22 | (assert-true server) 23 | (assert-error 'no-connection-available-error (accept-connection server)) 24 | (assert-error 'socket-error (make-ipv4-tcp-server +ipv4-loopback+ port))) 25 | (close-socket server)))) 26 | 27 | (define-test ipv4-tcp-test/sockets 28 | (:tag :ipv4-tcp-socket) 29 | (labels ((channel-test (client remote-client) 30 | (assert-true (poll-socket client '(determinedp connection-succeeded-p) 10)) 31 | (assert-true (poll-socket remote-client 'determinedp 10)) 32 | (assert-false (connection-failed-p client)) 33 | (assert-false (connection-failed-p remote-client)) 34 | (assert-true (connection-succeeded-p client)) 35 | (assert-true (connection-succeeded-p remote-client))) 36 | (establish-channel (server client) 37 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 38 | (let ((remote-client (accept-connection server))) 39 | (assert-true (typep server 'stream-server)) 40 | (assert-true (typep client 'stream-socket)) 41 | (assert-true (typep remote-client 'stream-socket)) 42 | (unwind-protect 43 | (channel-test client remote-client) 44 | (close-socket remote-client))))) 45 | (let ((server (make-ipv4-tcp-server +ipv4-loopback+ (random-server-port)))) 46 | (assert-false (poll-socket server 'connection-available-p 0)) 47 | (unwind-protect 48 | (let ((client (connect-to-ipv4-tcp-server +ipv4-loopback+ (port server)))) 49 | (unwind-protect 50 | (establish-channel server client) 51 | (close-socket client))) 52 | (close-socket server))))) 53 | 54 | (define-test ipv4-tcp-test/stream 55 | (:tag :ipv4-tcp-socket) 56 | (labels ((channel-test (client remote-client) 57 | (assert-true (poll-socket client 'ready-to-write-p 0)) 58 | (assert-false (poll-socket remote-client 'data-available-p 0)) 59 | 60 | (let ((buffer (make-array 10 :element-type '(unsigned-byte 8)))) 61 | (dotimes (i (length buffer)) 62 | (setf (elt buffer i) i)) 63 | (assert-error 'error (write-to-stream client buffer :start -1)) 64 | (assert-error 'error (write-to-stream client buffer :end -1)) 65 | (assert-error 'error (write-to-stream client buffer :start 3 :end 1)) 66 | (assert-error 'error (write-to-stream client buffer :start 3 :end 11)) 67 | 68 | (assert-equal 2 (write-to-stream client buffer :start 3 :end 5)) 69 | (assert-true (poll-socket remote-client 'data-available-p 10)) 70 | 71 | (assert-error 'error (read-from-stream remote-client buffer :start -1)) 72 | (assert-error 'error (read-from-stream remote-client buffer :end -1)) 73 | (assert-error 'error (read-from-stream remote-client buffer :start 3 :end 1)) 74 | (assert-error 'error (read-from-stream remote-client buffer :start 3 :end 11)) 75 | 76 | (assert-equal 2 (read-from-stream remote-client buffer :start 7 :end 10)) 77 | (dotimes (i 7) 78 | (assert-equal i (elt buffer i))) 79 | (assert-equal 3 (elt buffer 7)) 80 | (assert-equal 4 (elt buffer 8)) 81 | (assert-equal 9 (elt buffer 9)) 82 | 83 | (assert-false (data-available-p remote-client)) 84 | (assert-true (ready-to-write-p client)))) 85 | (establish-channel (server client) 86 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 87 | (let ((remote-client (accept-connection server))) 88 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 89 | (assert-true (poll-socket remote-client 'connection-succeeded-p 10)) 90 | (unwind-protect 91 | (channel-test client remote-client) 92 | (close-socket remote-client))))) 93 | (let ((server (make-ipv4-tcp-server +ipv4-loopback+ (random-server-port)))) 94 | (assert-false (poll-socket server 'connection-available-p 0)) 95 | (unwind-protect 96 | (let ((client (connect-to-ipv4-tcp-server +ipv4-loopback+ (port server)))) 97 | (unwind-protect 98 | (establish-channel server client) 99 | (close-socket client))) 100 | (close-socket server))))) 101 | 102 | (define-test ipv4-tcp-test/remote-disconnected 103 | (:tag :ipv4-tcp-socket) 104 | (labels ((channel-test (client remote-client) 105 | (assert-true (poll-socket client 'ready-to-write-p 0)) 106 | (assert-false (poll-socket remote-client 'data-available-p 0)) 107 | 108 | (close-socket remote-client) 109 | (assert-error 'error (poll-socket remote-client 'ready-to-write-p 10)) 110 | 111 | (assert-false (poll-socket client 'connection-succeeded-p 10)) 112 | (assert-true (poll-socket client 'remote-disconnected-p 10)) 113 | (assert-false (poll-socket client 'ready-to-write-p 0)) 114 | (assert-false (poll-socket client 'data-available-p 0))) 115 | (establish-channel (server client) 116 | (assert-equal 'connection-available-p (poll-socket server 'connection-available-p 10)) 117 | (let ((remote-client (accept-connection server))) 118 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 119 | (assert-true (poll-socket remote-client 'connection-succeeded-p 10)) 120 | 121 | (channel-test client remote-client)))) 122 | (let ((server (make-ipv4-tcp-server +ipv4-loopback+ (random-server-port)))) 123 | (assert-false (poll-socket server 'connection-available-p 0)) 124 | (unwind-protect 125 | (let ((client (connect-to-ipv4-tcp-server +ipv4-loopback+ (port server)))) 126 | (unwind-protect 127 | (establish-channel server client) 128 | (close-socket client))) 129 | (close-socket server))))) 130 | 131 | (define-test connect-to-ipv4-server/does-not-exist 132 | (:tag :ipv4-tcp-socket) 133 | (labels ((perform-test (client) 134 | (format *standard-output* "~&; This test pauses for a maximum of 2 minutes, do not panic.~%") 135 | (let ((results (poll-socket client '(determinedp connection-failed-p connection-succeeded-p) 120))) 136 | (assert-equal 2 (length results)) 137 | (assert-true (find 'determinedp results)) 138 | (assert-true (find 'connection-failed-p results)) 139 | (assert-false (find 'connection-succeeded-p results))) 140 | (assert-true (connection-failed-p client)))) 141 | (let ((client (connect-to-ipv4-tcp-server +ipv4-address-with-no-server+ (random-server-port)))) 142 | (unwind-protect 143 | (perform-test client) 144 | (close-socket client))))) 145 | 146 | (define-test connect-to-ipv4-server/does-not-exist/loopback 147 | (:tag :ipv4-tcp-socket) 148 | (labels ((perform-test (client) 149 | (assert-true (typep client 'stream-socket)) 150 | (format *standard-output* "~&; This test pauses for a maximum of 2 minutes, do not panic.~%") 151 | (let ((results (poll-socket client '(determinedp connection-failed-p connection-succeeded-p) 120))) 152 | (assert-equal 2 (length results)) 153 | (assert-true (find 'determinedp results)) 154 | (assert-true (find 'connection-failed-p results)) 155 | (assert-false (find 'connection-succeeded-p results))) 156 | (assert-true (connection-failed-p client)))) 157 | (let ((client (connect-to-ipv4-tcp-server +ipv4-loopback+ (random-server-port)))) 158 | (unwind-protect 159 | (perform-test client) 160 | (close-socket client))))) 161 | 162 | (define-test ipv4-tcp-test/host-address-and-ports 163 | (:tag :ipv4-tcp-socket) 164 | (let ((client-port (random-server-port)) 165 | (server-port (random-server-port))) 166 | (labels ((establish-channel (server client) 167 | (assert-true (poll-socket server 'connection-available-p 10)) 168 | (let ((remote-client (accept-connection server))) 169 | (assert-true (poll-socket remote-client 'connection-succeeded-p 10)) 170 | (assert-true (poll-socket client 'connection-succeeded-p 10)) 171 | 172 | ;; remote client tests 173 | (assert-equal server-port (local-port remote-client)) 174 | (assert-equal +ipv4-loopback+ (local-host-address remote-client)) 175 | (assert-equal client-port (remote-port remote-client)) 176 | (assert-equal +ipv4-loopback+ (remote-host-address remote-client)) 177 | 178 | ;; client tests 179 | (assert-equal client-port (local-port client)) 180 | (assert-equal +ipv4-loopback+ (local-host-address client)) 181 | (assert-equal server-port (remote-port client)) 182 | (assert-equal +ipv4-loopback+ (remote-host-address client))))) 183 | (let ((server (make-ipv4-tcp-server +ipv4-loopback+ server-port))) 184 | (assert-false (poll-socket server 'connection-available-p 0)) 185 | (unwind-protect 186 | (let ((client (connect-to-ipv4-tcp-server +ipv4-loopback+ (port server) :local-port client-port))) 187 | (unwind-protect 188 | (establish-channel server client) 189 | (close-socket client))) 190 | (close-socket server)))))) 191 | 192 | (define-test ipv4-tcp-test/server-port-zero 193 | (:tag :ipv4-tcp-socket) 194 | (with-socket (server (make-ipv4-tcp-server +ipv4-loopback+ 0)) 195 | (assert-false (poll-socket server 'connection-available-p 0)) 196 | (assert-false (zerop (port server))) 197 | (assert-equal +ipv4-loopback+ (host-address server)) 198 | (with-socket (client (connect-to-ipv4-tcp-server +ipv4-loopback+ (port server))) 199 | (assert-true (poll-socket server 'connection-available-p 10)) 200 | (with-socket (remote-client (accept-connection server)) 201 | (assert-true (poll-socket client 'connection-succeeded-p 0)) 202 | (assert-true (poll-socket remote-client 'connection-succeeded-p 0)))))) 203 | 204 | (define-test resolve-ipv4-address 205 | (:tag :resolve-ipv4-address) 206 | (assert-true (member (resolve-ipv4-address "example.com") 207 | '("93.184.216.119" 208 | "93.184.216.34") 209 | :test #'string=)) 210 | (assert-false (resolve-ipv4-address "example12341.com"))) 211 | -------------------------------------------------------------------------------- /src/epoll-poller.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (defgeneric epoll-descriptor (object) 4 | (:documentation "The descriptor for the EPOLL object.")) 5 | 6 | (defgeneric monitor-table (object) 7 | (:documentation "A table mapping sockets to epoll poller specific information.")) 8 | 9 | (defgeneric descriptor-socket-table (object) 10 | (:documentation "A table mapping file descriptors to socket objects.")) 11 | 12 | (defgeneric maximum-number-of-events (object) 13 | (:documentation "The maximum number of events to retrieve when 14 | invoking epoll_wait.")) 15 | 16 | (defclass epoll-poller (poller) 17 | ((epoll-descriptor 18 | :initarg :epoll-descriptor 19 | :reader epoll-descriptor) 20 | (closedp 21 | :initarg :closedp 22 | :accessor closedp) 23 | (monitor-table 24 | :initarg :monitor-table 25 | :reader monitor-table) 26 | (descriptor-socket-table 27 | :initarg :descriptor-socket-table 28 | :reader descriptor-socket-table) 29 | (maximum-number-of-events 30 | :initarg :maximum-number-of-events 31 | :reader maximum-number-of-events)) 32 | (:default-initargs 33 | :closedp nil 34 | :maximum-number-of-events 100 35 | :monitor-table (make-hash-table) 36 | :descriptor-socket-table (make-hash-table))) 37 | 38 | (defun make-poller () 39 | (let ((epfd (%ff-epoll-create 1))) 40 | ;; 1 is the size argument. From the NOTES section in 41 | ;; epoll_create(2). 42 | ;; 43 | ;; In the initial epoll_create() implementation, the size 44 | ;; argument informed the kernel of the number of file 45 | ;; descriptors that the caller expected to add to the epoll 46 | ;; instance. The kernel used this information as a hint for the 47 | ;; amount of space to initially allocate in internal data 48 | ;; structures describing events. .... Nowadays, this hint is no 49 | ;; longer required, ...., but size must still be greater than 50 | ;; zero, in order to ensure backward compatibility when new 51 | ;; epoll applications are run on older kernels. 52 | 53 | (make-instance 'epoll-poller 54 | :epoll-descriptor epfd))) 55 | 56 | (defmethod close-poller ((poller epoll-poller)) 57 | (unless (closedp poller) 58 | (%ff-close (epoll-descriptor poller)) 59 | (setf (closedp poller) t))) 60 | 61 | (defmethod wait-for-events ((poller epoll-poller) timeout) 62 | (assert (typep timeout '(or (member :indefinite :immediate) (real 0)))) 63 | (with-accessors ((epfd epoll-descriptor) 64 | (maximum-number-of-events maximum-number-of-events)) 65 | poller 66 | (cffi:with-foreign-objects ((events '(:struct epoll-event) maximum-number-of-events)) 67 | (handler-case (%ff-epoll-wait epfd events maximum-number-of-events 68 | (cond 69 | ((eql timeout :immediate) 70 | 0) 71 | ((eql timeout :indefinite) 72 | -1) 73 | (t 74 | (* timeout 1000)))) 75 | (posix-error (c) 76 | (unless (posix-error-interrupted-p c) 77 | (error c))) 78 | (:no-error (number-of-events) 79 | (process-events poller events number-of-events)))))) 80 | 81 | (defmethod monitor-socket ((poller epoll-poller) socket socket-events) 82 | (with-accessors ((monitor-table monitor-table) 83 | (descriptor-socket-table descriptor-socket-table)) 84 | poller 85 | (multiple-value-bind (value present?) (gethash socket monitor-table) 86 | (declare (ignore value)) 87 | (when present? 88 | (error "Socket ~A is already monitored by poller ~A." socket poller)) 89 | 90 | (setf (gethash socket monitor-table) nil 91 | (gethash (file-descriptor socket) descriptor-socket-table) socket 92 | (monitored-events poller socket) socket-events)))) 93 | 94 | (defmethod unmonitor-socket ((poller epoll-poller) socket) 95 | (with-accessors ((monitor-table monitor-table) 96 | (descriptor-socket-table descriptor-socket-table)) 97 | poller 98 | (multiple-value-bind (value present?) (gethash socket monitor-table) 99 | (declare (ignore value)) 100 | (when present? 101 | (unless (socket-closed-p socket) 102 | (setf (monitored-events poller socket) nil)) 103 | (remhash (file-descriptor socket) descriptor-socket-table) 104 | (remhash socket monitor-table))))) 105 | 106 | (defgeneric epoll-events (object) 107 | (:documentation "Return the list of events required for epoll to 108 | notify when the event OBJECT occurs.")) 109 | 110 | (defgeneric epoll-match-p (object events socket) 111 | (:documentation "Inspect EVENTS and SOCKET to see if the OBJECT 112 | event has occurred.")) 113 | 114 | (defmethod monitored-events ((poller epoll-poller) socket) 115 | (gethash socket (monitor-table poller))) 116 | 117 | (defmethod (setf monitored-events) (value (poller epoll-poller) socket) 118 | (setf value (if (listp value) 119 | value 120 | (list value))) 121 | 122 | (with-accessors ((monitor-table monitor-table) 123 | (epoll-descriptor epoll-descriptor)) 124 | poller 125 | (let ((fd (file-descriptor socket))) 126 | (cffi:with-foreign-object (event '(:struct epoll-event)) 127 | (cffi:with-foreign-slots ((events data) event (:struct epoll-event)) 128 | (setf (cffi:foreign-slot-value data '(:union epoll-data) 'fd) fd 129 | events (remove-duplicates (reduce #'append value :key #'epoll-events))) 130 | (cond 131 | ((null value) 132 | (%ff-epoll-ctl epoll-descriptor :epoll-ctl-del fd event)) 133 | ((null (gethash socket monitor-table)) 134 | (%ff-epoll-ctl epoll-descriptor :epoll-ctl-add fd event)) 135 | (t 136 | (%ff-epoll-ctl epoll-descriptor :epoll-ctl-mod fd event)))))) 137 | (setf (gethash socket monitor-table) value))) 138 | 139 | (defun process-events (poller events number-of-events) 140 | (with-accessors ((monitor-table monitor-table) 141 | (descriptor-socket-table descriptor-socket-table)) 142 | poller 143 | (let ((data (loop 144 | :for index :from 0 :below number-of-events 145 | :collect 146 | (let ((event (cffi:mem-aptr events '(:struct epoll-event) index))) 147 | (cffi:with-foreign-slots ((events data) event (:struct epoll-event)) 148 | (cffi:with-foreign-slots ((fd) data (:union epoll-data)) 149 | (let* ((socket (gethash fd descriptor-socket-table)) 150 | (monitored-events (gethash socket monitor-table))) 151 | (assert (and socket monitored-events)) 152 | (list socket (loop 153 | :for monitored-event :in monitored-events 154 | :when (epoll-match-p monitored-event events socket) 155 | :collect 156 | monitored-event))))))))) 157 | (remove-if #'null data :key #'second)))) 158 | 159 | (defun epoll-event-data (symbol) 160 | (when (null symbol) 161 | (error "Attempting to retrieve EPOLL-EVENT-DATA for NIL.")) 162 | (get symbol 'epoll-event-data)) 163 | 164 | (defun (setf epoll-event-data) (value symbol) 165 | (setf (get symbol 'epoll-event-data) value)) 166 | 167 | (defclass epoll-event-data () 168 | ((events 169 | :initarg :events 170 | :reader epoll-events) 171 | (test-function 172 | :initarg :test-function 173 | :reader test-function))) 174 | 175 | (defmethod epoll-match-p ((object epoll-event-data) events socket) 176 | (funcall (test-function object) events socket)) 177 | 178 | (defun ensure-epoll-event-data (name events test-function) 179 | (check-type name (and (not null) symbol)) 180 | (check-type events list) 181 | (check-type test-function function) 182 | (assert (every #'keywordp events)) 183 | (setf (epoll-event-data name) (make-instance 'epoll-event-data 184 | :events events 185 | :test-function test-function))) 186 | 187 | (defmethod epoll-events ((object symbol)) 188 | (epoll-events (epoll-event-data object))) 189 | 190 | (defmethod epoll-match-p ((object symbol) events socket) 191 | (epoll-match-p (epoll-event-data object) events socket)) 192 | 193 | (eval-when (:compile-toplevel :load-toplevel :execute) 194 | (defun prepare-epoll-event-test-function/expander (sexp events-var socket-var) 195 | (labels ((recurse (sexp) 196 | (prepare-epoll-event-test-function/expander sexp events-var socket-var)) 197 | (unsupported-form () 198 | (error "Unsupported form for DEFINE-EPOLL-EVENT test function: ~A" sexp))) 199 | (cond 200 | ((keywordp sexp) 201 | (assert (cffi:foreign-bitfield-value 'epoll-events (list sexp))) 202 | `(find ,sexp ,events-var)) 203 | ((listp sexp) 204 | (alexandria:destructuring-case sexp 205 | ((and &rest args) 206 | `(and ,@(mapcar #'recurse args))) 207 | ((or &rest args) 208 | `(or ,@(mapcar #'recurse args))) 209 | ((not arg) 210 | `(not ,(recurse arg))) 211 | ((lambda (socket) &body body) 212 | `(funcall (function (lambda (,socket) 213 | ,@body)) 214 | ,socket-var)) 215 | ((t &rest args) 216 | (declare (ignore args)) 217 | (unsupported-form)))) 218 | (t 219 | (unsupported-form))))) 220 | 221 | (defun prepare-epoll-event-test-function (sexp) 222 | (let ((events-var (gensym)) 223 | (socket-var (gensym))) 224 | `(lambda (,events-var ,socket-var) 225 | (declare (ignorable ,events-var ,socket-var)) 226 | ,(prepare-epoll-event-test-function/expander sexp events-var socket-var)))) 227 | 228 | (defmacro define-epoll-event (name &body body) 229 | (labels ((body-values (key) 230 | (let ((v (find key body :key #'first))) 231 | (unless v 232 | (error "Unable to find entry with key ~A" key)) 233 | (rest v))) 234 | (body-value (key) 235 | (first (body-values key)))) 236 | `(ensure-epoll-event-data ',name 237 | (list ,@(body-values :events)) 238 | (function ,(prepare-epoll-event-test-function (body-value :test))))))) 239 | 240 | (define-epoll-event connection-available-p 241 | (:events :epollin) 242 | (:test (and :epollin (not :epollhup)))) 243 | 244 | (define-epoll-event determinedp 245 | (:events :epollin :epollout) 246 | (:test (or :epollin :epollout))) 247 | 248 | (define-epoll-event connection-succeeded-p 249 | (:events :epollout) 250 | (:test (and :epollout 251 | (not :epollhup) 252 | (not :epollerr) 253 | (not (and :epollin 254 | (lambda (socket) 255 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 256 | (zerop (read-from-stream socket buffer :peek t))))))))) 257 | 258 | (define-epoll-event connection-failed-p 259 | (:events :epollin) 260 | (:test (and :epollin 261 | (or :epollhup 262 | :epollerr 263 | :epollrdhup 264 | (lambda (socket) 265 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 266 | (zerop (read-from-stream socket buffer :peek t)))))))) 267 | 268 | (define-epoll-event data-available-p 269 | (:events :epollin) 270 | (:test (and :epollin (not :epollrdhup) (not :epollhup)))) 271 | 272 | (define-epoll-event ready-to-write-p 273 | (:events :epollout) 274 | (:test (and :epollout 275 | (not :epollhup) 276 | (not :epollrdhup)))) 277 | 278 | (define-epoll-event remote-disconnected-p 279 | (:events :epollin) 280 | (:test (and :epollin 281 | (lambda (socket) 282 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 283 | (zerop (read-from-stream socket buffer :peek t))))))) -------------------------------------------------------------------------------- /src/posix-poll.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | ;; POLL-SOCKETS helpers 4 | (defgeneric compute-poll-fd-events (socket socket-events) 5 | (:documentation "Return the list of POLL-EVENTS symbols required for 6 | the events field in the pollfd structure. SOCKET-EVENTS can be a 7 | single symbol or a list of symbols that represent events that can be 8 | detected using poll(2).")) 9 | 10 | (defmethod compute-poll-fd-events (socket (socket-events list)) 11 | (loop 12 | :for socket-event :in socket-events 13 | :append (compute-poll-fd-events socket socket-event))) 14 | 15 | (defgeneric parse-poll-fd-result (socket socket-events revents) 16 | (:documentation "Parse the POLL-EVENTS symbols returned by poll(2) 17 | and determine if any event in SOCKET-EVENTS occurred. SOCKET-EVENTS 18 | may be a symbol or a list of symbols.")) 19 | 20 | (defmethod parse-poll-fd-result (socket (socket-events list) revents) 21 | (loop 22 | :for socket-event :in socket-events 23 | :for result := (parse-poll-fd-result socket socket-event revents) 24 | :when result 25 | :collect result)) 26 | 27 | (define-condition poll-socket-error (error) 28 | ((socket 29 | :initarg :socket 30 | :reader socket) 31 | (message 32 | :initarg :message 33 | :reader message)) 34 | (:report (lambda (condition stream) 35 | (write-string (message condition) stream)))) 36 | 37 | ;; POLL-SOCKETS Implementation 38 | (defmethod poll-socket (socket socket-events timeout) 39 | (first (poll-sockets (list socket) (list socket-events) timeout))) 40 | 41 | (defmethod poll-sockets ((all-sockets list) (all-socket-events list) timeout) 42 | (declare (type (or (member :immediate :indefinite) 43 | (real 0)) 44 | timeout)) 45 | (assert (= (length all-sockets) 46 | (length all-socket-events))) 47 | (let ((number-of-sockets (length all-sockets))) 48 | (cffi:with-foreign-object (poll-fd-array '(:struct pollfd) number-of-sockets) 49 | ;; Build up the structure to pass to poll(2) 50 | (loop 51 | :for socket :in all-sockets 52 | :for socket-events :in all-socket-events 53 | :for index :from 0 54 | :for poll-fd := (cffi:mem-aptr poll-fd-array '(:struct pollfd) index) 55 | :do 56 | (cffi:with-foreign-slots ((fd events) poll-fd (:struct pollfd)) 57 | (setf fd (file-descriptor socket)) 58 | (setf events (compute-poll-fd-events socket socket-events)))) 59 | 60 | ;; Call poll(2) 61 | (handler-case (%ff-poll poll-fd-array number-of-sockets (case timeout 62 | (:immediate 0) 63 | (:indefinite -1) 64 | ;; Convert to milliseconds 65 | (t (max 0 66 | (coerce (round (* timeout 1000)) 67 | 'integer))))) 68 | (posix-error (c) 69 | (unless (posix-error-interrupted-p c) 70 | (error c))) 71 | (:no-error (garbage) 72 | (declare (ignore garbage)) 73 | 74 | ;; Parse the revents field to determine events. 75 | (loop 76 | :for socket :in all-sockets 77 | :for socket-events :in all-socket-events 78 | :for index :from 0 79 | :for poll-fd := (cffi:mem-aptr poll-fd-array '(:struct pollfd) index) 80 | :collect 81 | (cffi:with-foreign-slots ((revents) poll-fd (:struct pollfd)) 82 | (parse-poll-fd-result socket socket-events revents)))))))) 83 | 84 | ;; Posix Poll FD event definitions helpers 85 | (defun poll-fd-event-test/sexp (expression events socket) 86 | (labels ((eventp (event) 87 | (find event events)) 88 | (evaluate (s-exp) 89 | (cond 90 | ((symbolp s-exp) 91 | (eventp s-exp)) 92 | ((listp s-exp) 93 | (ecase (first s-exp) 94 | (or 95 | (some #'evaluate (rest s-exp))) 96 | (and 97 | (every #'evaluate (rest s-exp))) 98 | (not 99 | (assert (= 2 (length s-exp))) 100 | (not (evaluate (second s-exp)))) 101 | (lambda 102 | (destructuring-bind ((socket-var) &body body) (rest s-exp) 103 | (declare (ignore socket-var body)) 104 | (funcall (compile nil s-exp) socket))) 105 | (t 106 | (error "Invalid poll-fd-event-test form: ~A" s-exp)))) 107 | (t 108 | (error "Invalid poll-fd-event-test form: ~A" s-exp))))) 109 | (if (evaluate expression) 110 | t 111 | nil))) 112 | 113 | (defun poll-fd-event-test (expression events socket) 114 | (if (functionp expression) 115 | (funcall expression events socket) 116 | (poll-fd-event-test/sexp expression events socket))) 117 | 118 | (defun compilable-poll-fd-event-expression (expression) 119 | (let* ((lambda-labels nil) 120 | (new-expression (labels ((rewrite (exp) 121 | (cond 122 | ((symbolp exp) 123 | `(eventp ',exp)) 124 | ((listp exp) 125 | (ecase (first exp) 126 | (or 127 | `(or ,@(mapcar #'rewrite (rest exp)))) 128 | (and 129 | `(and ,@(mapcar #'rewrite (rest exp)))) 130 | (not 131 | (assert (= 2 (length exp))) 132 | `(not ,(rewrite (second exp)))) 133 | (lambda 134 | (let ((fn-name (gensym))) 135 | (push (cons fn-name (rest exp)) lambda-labels) 136 | (list fn-name 'socket))) 137 | (t 138 | (error "Invalid poll-fd-event-test form: ~A" exp)))) 139 | (t 140 | (error "Invalid poll-fd-event-test form: ~A" exp))))) 141 | (rewrite expression)))) 142 | `(lambda (events socket) 143 | (declare (ignorable socket)) 144 | (labels (,@lambda-labels 145 | (eventp (event) 146 | (find event events))) 147 | ,new-expression)))) 148 | 149 | (defun compile-poll-fd-event-expression (expression) 150 | (compile nil (compilable-poll-fd-event-expression expression))) 151 | 152 | (eval-when (:compile-toplevel :load-toplevel :execute) 153 | (defmacro define-poll-fd-event (name &body body) 154 | "Provide implementations for COMPUTE-POLL-FD-EVENTS and 155 | PARSE-POLL-FD-EVENTS for the poll-fd event macro NAME. BODY consists 156 | of expressions starting with :CLASSES, :INPUT or :TEST. 157 | 158 | (:CLASSES ... ) represents the classes in which 159 | this event macro should be defined. 160 | 161 | (:INPUT ) are the events that poll(2) should look 162 | for. 163 | 164 | (:TEST ) is an expression that determines if the event 165 | occurred. 166 | " 167 | (labels ((body-values (key) 168 | (let ((v (find key body :key #'first))) 169 | (unless v 170 | (error "Unable to find expression starting with ~A in ~A" key body)) 171 | (rest v))) 172 | (body-value (key) 173 | (first (body-values key)))) 174 | `(progn 175 | ,@(mapcar #'(lambda (class) 176 | `(defmethod compute-poll-fd-events ((object ,class) (socket-events (eql ',name))) 177 | ',(body-values :input))) 178 | (body-values :classes)) 179 | 180 | (let ((compiled-fn (compile-poll-fd-event-expression ',(body-value :test)))) 181 | (labels ((do-test (events socket) 182 | (poll-fd-event-test compiled-fn events socket))) 183 | ,@(mapcar #'(lambda (class) 184 | `(defmethod parse-poll-fd-result ((object ,class) (socket-events (eql ',name)) revents) 185 | (dolist (error ',(body-values :error)) 186 | (when (find error revents) 187 | (error 'poll-socket-error 188 | :message (format nil "Error with socket ~A: ~A" object 189 | (get error 'poll-fd-event-error-message)) 190 | :socket object))) 191 | (if (do-test revents object) 192 | ',name 193 | nil))) 194 | (body-values :classes)))))))) 195 | 196 | (eval-when (:compile-toplevel :load-toplevel :execute) 197 | (defmacro define-poll-fd-event-errors (&body body) 198 | "A symbol macro for declaraing the messages that are to be used 199 | when PARSE-POLL-FD-RESULT encounters an event that represents a socket 200 | error. BODY is a collection (event-symbol message) forms." 201 | `(progn 202 | ,@(mapcar #'(lambda (x) 203 | (destructuring-bind (event message) x 204 | `(setf (get ',event 'poll-fd-event-error-message) ,message))) 205 | body)))) 206 | 207 | (define-poll-fd-event-errors 208 | (pollerr "An exceptional condition has occurred.") 209 | (pollnval "File descriptor for socket is not open.")) 210 | 211 | (define-poll-fd-event connection-available-p 212 | (:classes ipv4-tcp-server 213 | local-server) 214 | (:input pollin) 215 | (:test pollin) 216 | (:error pollnval)) 217 | 218 | #-linux 219 | (define-poll-fd-event determinedp 220 | (:classes posix-stream) 221 | (:input pollout) 222 | (:test (or pollout pollhup)) 223 | (:error pollnval)) 224 | 225 | #-linux 226 | (define-poll-fd-event connection-failed-p 227 | (:classes posix-stream) 228 | (:input pollin) 229 | (:test pollhup) 230 | (:error pollnval)) 231 | 232 | #-linux 233 | (define-poll-fd-event connection-succeeded-p 234 | (:classes posix-stream) 235 | (:input pollout pollin) 236 | (:test (and pollout (not pollhup) 237 | (or (not pollin) 238 | (lambda (socket) 239 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 240 | (declare (dynamic-extent buffer)) 241 | (plusp (read-from-stream socket buffer :peek t))))))) 242 | (:error pollnval)) 243 | 244 | #+linux 245 | (define-poll-fd-event determinedp 246 | (:classes posix-stream) 247 | (:input pollin pollout) 248 | (:test (or pollout pollhup)) 249 | (:error pollnval)) 250 | 251 | #+linux 252 | (define-poll-fd-event connection-failed-p 253 | (:classes posix-stream) 254 | (:input pollin) 255 | (:test (or pollhup)) 256 | (:error pollnval)) 257 | 258 | #+linux 259 | (define-poll-fd-event connection-succeeded-p 260 | (:classes posix-stream) 261 | (:input pollout pollin) 262 | (:test (and pollout (not pollhup) 263 | (or (not pollin) 264 | (lambda (socket) 265 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 266 | (declare (dynamic-extent buffer)) 267 | (plusp (read-from-stream socket buffer :peek t))))))) 268 | (:error pollnval)) 269 | 270 | (define-poll-fd-event data-available-p 271 | (:classes posix-stream) 272 | (:input pollin) 273 | (:test (and pollin (not pollhup) 274 | (lambda (socket) 275 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 276 | (declare (dynamic-extent buffer)) 277 | (plusp (read-from-stream socket buffer :peek t)))))) 278 | (:error pollnval)) 279 | 280 | (define-poll-fd-event ready-to-write-p 281 | (:classes posix-stream) 282 | (:input pollout pollin) 283 | (:test (and pollout (not pollhup) 284 | (or (not pollin) 285 | (lambda (socket) 286 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 287 | (declare (dynamic-extent buffer)) 288 | (plusp (read-from-stream socket buffer :peek t))))))) 289 | (:error pollnval)) 290 | 291 | (define-poll-fd-event remote-disconnected-p 292 | (:classes posix-stream) 293 | (:input pollin) 294 | (:test (or pollhup 295 | (and pollin 296 | (lambda (socket) 297 | (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) 298 | (declare (dynamic-extent buffer)) 299 | (= 0 (read-from-stream socket buffer :peek t))))))) 300 | (:error pollnval)) 301 | 302 | ;; failed posix stream 303 | (defmethod compute-poll-fd-events ((socket failed-posix-stream) socket-events) 304 | (declare (ignore socket-events)) 305 | nil) 306 | 307 | (defmethod parse-poll-fd-result ((socket failed-posix-stream) (socket-events symbol) revents) 308 | (declare (ignore revents)) 309 | (if (find socket-events '(determinedp connection-failed-p)) 310 | socket-events 311 | nil)) 312 | -------------------------------------------------------------------------------- /src/kqueue-poller.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (defparameter *kevent-struct* 4 | #+darwin '(:struct kevent64-s) 5 | #+freebsd '(:struct kevent) 6 | #-(or darwin freebsd) (error "Unsupported platform for KQUEUE.")) 7 | 8 | (defgeneric kqueue-descriptor (kqueue-poller) 9 | (:documentation "The OS descriptor for the KQUEUE.")) 10 | 11 | ;; CLOSEDP is defined elsewhere. 12 | #- (and) 13 | (defgeneric closedp (object) 14 | (:documentation "A predicate for determining whether or not the KQUEUE is closed.")) 15 | 16 | (defgeneric monitor-table (kqueue-poller) 17 | (:documentation "A table containing information about each monitored socket.")) 18 | 19 | (defgeneric maximum-number-of-events (kqueue-poller) 20 | (:documentation "The maximum number of events that the kevent syscall can return.")) 21 | 22 | (defclass kqueue-poller (poller) 23 | ((kqueue-descriptor 24 | :initarg :kqueue-descriptor 25 | :reader kqueue-descriptor) 26 | (closedp 27 | :initarg :closedp 28 | :accessor closedp) 29 | (monitor-table 30 | :initarg :monitor-table 31 | :reader monitor-table) 32 | (descriptor-socket-table 33 | :initarg :descriptor-socket-table 34 | :reader descriptor-socket-table) 35 | (maximum-number-of-events 36 | :initarg :maximum-number-of-events 37 | :reader maximum-number-of-events)) 38 | (:default-initargs 39 | :closedp nil 40 | :monitor-table (make-hash-table) 41 | :descriptor-socket-table (make-hash-table) 42 | :maximum-number-of-events 100)) 43 | 44 | (defun make-poller () 45 | (make-instance 'kqueue-poller 46 | :kqueue-descriptor (%ff-kqueue))) 47 | 48 | (defmethod close-poller ((object kqueue-poller)) 49 | (unless (closedp object) 50 | (%ff-close (kqueue-descriptor object)) 51 | (setf (closedp object) t))) 52 | 53 | (defmethod monitoredp ((poller kqueue-poller) socket) 54 | (multiple-value-bind (value present?) (gethash socket (monitor-table poller)) 55 | (declare (ignore value)) 56 | present?)) 57 | 58 | (defmethod monitor-socket ((poller kqueue-poller) socket socket-events) 59 | (with-accessors ((monitor-table monitor-table) 60 | (descriptor-socket-table descriptor-socket-table)) 61 | poller 62 | (multiple-value-bind (value present-p) (gethash socket monitor-table) 63 | (declare (ignore value)) 64 | (when present-p 65 | (error "Socket ~A is already being monitored by poller ~A." socket poller)) 66 | 67 | (setf (gethash socket monitor-table) nil) 68 | (setf (gethash (file-descriptor socket) descriptor-socket-table) socket) 69 | (setf (monitored-events poller socket) socket-events)))) 70 | 71 | (defmethod unmonitor-socket ((poller kqueue-poller) socket) 72 | (with-accessors ((monitor-table monitor-table) 73 | (kqueue-descriptor kqueue-descriptor)) 74 | poller 75 | (multiple-value-bind (events present-p) (gethash socket monitor-table) 76 | (declare (ignore events)) 77 | (when present-p 78 | (unless (socket-closed-p socket) 79 | (setf (monitored-events poller socket) nil)) 80 | (remhash socket monitor-table) 81 | (remhash (file-descriptor socket) (descriptor-socket-table poller)))))) 82 | 83 | (defmethod monitored-events ((poller kqueue-poller) socket) 84 | (with-accessors ((monitor-table monitor-table)) poller 85 | (gethash socket monitor-table))) 86 | 87 | (defgeneric compute-change-list (socket current-events new-events)) 88 | 89 | (defgeneric kevent-filters (object) 90 | (:documentation "Return the kevent filters needed to match the event 91 | represented by OBJECT.")) 92 | 93 | (defgeneric match-kqueue-events (object events)) 94 | 95 | (defmethod (setf monitored-events) (value (poller kqueue-poller) socket) 96 | (assert (monitoredp poller socket)) 97 | (setf value (if (listp value) 98 | value 99 | (list value))) 100 | 101 | (with-accessors ((monitor-table monitor-table) 102 | (kqueue-descriptor kqueue-descriptor)) 103 | poller 104 | (let* ((current-events (gethash socket monitor-table)) 105 | (change-list (compute-change-list socket current-events value)) 106 | (kevent-struct *kevent-struct*)) 107 | (cffi:with-foreign-objects ((ptr-change-list kevent-struct (length change-list)) 108 | (ptr-event-list kevent-struct 0) 109 | (timeout '(:struct timespec))) 110 | (setf (cffi:foreign-slot-value timeout '(:struct timespec) 'tv-sec) 0 111 | (cffi:foreign-slot-value timeout '(:struct timespec) 'tv-nsec) 0) 112 | 113 | (loop 114 | :for change :in change-list 115 | :for index :from 0 116 | :for ptr := (cffi:mem-aptr ptr-change-list kevent-struct index) 117 | :do 118 | (prepare-kevent-struct change ptr)) 119 | 120 | (let ((number-of-events (kevent-wrapper kqueue-descriptor 121 | ptr-change-list (length change-list) 122 | ptr-event-list 0 timeout))) 123 | (assert (zerop number-of-events)))) 124 | 125 | (setf (gethash socket (monitor-table poller)) value)))) 126 | 127 | (defmethod compute-change-list ((socket socket) current new) 128 | (let ((current (if (listp current) current (list current))) 129 | (new (if (listp new) new (list new)))) 130 | (assert (and (listp current) (listp new))) 131 | 132 | (labels ((valid-event-p (event) 133 | (if (typep socket 'stream-server) 134 | (member event '(connection-available-p)) 135 | (member event '(connection-failed-p connection-succeeded-p determinedp 136 | data-available-p ready-to-write-p 137 | remote-disconnected-p)))) 138 | (reduce-kevent-filters (events) 139 | (remove-duplicates (reduce #'append events :key #'kevent-filters)))) 140 | (assert (every #'valid-event-p current)) 141 | (assert (every #'valid-event-p new)) 142 | 143 | (let* ((current-filters (reduce-kevent-filters current)) 144 | (new-filters (reduce-kevent-filters new)) 145 | (filters-to-remove (set-difference current-filters new-filters)) 146 | (filters-to-add (set-difference new-filters current-filters)) 147 | rv) 148 | (dolist (filter filters-to-remove) 149 | (push (list (file-descriptor socket) filter :ev-delete) rv)) 150 | (dolist (filter filters-to-add) 151 | (push (list (file-descriptor socket) filter :ev-add) rv)) 152 | rv)))) 153 | 154 | (defmethod wait-for-events ((poller kqueue-poller) timeout) 155 | (assert (typep timeout '(or (member :indefinite :immediate) 156 | (real 0)))) 157 | (let ((kevent-struct *kevent-struct*)) 158 | (cffi:with-foreign-objects ((change-list-ptr kevent-struct 0) 159 | (event-list-ptr kevent-struct (maximum-number-of-events poller)) 160 | (timespec-ptr '(:struct timespec))) 161 | 162 | (cffi:with-foreign-slots ((tv-sec tv-nsec) timespec-ptr (:struct timespec)) 163 | (cond 164 | ((realp timeout) 165 | (setf tv-sec (floor timeout) 166 | tv-nsec (floor (* 1e9 (- timeout (floor timeout)))))) 167 | ((eql timeout :immediate) 168 | (setf tv-sec 0 169 | tv-nsec 0)) 170 | ((eql timeout :indefinite) ;; do nothing. 171 | )) 172 | (handler-case (kevent-wrapper (kqueue-descriptor poller) 173 | change-list-ptr 0 174 | event-list-ptr (maximum-number-of-events poller) 175 | (if (eql timeout :indefinite) 176 | (cffi:null-pointer) 177 | timespec-ptr)) 178 | (posix-error (c) 179 | (unless (posix-error-interrupted-p c) 180 | (error c))) 181 | (:no-error (n) 182 | (process-kqueue-events poller 183 | (loop 184 | :for index :from 0 :below n 185 | :collect 186 | (parse-kevent-struct (cffi:mem-aptr event-list-ptr kevent-struct index)))))))))) 187 | 188 | (defun process-kqueue-events (poller events) 189 | (let* ((unique-file-descriptors (remove-duplicates (mapcar #'first events) :test #'=)) 190 | (unique-sockets (mapcar #'(lambda (fd) 191 | (gethash fd (descriptor-socket-table poller))) 192 | unique-file-descriptors))) 193 | (assert (not (find nil unique-sockets))) 194 | (loop 195 | :for current-fd :in unique-file-descriptors 196 | :for current-socket :in unique-sockets 197 | :for socket-events := (remove-if-not #'(lambda (fd) 198 | (= current-fd fd)) 199 | events :key #'first) 200 | :for matched-events := (loop 201 | :for monitored-event :in (monitored-events poller current-socket) 202 | :when (match-kqueue-events monitored-event socket-events) 203 | :collect monitored-event) 204 | :when matched-events 205 | :collect 206 | (list current-socket matched-events)))) 207 | 208 | ;; KQUEUE EVENTS 209 | (defun kevent/ident (object) 210 | (first object)) 211 | 212 | (defun kevent/filter (object) 213 | (second object)) 214 | 215 | (defun kevent/flags (object) 216 | (third object)) 217 | 218 | (defun kevent/data (object) 219 | (fifth object)) 220 | 221 | ;; - connection-available-p 222 | (defmethod kevent-filters ((object (eql 'connection-available-p))) 223 | '(:evfilt-read)) 224 | 225 | (defmethod match-kqueue-events ((object (eql 'connection-available-p)) events) 226 | (when (and events (= 1 (length events))) 227 | (equal (kevent/filter (first events)) :evfilt-read))) 228 | 229 | ;; - determinedp 230 | (defmethod kevent-filters ((object (eql 'determinedp))) 231 | '(:evfilt-read :evfilt-write)) 232 | 233 | (defmethod match-kqueue-events ((object (eql 'determinedp)) events) 234 | (not (null events))) 235 | 236 | ;; - connection-succeeded-p 237 | (defmethod kevent-filters ((object (eql 'connection-succeeded-p))) 238 | '(:evfilt-write :evfilt-read)) 239 | 240 | (defmethod match-kqueue-events ((object (eql 'connection-succeeded-p)) events) 241 | (let ((write (find :evfilt-write events :key #'kevent/filter)) 242 | (read (find :evfilt-read events :key #'kevent/filter))) 243 | (and write 244 | (or (not read) 245 | (not (find :ev-eof (kevent/flags read))))))) 246 | 247 | ;; - connection-failed-p 248 | (defmethod kevent-filters ((object (eql 'connection-failed-p))) 249 | '(:evfilt-read)) 250 | 251 | (defmethod match-kqueue-events ((object (eql 'connection-failed-p)) events) 252 | (let ((read (find :evfilt-read events :key #'kevent/filter))) 253 | (and read 254 | (find :ev-eof (kevent/flags read))))) 255 | 256 | ;; - data-available-p 257 | (defmethod kevent-filters ((object (eql 'data-available-p))) 258 | '(:evfilt-read)) 259 | 260 | (defmethod match-kqueue-events ((object (eql 'data-available-p)) events) 261 | (let ((read (find :evfilt-read events :key #'kevent/filter))) 262 | (and read 263 | (not (find :ev-eof (kevent/flags read))) 264 | (plusp (kevent/data read))))) 265 | 266 | ;; - read-to-write-p 267 | (defmethod kevent-filters ((object (eql 'ready-to-write-p))) 268 | '(:evfilt-write)) 269 | 270 | (defmethod match-kqueue-events ((object (eql 'ready-to-write-p)) events) 271 | (let ((write (find :evfilt-write events :key #'kevent/filter))) 272 | (and write 273 | (plusp (kevent/data write))))) 274 | 275 | ;; - remote-disconnected-p 276 | (defmethod kevent-filters ((object (eql 'remote-disconnected-p))) 277 | '(:evfilt-read)) 278 | 279 | (defmethod match-kqueue-events ((object (eql 'remote-disconnected-p)) events) 280 | (let ((read (find :evfilt-read events :key #'kevent/filter))) 281 | (and read 282 | (find :ev-eof (kevent/flags read))))) 283 | 284 | ;; KEVENT STRUCTS 285 | #+darwin 286 | (progn 287 | (defun parse-kevent-struct (kevent-struct-ptr) 288 | (cffi:with-foreign-slots ((ident filter flags fflags data udata ext) kevent-struct-ptr (:struct kevent64-s)) 289 | (list ident 290 | (cffi:foreign-enum-keyword 'kevent-filters filter) 291 | (remove-if #'(lambda (keyword) 292 | (zerop (logand flags (cffi:foreign-enum-value 'kevent-flags keyword)))) 293 | (cffi:foreign-enum-keyword-list 'kevent-flags)) 294 | fflags 295 | data 296 | udata 297 | (list (cffi:mem-aref ext :uint64 0) 298 | (cffi:mem-aref ext :uint64 1))))) 299 | 300 | (defun prepare-kevent-struct (change kevent-struct-ptr) 301 | (cffi:with-foreign-slots ((ident filter flags fflags data udata ext) kevent-struct-ptr (:struct kevent64-s)) 302 | (destructuring-bind (change-ident change-filter change-flags) change 303 | (setf ident change-ident 304 | filter (cffi:foreign-enum-value 'kevent-filters change-filter) 305 | flags (cffi:foreign-enum-value 'kevent-flags change-flags) 306 | fflags 0 307 | data 0 308 | udata 0) 309 | 310 | (setf (cffi:mem-aref ext :uint64 0) 0 311 | (cffi:mem-aref ext :uint64 1) 0))))) 312 | 313 | #+freebsd 314 | (progn 315 | (defun parse-kevent-struct (kevent-struct-ptr) 316 | (cffi:with-foreign-slots ((ident filter flags fflags data udata) kevent-struct-ptr (:struct kevent)) 317 | (list ident 318 | (cffi:foreign-enum-keyword 'kevent-filters filter) 319 | (remove-if #'(lambda (keyword) 320 | (zerop (logand flags (cffi:foreign-enum-value 'kevent-flags keyword)))) 321 | (cffi:foreign-enum-keyword-list 'kevent-flags)) 322 | fflags 323 | data 324 | udata))) 325 | 326 | (defun prepare-kevent-struct (change kevent-struct-ptr) 327 | (cffi:with-foreign-slots ((ident filter flags fflags data udata) kevent-struct-ptr (:struct kevent)) 328 | (destructuring-bind (change-ident change-filter change-flags) change 329 | (setf ident change-ident 330 | filter (cffi:foreign-enum-value 'kevent-filters change-filter) 331 | flags (cffi:foreign-enum-value 'kevent-flags change-flags) 332 | fflags 0 333 | data 0 334 | udata (cffi:null-pointer)))))) 335 | -------------------------------------------------------------------------------- /doc/basic-binary-ipc.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Basic Binary Inter Process Communication 2 | #+AUTHOR: Mark Cox 3 | 4 | This system provides an interface for performing inter process 5 | communication using streams. The interface follows a non-blocking 6 | pattern which allows applications to communicate either synchronously 7 | or asynchronously. 8 | 9 | [TABLE-OF-CONTENTS] 10 | 11 | * Installation 12 | The prerequisite systems for this extension are 13 | - [[http://common-lisp.net/project/cffi/][~CFFI~]] 14 | - [[https://github.com/OdonataResearchLLC/lisp-unit][Lisp Unit]] (tests only) 15 | These libraries can be obtained using [[http://www.quicklisp.org][Quicklisp]]. 16 | 17 | Access to the operating system's networking API is performed using the 18 | foreign function interface provided by ~CFFI~. The operating systems 19 | that are supported are: 20 | - [[http://www.apple.com/osx/][Apple OSX]] (Tested with version 10.7.5, 32 bit and 64 bit) 21 | - [[http://www.freebsd.org][FreeBSD]] (Tested with version 9.1, 32 bit and 64 bit) 22 | - Linux (Tested with [[http://www.debian.org][Debian]] squeeze, 32 bit and 64 bit) 23 | - [[http://windows.microsoft.com/en-US/windows/home][Microsoft Windows]] (Tested with Windows 8, 64 bit MinGW) 24 | 25 | The system can be loaded in to the current Lisp environment via ASDF. 26 | #+begin_src lisp 27 | (asdf:load-system "basic-binary-ipc") 28 | #+end_src 29 | 30 | The tests for the system can be executed via ASDF as well. 31 | #+begin_src lisp 32 | (asdf:test-system "basic-binary-ipc") 33 | #+end_src 34 | All tests should succeed. 35 | 36 | * Introduction 37 | The goal of this system is to provide an easy method for establishing 38 | a communication channel known as a stream. A stream is a 39 | bidirectional, full duplex communication channel with the guarantee 40 | that the order in which data is read is the same as the order it was 41 | written and that the data written is the same as the data read. 42 | 43 | The term stream used in this system is not to be confused with the 44 | Common Lisp stream. The two terms are distinct. The main reason for 45 | this distinction is that every operation in this system is 46 | non-blocking and changes in state are obtained via a polling 47 | interface. The benefit of the polling strategy is that it does not 48 | require callbacks which allows the library to be used in either 49 | synchronous or asynchronous settings. 50 | 51 | * Namespaces 52 | An application must consider the namespace in which two processes are 53 | to communicate. A namespace represents the lower level protocol that 54 | the stream is constructed on top of. This library can construct 55 | streams in the following namespaces 56 | - [[*IPv4][IPv4 namespace]] :: The Internet protocol version 4 namespace using the 57 | transmission control protocol. 58 | - [[*Local][Local namespace]] :: Local or Unix domain sockets for communicating between 59 | processes located on the same physical device. 60 | 61 | Once a namespace is chosen, the functions for that namespace determine 62 | how to initiate a connection to a server or start a new server that is 63 | capable of accepting incoming connections. Both of these tasks involve 64 | creating a specialised socket. 65 | 66 | * Sockets 67 | A socket represents an operating system resource that is needed to 68 | perform communication. Once a socket is no longer required, its 69 | resources must be released using the ~CLOSE-SOCKET~ function. 70 | #+begin_src lisp 71 | (defgeneric close-socket (object)) 72 | #+end_src 73 | A socket has been closed if the predicate ~SOCKET-CLOSED-P~ is 74 | non ~NIL~. 75 | 76 | Objects implementing the socket protocol inherit from the ~SOCKET~ 77 | class. 78 | 79 | This library provides protocols for two different types of sockets, 80 | the stream server socket and the stream socket. 81 | 82 | Lastly, this library adheres to the philosophy that errors should only 83 | be signaled in exceptional circumstances. If an exceptional 84 | circumstance occurs during any operation then an error of type 85 | ~SOCKET-ERROR~ is signaled. Some operations are capable of signaling 86 | other error types. 87 | 88 | ** Stream Servers 89 | The stream server protocol represents sockets that listen for 90 | connections from clients. Accepting a new connection is performed 91 | using the ~ACCEPT-CONNECTION~ function. 92 | #+begin_src lisp 93 | (defgeneric accept-connection (server)) 94 | #+end_src 95 | This function returns a new object that implements the [[*Stream Clients][stream socket]] 96 | protocol. The ~ACCEPT-CONNECTION~ function will signal a 97 | ~NO-CONNECTION-AVAILABLE-ERROR~ condition if there is no client 98 | waiting for acknowledgment from the server. 99 | 100 | It should be noted that the returned stream socket is dissociated from 101 | the server that created the connection i.e. calling ~CLOSE-SOCKET~ on 102 | a server will /not/ terminate any of its accepted connections. 103 | 104 | The predicate ~CONNECTION-AVAILABLE-P~ returns non ~NIL~ if the server 105 | has connections available. 106 | #+begin_src lisp 107 | (defgeneric connection-available-p (server)) 108 | #+end_src 109 | 110 | All objects implementing the stream server protocol inherit from the 111 | ~STREAM-SERVER~ class. 112 | 113 | ** Stream Sockets 114 | A stream socket represents a stream that is either established or in 115 | the process of being established. 116 | 117 | There are two ways to create a stream socket. The first is to use a 118 | namespace specific function to initiate a connection to a server. The 119 | second is using the ~ACCEPT-CONNECTION~ function on a server object. 120 | 121 | Once a stream socket has been created, it immediately starts to 122 | establish the stream by negotiating with the remote socket. This 123 | negotiation may take a significant amount of time, and in some cases 124 | may fail to complete e.g. a network failure, an overloaded server or 125 | an unreachable host. This period of uncertainty is modelled by the 126 | future connection protocol and is implemented by all instances of the 127 | ~STREAM-SOCKET~ class. 128 | 129 | The predicate 130 | #+begin_src lisp 131 | (defgeneric determinedp (future-connection)) 132 | #+end_src 133 | can be used to determine if the the operating system has finished 134 | trying to negotiate a new stream connection. The result of the 135 | negotiation can be obtained using the predicates ~CONNECTION-FAILED-P~ 136 | or ~CONNECTION-SUCCEEDED-P~. 137 | #+begin_src lisp 138 | (defgeneric connection-failed-p (future-connection)) 139 | (defgeneric connection-succeeded-p (future-connection)) 140 | #+end_src 141 | 142 | If the connection is successful, the stream protocol outlined next can 143 | be used to send and receive data over the newly created stream. 144 | 145 | The function ~DATA-AVAILABLE-P~ can be used to determine if there is 146 | data that can be read immediately from the stream using the function 147 | ~READ-FROM-STREAM~. 148 | #+begin_src lisp 149 | (defgeneric data-available-p (stream)) 150 | (defgeneric read-from-stream (stream buffer &key start end peek)) 151 | #+end_src 152 | The return value of ~READ-FROM-STREAM~ is the number of bytes written 153 | to ~BUFFER~. This can be either the number of bytes that are 154 | immediately available for reading or the value ~(- END START)~. If 155 | ~PEEK~ is ~T~ then ~READ-FROM-STREAM~ obtains data from the stream 156 | without removing it from the stream. i.e. the next call to 157 | ~READ-FROM-STREAM~ will contain exactly the same data. 158 | 159 | Note that it is possible for ~READ-FROM-STREAM~ to signal an error 160 | despite ~DATA-AVAILABLE-P~ having returned true! This is the nature of 161 | communication channels where the path connecting the two stream 162 | sockets is governed by a large number of interacting agents. 163 | 164 | Writing data to the stream is performed using the function 165 | ~WRITE-TO-STREAM~. 166 | #+begin_src lisp 167 | (defgeneric write-to-stream (stream buffer &key start end)) 168 | #+end_src 169 | The return value of ~WRITE-TO-STREAM~ is the number of bytes 170 | written. If no bytes can be written then this function returns 171 | ~0~. 172 | 173 | The predicate ~READY-TO-WRITE-P~ can be used to determine if data can 174 | be written immediately. 175 | #+begin_src lisp 176 | (defgeneric ready-to-write-p (stream)) 177 | #+end_src 178 | Please be aware that the function ~WRITE-TO-STREAM~ can still fail 179 | even if ~READY-TO-WRITE-P~ returned non ~NIL~. 180 | 181 | Last but not least, the predicate ~REMOTE-DISCONNECTED-P~ can be used 182 | to determine if the connection between the two stream sockets has been 183 | severed. 184 | #+begin_src lisp 185 | (defgeneric remote-disconnected-p (stream)) 186 | #+end_src 187 | 188 | * IPv4 189 | The IPv4 namespace is the namespace that is the foundation of the 190 | Internet. The Transmission Control Protocol (TCP) is the underlying 191 | protocol used to establish a stream in the IPv4 namespace. A stream 192 | socket in the IPv4 namespace is uniquely defined by a local host 193 | address, a local port number, a remote host address and a remote port 194 | number. 195 | 196 | The function ~MAKE-IPV4-TCP-SERVER~ can be used to create a IPv4 197 | stream server that listens for incoming connections to ~PORT~ on the 198 | host ~ADDRESS~. 199 | #+begin_src lisp 200 | (defun make-ipv4-tcp-server (host-address port &key reuse-socket-address backlog)) 201 | #+end_src 202 | The number ~PORT~ must be of type ~(UNSIGNED-BYTE 16)~ and the value 203 | of ~HOST-ADDRESS~ must be a string in dotted-quad format. e.g 204 | ~127.0.0.1~ or one of the constants: 205 | - ~+IPV4-LOOPBACK+~ :: The address of the localhost IPv4 network 206 | interface. 207 | - ~+IPV4-ANY+~ :: All IPv4 network interfaces for the host. 208 | 209 | The value returned from ~MAKE-IPV4-TCP-SERVER~ is an instance of type 210 | ~IPV4-TCP-SERVER~ and adheres to the [[*Stream Server][stream server]] protocol. The 211 | object returned also implements the following functions 212 | #+begin_src lisp 213 | (defgeneric host-address (ipv4-tcp-server)) 214 | (defgeneric port (ipv4-tcp-server)) 215 | #+end_src 216 | 217 | If the ~PORT~ argument to ~MAKE-IPV4-TCP-SERVER~ is zero, than the 218 | operating system will automatically assign a non-zero port to the 219 | server. The assigned port can be retrieved using the ~PORT~ generic 220 | function defined above. 221 | 222 | The function ~CONNECT-TO-IPV4-TCP-SERVER~ creates a stream socket that 223 | connects to the TCP/IPv4 server listening on the socket address 224 | defined by ~HOST-ADDRESS~ and ~PORT~. 225 | #+begin_src lisp 226 | (defun connect-to-ipv4-tcp-server (host-address port &key local-host-address local-port)) 227 | #+end_src 228 | The arguments ~LOCAL-HOST-ADDRESS~ and ~LOCAL-PORT~ can be used to 229 | specify which local host address and port number should be used to 230 | connect to the server. If these are not specified, then a random port 231 | number and an appropriate host address are chosen. 232 | 233 | Stream sockets obtained by using ~ACCEPT-CONNECTION~ or 234 | ~CONNECT-TO-IPV4-TCP-SERVER~ are of type ~IPV4-TCP-STREAM~. This class 235 | extends the stream socket protocol with the following functions 236 | #+begin_src lisp 237 | (defgeneric local-host-address (stream)) 238 | (defgeneric local-port (stream)) 239 | (defgeneric remote-host-address (stream)) 240 | (defgeneric remote-port (stream)) 241 | #+end_src 242 | 243 | The function ~CONNECT-TO-IPV4-TCP-SERVER~ only accepts host addresses 244 | in dotted quad format (i.e. ~127.0.0.1~). The function 245 | ~RESOLVE-IPV4-ADDRESS~ can be used to obtain a host address for a 246 | given domain name. 247 | #+begin_src lisp 248 | (defun resolve-ipv4-address (hostname)) 249 | #+end_src 250 | If successful, a string containing the host address is returned. If no 251 | host address exists for the given ~HOSTNAME~ than ~NIL~ is 252 | returned. An ~ERROR~ is signalled if ~RESOLVE-IPV4-ADDRESS~ fails for 253 | any other reason. 254 | 255 | The reader should be aware that ~RESOLVE-IPV4-ADDRESS~ is a blocking 256 | operation i.e. the current thread will block until the address has 257 | been retrieved. 258 | 259 | * Local 260 | This section outlines how to create a communication channel between 261 | two processes running on the same physical machine. Local stream 262 | sockets are defined by a filesystem pathname to a server. Unlike IPv4, 263 | the Local namespace does not have the ability to determine if two 264 | stream sockets refer to the same stream. 265 | 266 | The function ~MAKE-LOCAL-SERVER~ creates a server that is capable of 267 | accepting incoming connections on the local namespace. 268 | #+begin_src lisp 269 | (defun make-local-server (pathname &key (backlog 5) (delete-on-close t))) 270 | #+end_src 271 | The ~PATHNAME~ argument specifies the filesystem pathname where the 272 | server listens for connections. This pathname must not exist prior to 273 | calling ~MAKE-LOCAL-SERVER~. A non ~-NIL~ argument for 274 | ~DELETE-ON-CLOSE~ specifies that ~CLOSE-SOCKET~ should delete 275 | ~PATHNAME~ when the server is closed. 276 | 277 | The object returned by ~MAKE-LOCAL-SERVER~ is an instance of the class 278 | ~LOCAL-SERVER~ and implements the stream server protocol. It also 279 | implements the function ~LOCAL-PATHNAME~ which returns the ~PATHNAME~ 280 | argument to ~MAKE-LOCAL-SERVER~. 281 | #+begin_src lisp 282 | (defgeneric local-pathname (local-socket)) 283 | #+end_src 284 | 285 | All stream objects returned by ~ACCEPT-CONNECTION~ are instances of 286 | the class ~LOCAL-STREAM~. 287 | 288 | Connections to local servers can be initiated using the function 289 | ~CONNECT-TO-LOCAL-SERVER~. 290 | #+begin_src lisp 291 | (defun connect-to-local-server (pathname &key)) 292 | #+end_src 293 | where ~PATHNAME~ is the filesystem pathname of the server. The object 294 | returned is an instance of type ~LOCAL-STREAM~ which implements the [[*Stream 295 | Socket][stream socket]] protocol and the ~LOCAL-PATHNAME~ function mentioned 296 | above. If no server exists at ~PATHNAME~, then a 297 | ~NO-LOCAL-SERVER-ERRROR~ is signalled. 298 | 299 | * Polling 300 | All functions outlined above work directly on the current state of the 301 | socket. The function ~POLL-SOCKET~ allows an application to block 302 | until an object changes state. e.g. data is now available or the 303 | remote host has disconnected. 304 | #+begin_src lisp 305 | (defgeneric poll-socket (socket socket-events timeout)) 306 | #+end_src 307 | The ~TIMEOUT~ argument specifies how long to wait (in seconds) until a 308 | state change occurs on the socket. A value of ~:IMMEDIATE~ indicates 309 | that ~POLL-SOCKET~ should not wait and return the current state. A 310 | value of ~:INDEFINITE~ means to wait until an event occurs. 311 | 312 | The ~SOCKET-EVENTS~ argument tells the ~POLL-SOCKET~ function what 313 | event(s) to wait for. This argument is socket specific and can be 314 | either a symbol or a list of symbols. The symbols accepted correspond 315 | to the predicate functions for each socket object. For example, for 316 | stream server objects, only the symbol ~CONNECTION-AVAILABLE-P~ is 317 | accepted. For stream socket objects, the symbols ~DETERMINEDP~, 318 | ~CONNECTION-SUCCEEDED-P~, ~CONNECTION-FAILED-P~, ~DATA-AVAILABLE-P~, 319 | ~READY-TO-WRITE-P~ and/or ~REMOTE-DISCONNECTED-P~ are all permitted. 320 | 321 | The return value of ~POLL-SOCKET~ is either a ~SYMBOL~, a list of 322 | ~SYMBOLS~ or ~NIL~. A symbol is returned only if ~SOCKET-EVENTS~ is a 323 | symbol. A value of ~NIL~ indicates that no events that match the 324 | criteria of ~SOCKET-EVENTS~ has occurred. One should not conclude that 325 | ~TIMEOUT~ seconds has transpired when ~POLL-SOCKET~ returns ~NIL~. It 326 | is possible for ~POLL-SOCKETS~ to return with a value of ~NIL~ without 327 | timing out. 328 | 329 | An extremely useful variant of ~POLL-SOCKET~ is the ~POLL-SOCKETS~ 330 | function. 331 | #+begin_src lisp 332 | (defun poll-sockets (all-sockets all-sockets-events timeout)) 333 | #+end_src 334 | This function acts like the following 335 | #+begin_src lisp 336 | (multiplexing-collect 337 | (poll-socket socket-1 socket-1-events 10) 338 | (poll-socket socket-2 socket-2-events 10) 339 | ..) 340 | #+end_src 341 | where the hypothetical function ~MULTIPLEXING-COLLECT~ executes all 342 | ~POLL-SOCKET~ calls simultaneously and stops them all as soon as an 343 | event occurs on any socket. The return value is a list containing the 344 | results of performing ~POLL-SOCKET~ on that socket alone. For example 345 | #+begin_src lisp 346 | (destructuring-bind (s1-result s2-result s3-result) 347 | (poll-sockets (list s1 s2 s3) 348 | (list s1-events s2-events s3-events) 349 | 10) 350 | ;; do stuff with results 351 | ) 352 | #+end_src 353 | 354 | ** Polling many sockets 355 | One draw back of ~POLL-SOCKETS~ is that every call to ~POLL-SOCKETS~ 356 | requires traversing ~N~ sockets and their corresponding events. For 357 | server applications this can be problematic as ~N~ is typically large, 358 | ~N~ changes frequently and ~POLL-SOCKETS~ is called repeatedly until 359 | the server stops. In order to handle this situation, the ~POLLER~ 360 | protocol is provided. 361 | 362 | ~POLLER~s represent an operating system resource that monitors many 363 | sockets. Creating a poller object is performed using the function 364 | ~MAKE-POLLER~. 365 | #+begin_src lisp 366 | (defun make-poller ()) 367 | #+end_src 368 | 369 | Waiting for events to occur with a poller is performed with the 370 | function ~WAIT-FOR-EVENTS~. 371 | #+begin_src lisp 372 | (defgeneric wait-for-events (poller timeout)) 373 | #+end_src 374 | The return value of ~WAIT-FOR-EVENTS~ is ~NIL~ if no events occurred 375 | or a list where each item is a list containing two entries, ~SOCKET~ 376 | and ~SOCKET-EVENTS~. The ~TIMEOUT~ argument can be a positive value 377 | representing seconds, or it can be one of ~:IMMEDIATE~ or 378 | ~:INDEFINITE~. Like ~POLL-SOCKET~ and ~POLL-SOCKETS~, a return value 379 | of ~NIL~ does not mean that the function timed out. 380 | 381 | Adding a socket to be monitored by a ~POLLER~ is performed using the 382 | ~MONITOR-SOCKET~ function. 383 | #+begin_src lisp 384 | (defgeneric monitor-socket (poller socket socket-events)) 385 | #+end_src 386 | where ~SOCKET~ is the socket to add and ~SOCKET-EVENTS~ contain the 387 | events to wait for. 388 | 389 | Changing the set of events to be monitored by the poller is performed 390 | using the ~(SETF MONITORED-EVENTS)~ function. 391 | #+begin_src lisp 392 | (defgeneric (setf monitored-events) (socket-events poller socket)) 393 | #+end_src 394 | The current set of events being monitored can be accessed using the 395 | ~MONITORED-EVENTS~ function. 396 | #+begin_src lisp 397 | (defgeneric monitored-events (poller socket)) 398 | #+end_src 399 | 400 | Removing a socket from a ~POLLER~ is achieved with the function 401 | ~UNMONITOR-SOCKET~. 402 | #+begin_src lisp 403 | (defgeneric unmonitor-socket (poller socket)) 404 | #+end_src 405 | 406 | The current set of sockets being monitored can be retrieved using the 407 | function ~MONITORED-SOCKETS~. 408 | #+begin_src lisp 409 | (defgeneric monitored-sockets (poller)) 410 | #+end_src 411 | 412 | When a poller is no longer required, the function ~CLOSE-POLLER~ must 413 | be called in order to release the operating system resource. 414 | #+begin_src lisp 415 | (defgeneric close-poller (poller)) 416 | #+end_src 417 | 418 | Finally, all objects implementing the above ~POLLER~ protocol inherit 419 | from the ~POLLER~ class. 420 | 421 | -------------------------------------------------------------------------------- /tests/overlapped-io.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC.OVERLAPPED-IO.TESTS") 2 | 3 | #-windows 4 | (error "The file ~A should only be compiled/loaded on Windows." (or *compile-file-truename* 5 | *load-truename*)) 6 | 7 | (defun random-string (&optional (number-of-characters 10)) 8 | (let ((rv (make-string number-of-characters)) 9 | (offset (char-code #\a)) 10 | (range (- (char-code #\z) (char-code #\a)))) 11 | (dotimes (index number-of-characters) 12 | (let ((code (random range))) 13 | (setf (elt rv index) (code-char (+ offset code))))) 14 | rv)) 15 | 16 | (defun random-pipe-name (&optional (number-of-characters 10)) 17 | (concatenate 'string 18 | "//./pipe/" 19 | (random-string number-of-characters))) 20 | 21 | (define-test named-pipe/connection/nothing 22 | (with-handle (server (make-named-pipe-server (random-pipe-name))) 23 | (with-request (connect-request (connect-named-pipe server)) 24 | (assert-false (invalidp connect-request)) 25 | (assert-true (waitingp connect-request)) 26 | (assert-false (completedp connect-request)) 27 | 28 | (cancel-all-io server)))) 29 | 30 | (define-test named-pipe/connection/wait 31 | (let ((pipe-name (random-pipe-name))) 32 | (with-handle (server (make-named-pipe-server pipe-name)) 33 | (with-request (connect-request (connect-named-pipe server)) 34 | (assert-false (invalidp connect-request)) 35 | (assert-true (waitingp connect-request)) 36 | (assert-false (completedp connect-request)) 37 | 38 | (with-handle (client (connect-to-named-pipe pipe-name)) 39 | (declare (ignore client)) 40 | (assert-false (waitingp connect-request)) 41 | (assert-true (completedp connect-request)) 42 | (assert-true (succeededp connect-request))))))) 43 | 44 | (define-test named-pipe/connection/no-wait 45 | (let ((pipe-name (random-pipe-name))) 46 | (with-handle (server (make-named-pipe-server pipe-name)) 47 | (with-handle (client (connect-to-named-pipe pipe-name)) 48 | (declare (ignore client)) 49 | (with-request (connect-request (connect-named-pipe server)) 50 | (assert-false (invalidp connect-request)) 51 | (assert-false (waitingp connect-request)) 52 | (assert-true (completedp connect-request)) 53 | (assert-true (succeededp connect-request))))))) 54 | 55 | (eval-when (:compile-toplevel :load-toplevel :execute) 56 | (defun do-with-connected-pipe (function &key ignore-close-errors) 57 | (let ((pipe-name (random-pipe-name))) 58 | (with-handle (server (make-named-pipe-server pipe-name) :ignore-close-errors (if (eql ignore-close-errors :client-only) 59 | nil 60 | t)) 61 | (with-handle (client (connect-to-named-pipe pipe-name) :ignore-close-errors (if (eql ignore-close-errors :server-only) 62 | nil 63 | t)) 64 | (with-request (connect-request (connect-named-pipe server)) 65 | (assert (completedp connect-request)) 66 | (funcall function server client)))))) 67 | 68 | (defmacro with-connected-pipe ((server client &rest args) &body body) 69 | `(do-with-connected-pipe #'(lambda (,server ,client) 70 | ,@body) 71 | ,@args))) 72 | 73 | (define-test named-pipe/read/no-data 74 | (with-connected-pipe (server client) 75 | (declare (ignore client)) 76 | (cffi:with-foreign-object (buffer :uint8 100) 77 | (with-request (read-request (read-file server buffer 100)) 78 | (assert-false (completedp read-request)) 79 | (cancel-all-io server))))) 80 | 81 | (define-test named-pipe/read/immediate 82 | (with-connected-pipe (server client) 83 | (cffi:with-foreign-objects ((buffer-to-write :uint8 100) 84 | (buffer-to-read :uint8 100)) 85 | (dotimes (index 100) 86 | (setf (cffi:mem-aref buffer-to-write :uint8 index) index 87 | (cffi:mem-aref buffer-to-read :uint8 index) 0)) 88 | 89 | (with-request (write-request (write-file client buffer-to-write 100)) 90 | (wait-for-request write-request 1) 91 | (assert-true (completedp write-request)) 92 | (assert-true (succeededp write-request)) 93 | (assert-equal 100 (bytes-written write-request))) 94 | 95 | (with-request (read-request (read-file server buffer-to-read 100)) 96 | (wait-for-request read-request 1) 97 | (assert-true (completedp read-request)) 98 | (assert-true (succeededp read-request)) 99 | (assert-equal 100 (bytes-read read-request)) 100 | 101 | (dotimes (index 100) 102 | (assert-equal index (cffi:mem-aref buffer-to-read :uint8 index)) 103 | (assert-equal index (cffi:mem-aref (buffer read-request) :uint8 index))))))) 104 | 105 | (define-test named-pipe/read/wait 106 | (with-connected-pipe (server client) 107 | (cffi:with-foreign-objects ((buffer-to-write :uint8 100) 108 | (buffer-to-read :uint8 100)) 109 | (dotimes (index 100) 110 | (setf (cffi:mem-aref buffer-to-write :uint8 index) index 111 | (cffi:mem-aref buffer-to-read :uint8 index) 0)) 112 | 113 | (with-request (read-request (read-file server buffer-to-read 100)) 114 | (assert-false (completedp read-request)) 115 | (assert-equal nil (bytes-read read-request)) 116 | 117 | (with-request (write-request (write-file client buffer-to-write 100)) 118 | (wait-for-request write-request 1) 119 | (assert-true (completedp write-request)) 120 | (assert-true (succeededp write-request)) 121 | (assert-equal 100 (bytes-written write-request))) 122 | 123 | (wait-for-request read-request 1) 124 | (assert-true (completedp read-request)) 125 | (assert-true (succeededp read-request)) 126 | (assert-equal 100 (bytes-read read-request)) 127 | 128 | (dotimes (index 100) 129 | (assert-equal index (cffi:mem-aref buffer-to-read :uint8 index)) 130 | (assert-equal index (cffi:mem-aref (buffer read-request) :uint8 index))))))) 131 | 132 | (define-test named-pipe/disconnect/close-client 133 | (with-connected-pipe (server client :ignore-close-errors :client-only) 134 | (cffi:with-foreign-objects ((buffer-to-read :uint8 100)) 135 | (with-request (read-request (read-file server buffer-to-read 100)) 136 | (assert-false (completedp read-request)) 137 | (close-handle client) 138 | (assert-true (completedp read-request)) 139 | (assert-false (succeededp read-request)) 140 | (assert-equal 0 (bytes-read read-request)))))) 141 | 142 | (define-test named-pipe/disconnect/close-server 143 | (with-connected-pipe (server client :ignore-close-errors :server-only) 144 | (cffi:with-foreign-objects ((buffer-to-read :uint8 100)) 145 | (with-request (read-request (read-file client buffer-to-read 100)) 146 | (assert-false (completedp read-request)) 147 | (close-handle server) 148 | (assert-true (completedp read-request)) 149 | (assert-false (succeededp read-request)) 150 | (assert-equal 0 (bytes-read read-request)))))) 151 | 152 | (define-test wait-for-requests/one 153 | (with-connected-pipe (server-1 client-1) 154 | (declare (ignore client-1)) 155 | (with-connected-pipe (server-2 client-2) 156 | (cffi:with-foreign-objects ((buffer-1 :uint8 10) 157 | (buffer-2 :uint8 10) 158 | (write-buffer :uint8 10)) 159 | (dotimes (index 10) 160 | (setf (cffi:mem-aref write-buffer :uint8) index)) 161 | 162 | (with-request (read-1 (read-file server-1 buffer-1 10)) 163 | (with-request (read-2 (read-file server-2 buffer-2 10)) 164 | (assert-equal nil (wait-for-requests (list read-1 read-2) 0)) 165 | 166 | (with-request (write-2 (write-file client-2 write-buffer 10)) 167 | (assert-true (completedp write-2))) 168 | 169 | (assert-equal read-2 (wait-for-requests (list read-1 read-2) 1)) 170 | (assert-equal 10 (bytes-read read-2))) 171 | (cancel-all-io server-1)))))) 172 | 173 | (define-test wait-for-requests/all 174 | (with-connected-pipe (server-1 client-1) 175 | (with-connected-pipe (server-2 client-2) 176 | (cffi:with-foreign-objects ((buffer-1 :uint8 10) 177 | (buffer-2 :uint8 10) 178 | (write-buffer :uint8 10)) 179 | (dotimes (index 10) 180 | (setf (cffi:mem-aref write-buffer :uint8) index)) 181 | 182 | (with-request (read-1 (read-file server-1 buffer-1 10)) 183 | (with-request (read-2 (read-file server-2 buffer-2 10)) 184 | (assert-equal nil (wait-for-requests (list read-1 read-2) 0 :wait-all t)) 185 | 186 | (with-request (write-1 (write-file client-1 write-buffer 10)) 187 | (assert-true (completedp write-1))) 188 | 189 | (assert-equal nil (wait-for-requests (list read-1 read-2) 1 :wait-all t)) 190 | 191 | (with-request (write-2 (write-file client-2 write-buffer 10)) 192 | (assert-true (completedp write-2))) 193 | 194 | (assert-equal (list read-1 read-2) (wait-for-requests (list read-1 read-2) 1 :wait-all t)) 195 | 196 | (assert-equal 10 (bytes-read read-1)) 197 | (assert-equal 10 (bytes-read read-2)))))))) 198 | 199 | (define-test monitor 200 | (let ((number-of-bytes 20)) 201 | (with-connected-pipe (server-1 client-1) 202 | (with-connected-pipe (server-2 client-2) 203 | (cffi:with-foreign-objects ((buffer-1 :uint8 number-of-bytes) 204 | (buffer-2 :uint8 number-of-bytes) 205 | (write-buffer :uint8 number-of-bytes)) 206 | (dotimes (index number-of-bytes) 207 | (setf (cffi:mem-aref write-buffer :uint8 index) index 208 | (cffi:mem-aref buffer-1 :uint8 index) 0 209 | (cffi:mem-aref buffer-2 :uint8 index) 0)) 210 | 211 | (with-monitor (monitor) 212 | (with-request (read-1 (read-file server-1 buffer-1 number-of-bytes)) 213 | (with-request (read-2 (read-file server-2 buffer-2 number-of-bytes)) 214 | (monitor monitor read-1) 215 | (monitor monitor read-2) 216 | 217 | (with-request (write-1 (make-instance 'write-file-request :descriptor client-1)) 218 | (with-request (write-2 (make-instance 'write-file-request :descriptor client-2)) 219 | (monitor monitor write-1) 220 | (monitor monitor write-2) 221 | 222 | (write-file client-1 write-buffer number-of-bytes write-1) 223 | (write-file client-2 write-buffer number-of-bytes write-2) 224 | 225 | (let ((requests (list read-1 read-2 write-1 write-2))) 226 | (dotimes (attempt 4) 227 | (let ((v (pop-notification monitor 1))) 228 | (assert-true (find v requests)) 229 | (setf requests (remove v requests)))) 230 | (assert-false (pop-notification monitor 0))) 231 | 232 | (assert-true (completedp write-1)) 233 | (assert-true (completedp write-2)) 234 | (assert-true (completedp read-1)) 235 | (assert-true (completedp read-2))))))) 236 | 237 | (dotimes (index number-of-bytes) 238 | (assert-equal index (cffi:mem-aref buffer-1 :uint8 index)) 239 | (assert-equal index (cffi:mem-aref buffer-2 :uint8 index)))))))) 240 | 241 | ;;;; Sockets 242 | (defvar *ports* nil) 243 | (defun random-port () 244 | (loop 245 | :for port := (+ 41000 (random 1000)) 246 | :while (find port *ports* :test #'=) 247 | :finally (progn 248 | (push port *ports*) 249 | (return port)))) 250 | 251 | (eval-when (:compile-toplevel :load-toplevel :execute) 252 | (defun do-with-socket (socket function) 253 | (unwind-protect 254 | (funcall function socket) 255 | (ignore-errors (close-socket socket)))) 256 | 257 | (defmacro with-socket ((var form) &body body) 258 | `(do-with-socket ,form 259 | #'(lambda (,var) 260 | ,@body)))) 261 | 262 | (eval-when (:compile-toplevel :load-toplevel :execute) 263 | (defun do-with-ipv4-connection (address port local-address local-port function) 264 | (let ((local-address (or local-address +inaddr-any+)) 265 | (local-port (or local-port 0))) 266 | (with-socket (socket (make-socket :af-inet :sock-stream :ipproto-tcp)) 267 | (with-request (request (make-instance 'connect-ipv4-request)) 268 | (connect-ipv4 socket address port request local-address local-port) 269 | (with-socket (socket socket) 270 | (funcall function socket request)))))) 271 | 272 | (defmacro with-ipv4-connection ((socket request address port &optional local-address local-port) &body body) 273 | `(do-with-ipv4-connection ,address ,port 274 | ,local-address ,local-port 275 | #'(lambda (,socket ,request) 276 | ,@body)))) 277 | 278 | (define-test ipv4-connection 279 | (let ((port (random-port)) 280 | (address "127.0.0.1") 281 | (buffer-length (minimum-accept-ipv4-buffer-size))) 282 | (with-socket (server (make-ipv4-server address port)) 283 | (with-socket (remote-client (make-socket :af-inet :sock-stream :ipproto-tcp)) 284 | (cffi:with-foreign-objects ((buffer :uint8 buffer-length)) 285 | (with-request (accept (accept-ipv4 server remote-client buffer buffer-length)) 286 | (with-ipv4-connection (client connection-request address port) 287 | (declare (ignore client)) 288 | (wait-for-request accept 10) 289 | (assert-true (completedp accept)) 290 | (assert-true (succeededp accept)) 291 | (assert-true (completedp connection-request)) 292 | (assert-true (succeededp connection-request)) 293 | (assert-equal address (remote-address connection-request)) 294 | (assert-equal port (remote-port connection-request)) 295 | (assert-equal address (local-address accept)) 296 | (assert-equal port (local-port accept))))))))) 297 | 298 | (define-test ipv4-connection/specific-ports 299 | (let ((server-port (random-port)) 300 | (client-port (random-port)) 301 | (address "127.0.0.1") 302 | (buffer-length (minimum-accept-ipv4-buffer-size))) 303 | (with-socket (server (make-ipv4-server address server-port)) 304 | (with-socket (remote-client (make-socket :af-inet :sock-stream :ipproto-tcp)) 305 | (cffi:with-foreign-objects ((buffer :uint8 buffer-length)) 306 | (with-request (accept (accept-ipv4 server remote-client buffer buffer-length)) 307 | (with-ipv4-connection (client connection-request address server-port address client-port) 308 | (declare (ignore client)) 309 | (wait-for-request accept 10) 310 | (assert-true (completedp accept)) 311 | (assert-true (succeededp accept)) 312 | (assert-true (completedp connection-request)) 313 | (assert-true (succeededp connection-request)) 314 | (assert-equal address (remote-address connection-request)) 315 | (assert-equal server-port (remote-port connection-request)) 316 | (assert-equal address (local-address connection-request)) 317 | (assert-equal client-port (local-port connection-request)) 318 | (assert-equal address (local-address accept)) 319 | (assert-equal server-port (local-port accept)) 320 | (assert-equal address (remote-address accept)) 321 | (assert-equal client-port (remote-port accept))))))))) 322 | 323 | (define-test ipv4-connection/no-server/remote 324 | (let ((address "169.254.1.1") 325 | (port (random-port))) 326 | (with-ipv4-connection (client connection-request address port) 327 | (declare (ignore client)) 328 | (wait-for-request connection-request 60) 329 | (assert-true (completedp connection-request)) 330 | (assert-false (succeededp connection-request)) 331 | (assert-equal address (remote-address connection-request)) 332 | (assert-equal port (remote-port connection-request)) 333 | (assert-false (null (local-address connection-request))) 334 | (assert-false (null (local-port connection-request)))))) 335 | 336 | (define-test ipv4-connection/no-server/read 337 | (let ((address "169.254.1.1") 338 | (port (random-port))) 339 | (with-request (request (make-instance 'read-file-request)) 340 | (with-ipv4-connection (client connection-request address port) 341 | (declare (ignore connection-request)) 342 | (cffi:with-foreign-objects ((buffer :uint8 10)) 343 | (assert-error 'system-function-error (read-file client buffer 10 request))))))) 344 | 345 | (define-test ipv4-connection/no-server/write 346 | (let ((address "169.254.1.1") 347 | (port (random-port))) 348 | (with-request (request (make-instance 'write-file-request)) 349 | (with-ipv4-connection (client connection-request address port) 350 | (declare (ignore connection-request)) 351 | (cffi:with-foreign-objects ((buffer :uint8 10)) 352 | (assert-error 'system-function-error (write-file client buffer 10 request))))))) 353 | 354 | (define-test ipv4-connection/no-server/local 355 | (let ((address "127.0.0.1") 356 | (port (random-port))) 357 | (with-ipv4-connection (client connection-request address port) 358 | (declare (ignore client)) 359 | (wait-for-request connection-request 60) 360 | (assert-true (completedp connection-request)) 361 | (assert-false (succeededp connection-request)) 362 | (assert-equal address (remote-address connection-request)) 363 | (assert-equal port (remote-port connection-request)) 364 | (assert-false (null (local-address connection-request))) 365 | (assert-false (null (local-port connection-request)))))) 366 | 367 | (define-test ipv4-connection/zero-port 368 | (let ((address "127.0.0.1") 369 | (buffer-length (minimum-accept-ipv4-buffer-size))) 370 | (multiple-value-bind (socket-descriptor socket-address socket-port) 371 | (make-ipv4-server address 0) 372 | (with-socket (socket socket-descriptor) 373 | (assert-equal address socket-address) 374 | (assert-false (zerop socket-port)) 375 | (with-socket (remote-socket (make-socket :af-inet :sock-stream :ipproto-tcp)) 376 | (cffi:with-foreign-objects ((buffer :uint8 buffer-length)) 377 | (with-request (accept-request (accept-ipv4 socket remote-socket buffer buffer-length)) 378 | (with-socket (client-socket (make-socket :af-inet :sock-stream :ipproto-tcp)) 379 | (with-request (connect-request (connect-ipv4 client-socket address socket-port)) 380 | (wait-for-request connect-request 2) 381 | (wait-for-request accept-request 2) 382 | (assert-true t)))))))))) 383 | 384 | (eval-when (:compile-toplevel :load-toplevel :execute) 385 | (defun do-with-ipv4 (function address port) 386 | (let ((buffer-length (minimum-accept-ipv4-buffer-size))) 387 | (with-socket (server (make-ipv4-server address port)) 388 | (with-socket (remote-client (make-socket :af-inet :sock-stream :ipproto-tcp)) 389 | (cffi:with-foreign-object (buffer :uint8 buffer-length) 390 | (with-request (accept (accept-ipv4 server remote-client buffer buffer-length)) 391 | (with-ipv4-connection (client connection-request address port) 392 | (wait-for-request connection-request 10) 393 | (assert (and (completedp connection-request) 394 | (succeededp connection-request))) 395 | (assert (completedp accept)) 396 | (funcall function client remote-client)))))))) 397 | 398 | (defmacro with-ipv4 ((client remote-client &optional (address "127.0.0.1") (port '(random-port))) &body body) 399 | `(do-with-ipv4 #'(lambda (,client ,remote-client) 400 | ,@body) 401 | ,address ,port))) 402 | 403 | (define-test ipv4-connection/communication/nowait 404 | (let ((buffer-length 10)) 405 | (with-ipv4 (client remote-client) 406 | (cffi:with-foreign-objects ((read-buffer :uint8 buffer-length) 407 | (write-buffer :uint8 buffer-length)) 408 | (dotimes (index buffer-length) 409 | (setf (cffi:mem-aref write-buffer :uint8 index) index 410 | (cffi:mem-aref read-buffer :uint8 index) 0)) 411 | (with-request (writing (write-file client write-buffer buffer-length)) 412 | (wait-for-request writing 10) 413 | (assert-true (completedp writing))) 414 | 415 | (with-request (reading (read-file remote-client read-buffer buffer-length)) 416 | (assert-true (completedp reading)) 417 | (dotimes (index buffer-length) 418 | (assert-equal (cffi:mem-aref write-buffer :uint8 index) 419 | (cffi:mem-aref read-buffer :uint8 index)))))))) 420 | 421 | (define-test ipv4-connection/communication/wait 422 | (let ((buffer-length 10)) 423 | (with-ipv4 (client remote-client) 424 | (cffi:with-foreign-objects ((read-buffer :uint8 buffer-length) 425 | (write-buffer :uint8 buffer-length)) 426 | (dotimes (index buffer-length) 427 | (setf (cffi:mem-aref write-buffer :uint8 index) index 428 | (cffi:mem-aref read-buffer :uint8 index) 0)) 429 | (with-request (reading (read-file remote-client read-buffer buffer-length)) 430 | (assert-false (completedp reading)) 431 | 432 | (with-request (writing (write-file client write-buffer buffer-length)) 433 | (wait-for-request writing 10) 434 | (assert-true (and (completedp writing) 435 | (succeededp writing))) 436 | 437 | (assert-true (and (completedp reading) 438 | (succeededp reading))) 439 | (dotimes (index buffer-length) 440 | (assert-equal (cffi:mem-aref write-buffer :uint8 index) 441 | (cffi:mem-aref read-buffer :uint8 index))))))))) 442 | 443 | (define-test ipv4-connection/communication/disconnect 444 | (let ((buffer-length 10)) 445 | (with-ipv4 (client remote-client) 446 | (cffi:with-foreign-objects ((write-buffer :uint8 buffer-length) 447 | (read-buffer :uint8 buffer-length)) 448 | (dotimes (index buffer-length) 449 | (setf (cffi:mem-aref write-buffer :uint8 index) index 450 | (cffi:mem-aref read-buffer :uint8 index) 0)) 451 | 452 | (close-socket remote-client) 453 | 454 | (with-request (writing (write-file client write-buffer buffer-length)) 455 | (wait-for-request writing 10) 456 | (assert-true (and (completedp writing) 457 | (succeededp writing)))))))) 458 | -------------------------------------------------------------------------------- /src/posix-sockets.lisp: -------------------------------------------------------------------------------- 1 | (in-package "BASIC-BINARY-IPC") 2 | 3 | (defgeneric file-descriptor (object) 4 | (:documentation "Return the file descriptor of the object.")) 5 | 6 | (defgeneric namespace (posix-socket) 7 | (:documentation "Return the posix namespace used by the 8 | POSIX-SOCKET.")) 9 | 10 | (defgeneric communication-style (posix-socket) 11 | (:documentation "Return the posix communication style used by the 12 | POSIX-SOCKET.")) 13 | 14 | (defgeneric protocol (posix-socket) 15 | (:documentation "Return the protocol used by the POSIX-SOCKET.")) 16 | 17 | (defgeneric socket (object) 18 | (:documentation "Return the POSIX-SOCKET object used by OBJECT.")) 19 | 20 | (defclass posix-socket () 21 | ((namespace 22 | :initarg :namespace 23 | :reader namespace) 24 | (communication-style 25 | :initarg :communication-style 26 | :reader communication-style) 27 | (protocol 28 | :initarg :protocol 29 | :reader protocol) 30 | (file-descriptor 31 | :initarg :file-descriptor 32 | :reader file-descriptor 33 | :initform (error "File descriptors must be specified.")) 34 | (closedp 35 | :initarg :closedp 36 | :initform nil 37 | :reader socket-closed-p))) 38 | 39 | (defun make-posix-socket (namespace communication-style protocol) 40 | (let ((fd (%ff-socket namespace communication-style protocol))) 41 | (make-instance 'posix-socket 42 | :namespace namespace 43 | :communication-style communication-style 44 | :protocol protocol 45 | :file-descriptor fd))) 46 | 47 | (defmethod close-socket ((socket posix-socket)) 48 | (with-slots (closedp) socket 49 | (unless closedp 50 | (%ff-close (file-descriptor socket)) 51 | (setf closedp t)))) 52 | 53 | (eval-when (:compile-toplevel :load-toplevel :execute) 54 | (defmacro posix-socket-initialisation-progn ((socket) &body body) 55 | `(alexandria:unwind-protect-case () 56 | (progn 57 | ,@body) 58 | (:abort 59 | (close-socket ,socket))))) 60 | 61 | (defgeneric operating-modes (socket)) 62 | (defgeneric (setf operating-modes) (value socket)) 63 | 64 | (defmethod operating-modes ((object posix-socket)) 65 | (cffi:foreign-bitfield-symbols 'operating-mode (%ff-fcntl-noarg (file-descriptor object) :f-getfl))) 66 | 67 | (defmethod (setf operating-modes) (value (object posix-socket)) 68 | (%ff-fcntl-setfl (file-descriptor object) :f-setfl (cffi:foreign-bitfield-value 'operating-mode value))) 69 | 70 | ;; Socket Option arguments 71 | (define-socket-option-argument soa-boolean 72 | (:base-type :int) 73 | (:writer (value pointer) 74 | (setf (cffi:mem-ref pointer :int) (if value 1 0))) 75 | (:reader (pointer) 76 | (if (zerop (cffi:mem-ref pointer :int)) 77 | nil 78 | t))) 79 | 80 | ;; Socket options 81 | (define-socket-option (reuse-address-p :so-reuseaddr soa-boolean)) 82 | (define-socket-option (keep-alive-p :so-keepalive soa-boolean)) 83 | 84 | (defclass posix-stream (stream-socket) 85 | ((socket 86 | :initarg :socket 87 | :reader socket))) 88 | 89 | (defmethod close-socket ((object posix-stream)) 90 | (close-socket (socket object))) 91 | 92 | (defmethod file-descriptor ((object posix-stream)) 93 | (file-descriptor (socket object))) 94 | 95 | (defmethod socket-closed-p ((socket posix-stream)) 96 | (socket-closed-p (socket socket))) 97 | 98 | ;; Posix stream - future protocol 99 | (defmethod determinedp ((future-connection posix-stream)) 100 | (poll-socket future-connection 'determinedp :immediate)) 101 | 102 | (defmethod connection-failed-p ((future-connection posix-stream)) 103 | (poll-socket future-connection 'connection-failed-p :immediate)) 104 | 105 | (defmethod connection-succeeded-p ((future-connection posix-stream)) 106 | (poll-socket future-connection 'connection-succeeded-p :immediate)) 107 | 108 | ;; IPv4 Stream - stream protocol 109 | (defmethod data-available-p ((stream posix-stream)) 110 | (poll-socket stream 'data-available-p :immediate)) 111 | 112 | (defmethod ready-to-write-p ((stream posix-stream)) 113 | (poll-socket stream 'ready-to-write-p :immediate)) 114 | 115 | (defmethod remote-disconnected-p ((stream posix-stream)) 116 | (poll-socket stream 'remote-disconnected-p :immediate)) 117 | 118 | (defmethod read-from-stream ((stream posix-stream) buffer &key start end peek) 119 | (declare (type (vector (unsigned-byte 8)) buffer)) 120 | (unless start 121 | (setf start 0)) 122 | (unless end 123 | (setf end (length buffer))) 124 | 125 | (unless (<= start end) 126 | (error "The value START is greater than END.")) 127 | 128 | (unless (or (zerop (length buffer)) 129 | (and (>= start 0) (< start (length buffer)))) 130 | (error "The value START is not a valid index for BUFFER.")) 131 | 132 | (unless (and (>= end 0) (<= end (length buffer))) 133 | (error "The value END is not a valid end index for BUFFER.")) 134 | 135 | (cffi:with-pointer-to-vector-data (ptr buffer) 136 | (handler-case (%ff-recvfrom (file-descriptor stream) (cffi:mem-aptr ptr :uint8 start) (- end start) 137 | (if peek 138 | (cffi:foreign-bitfield-value 'message-flags '(msg-peek)) 139 | 0) 140 | (cffi:null-pointer) (cffi:null-pointer)) 141 | (posix-error (c) 142 | (if (posix-error-code-p c :ewouldblock) 143 | 0 144 | (error c)))))) 145 | 146 | (defmethod write-to-stream ((stream posix-stream) buffer &key start end) 147 | (declare (type (vector (unsigned-byte 8)) buffer)) 148 | (unless start 149 | (setf start 0)) 150 | (unless end 151 | (setf end (length buffer))) 152 | 153 | (unless (<= start end) 154 | (error "The value START is greater than END.")) 155 | 156 | (unless (and (>= start 0) (< start (length buffer))) 157 | (error "The value START is not a valid index for BUFFER.")) 158 | 159 | (unless (and (>= end 0) (<= end (length buffer))) 160 | (error "The value END is not a valid end index for BUFFER.")) 161 | 162 | (handler-case (cffi:with-pointer-to-vector-data (ptr buffer) 163 | (%ff-sendto (file-descriptor stream) 164 | (cffi:mem-aptr ptr :uint8 start) 165 | (- end start) 166 | 0 167 | (cffi:null-pointer) 168 | 0)) 169 | (posix-error (c) 170 | (if (posix-error-would-block-p c) 171 | 0 172 | (error c))))) 173 | 174 | ;; Failed stream 175 | (defclass failed-posix-stream (stream-socket) 176 | ((socket 177 | :initarg :socket 178 | :reader socket))) 179 | 180 | (defmethod close-socket ((socket failed-posix-stream)) 181 | (handler-case (close-socket (socket socket)) 182 | (posix-error (c) 183 | (unless (posix-error-code-p c :ebadf) 184 | (error c))))) 185 | 186 | (defmethod file-descriptor ((object failed-posix-stream)) 187 | (file-descriptor (socket object))) 188 | 189 | ;; - stream protocol 190 | (defmethod data-available-p ((socket-stream failed-posix-stream)) 191 | nil) 192 | 193 | (defmethod determinedp ((socket-stream failed-posix-stream)) 194 | t) 195 | 196 | (defmethod connection-failed-p ((socket-stream failed-posix-stream)) 197 | t) 198 | 199 | (defmethod connection-succeeded-p ((socket-stream failed-posix-stream)) 200 | nil) 201 | 202 | ;;;; Posix stream server 203 | (defclass posix-stream-server (stream-server) 204 | ((socket 205 | :initarg :socket 206 | :reader socket))) 207 | 208 | (defmethod close-socket ((object posix-stream-server)) 209 | (close-socket (socket object))) 210 | 211 | (defmethod file-descriptor ((object posix-stream-server)) 212 | (file-descriptor (socket object))) 213 | 214 | (defmethod socket-closed-p ((socket posix-stream-server)) 215 | (socket-closed-p (socket socket))) 216 | 217 | ;; IPv4 stream 218 | (defclass ipv4-tcp-stream (posix-stream) 219 | ((remote-host-address 220 | :initarg :remote-host-address 221 | :reader remote-host-address) 222 | (remote-port 223 | :initarg :remote-port 224 | :reader remote-port) 225 | (local-host-address 226 | :initarg :local-host-address 227 | :reader local-host-address) 228 | (local-port 229 | :initarg :local-port 230 | :reader local-port))) 231 | 232 | (defmethod print-object ((object ipv4-tcp-stream) stream) 233 | (print-unreadable-object (object stream :type t :identity t) 234 | (format stream "~A:~d -> ~A:~d" 235 | (local-host-address object) 236 | (local-port object) 237 | (remote-host-address object) 238 | (remote-port object)))) 239 | 240 | ;; Failed IPV4 Stream - This class is for the special situation when 241 | ;; using CONNECT-TO-TCP4-SERVER to connect to a server listening on 242 | ;; the loopback device. If the server does not exist, then some 243 | ;; operating systems signal an ECONNREFUSED error. In that case an 244 | ;; object of type FAILED-IPV4-TCP-STREAM is returned. 245 | (defclass failed-ipv4-tcp-stream (failed-posix-stream) 246 | ((remote-port 247 | :initarg :remote-port 248 | :reader remote-port) 249 | (remote-host-address 250 | :initarg :remote-host-address 251 | :reader remote-host-address))) 252 | 253 | (defmethod print-object ((object failed-ipv4-tcp-stream) stream) 254 | (print-unreadable-object (object stream :type t :identity t) 255 | (format stream "~A:~d" 256 | (remote-host-address object) 257 | (remote-port object)))) 258 | 259 | ;; IPv4 260 | (defparameter +ipv4-loopback+ (%ff-inet-ntoa (%ff-ntohl inaddr-loopback))) 261 | (defparameter +ipv4-any+ (%ff-inet-ntoa (%ff-ntohl inaddr-any))) 262 | 263 | (eval-when (:compile-toplevel :load-toplevel :execute) 264 | (defun do-with-sockaddr-in (function family host-address port) 265 | (declare (type (unsigned-byte 16) port) 266 | (type string host-address)) 267 | (cffi:with-foreign-object (sockaddr-in '(:struct sockaddr-in)) 268 | (zero-memory sockaddr-in '(:struct sockaddr-in)) 269 | (cffi:with-foreign-slots ((sin-family sin-port) sockaddr-in (:struct sockaddr-in)) 270 | (setf sin-family family 271 | sin-port (%ff-htons port)) 272 | (when (zerop (%ff-inet-aton host-address (cffi:foreign-slot-pointer sockaddr-in '(:struct sockaddr-in) 'sin-addr))) 273 | (error "Host address ~S is not in standard numbers-and-dots notation." host-address)) 274 | 275 | (funcall function sockaddr-in)))) 276 | 277 | (defmacro with-sockaddr-in ((var family host-address port) &body body) 278 | `(do-with-sockaddr-in #'(lambda (,var) 279 | ,@body) 280 | ,family ,host-address ,port))) 281 | 282 | (defclass ipv4-tcp-server (posix-stream-server) 283 | ((host-address 284 | :initarg :host-address 285 | :reader host-address) 286 | (port 287 | :initarg :port 288 | :reader port))) 289 | 290 | (defun make-ipv4-tcp-server (host-address port &key reuse-address (backlog 5)) 291 | (let ((socket (make-posix-socket :pf-inet :sock-stream 0))) 292 | (setf (operating-modes socket) '(o-nonblock) 293 | (reuse-address-p socket) reuse-address) 294 | (with-accessors ((file-descriptor file-descriptor)) socket 295 | (posix-socket-initialisation-progn (socket) 296 | (with-sockaddr-in (sockaddr-in :af-inet host-address port) 297 | (%ff-bind file-descriptor sockaddr-in (cffi:foreign-type-size '(:struct sockaddr-in))) 298 | (%ff-listen file-descriptor backlog) 299 | 300 | (cffi:with-foreign-object (length-ptr 'socklen-t) 301 | (setf (cffi:mem-ref length-ptr 'socklen-t) (cffi:foreign-type-size '(:struct sockaddr-in))) 302 | (%ff-getsockname file-descriptor sockaddr-in length-ptr) 303 | (make-instance 'ipv4-tcp-server 304 | :host-address (host-address-from-sockaddr-in sockaddr-in) 305 | :port (port-from-sockaddr-in sockaddr-in) 306 | :socket socket))))))) 307 | 308 | (defmethod connection-available-p ((server ipv4-tcp-server)) 309 | (let ((results (poll-socket server 'connection-available-p :immediate))) 310 | (if results t nil))) 311 | 312 | (defun posix-error-would-block-p (condition) 313 | "The predicate POSIX-ERROR-WOULD-BLOCK-P handles the potential 314 | sitation where EAGAIN and EWOULDBLOCK are defined to be the same 315 | ERRNO constant (this is true on OSX). This causes difficulties with 316 | the mapping between error codes and keywords in the enum 317 | ERRNO-ENUM." 318 | (let ((code (posix-error-code condition))) 319 | (cond 320 | ((= (cffi:foreign-enum-value 'errno-enum :eagain) 321 | (cffi:foreign-enum-value 'errno-enum :ewouldblock)) 322 | (or (eql code :eagain) 323 | (eql code :ewouldblock))) 324 | 325 | (t 326 | (eql code :ewouldblock))))) 327 | 328 | (defmethod accept-connection ((server ipv4-tcp-server)) 329 | (cffi:with-foreign-object (ptr '(:struct sockaddr-in)) 330 | (cffi:with-foreign-object (ptr-size 'socklen-t) 331 | (setf (cffi:mem-ref ptr-size 'socklen-t) (cffi:foreign-type-size '(:struct sockaddr-in))) 332 | (let* ((fd (handler-case (%ff-accept (file-descriptor (socket server)) ptr ptr-size) 333 | (posix-error (c) 334 | (if (posix-error-would-block-p c) 335 | (error 'no-connection-available-error :socket server) 336 | (error c))))) 337 | (socket (make-instance 'posix-socket 338 | :namespace (namespace (socket server)) 339 | :communication-style (communication-style (socket server)) 340 | :protocol (protocol (socket server)) 341 | :file-descriptor fd))) 342 | ;; This shouldn't be necessary but on some systems the socket 343 | ;; options are not inherited. 344 | (setf (operating-modes socket) '(o-nonblock)) 345 | (make-instance 'ipv4-tcp-stream 346 | :socket socket 347 | :local-port (port server) 348 | :local-host-address (host-address server) 349 | :remote-host-address (host-address-from-sockaddr-in ptr) 350 | :remote-port (port-from-sockaddr-in ptr)))))) 351 | 352 | ;; CONNECT-TO-IPV4-TCP-SERVER 353 | 354 | (defun host-address-from-inaddr (in-addr) 355 | (%ff-inet-ntoa (cffi:foreign-slot-value in-addr '(:struct in-addr) 's-addr))) 356 | 357 | (defun host-address-from-sockaddr-in (sockaddr-in) 358 | (host-address-from-inaddr (cffi:foreign-slot-pointer sockaddr-in '(:struct sockaddr-in) 'sin-addr))) 359 | 360 | (defun port-from-sockaddr-in (sockaddr-in) 361 | (%ff-ntohs (cffi:foreign-slot-value sockaddr-in '(:struct sockaddr-in) 'sin-port))) 362 | 363 | (defun connect-to-ipv4-tcp-server (host-address port &key local-host-address local-port) 364 | (let ((socket (make-posix-socket :pf-inet :sock-stream 0))) 365 | (posix-socket-initialisation-progn (socket) 366 | (setf (operating-modes socket) '(o-nonblock)) 367 | 368 | ;; Bind local host address and port. 369 | (setf local-host-address (or local-host-address 370 | +ipv4-any+)) 371 | (setf local-port (or local-port 372 | 0)) 373 | (with-sockaddr-in (sockaddr-in :af-inet local-host-address local-port) 374 | (%ff-bind (file-descriptor socket) sockaddr-in (cffi:foreign-type-size '(:struct sockaddr-in)))) 375 | 376 | ;; Connect to the host. 377 | (with-sockaddr-in (sockaddr-in :af-inet host-address port) 378 | (handler-case (%ff-connect (file-descriptor socket) sockaddr-in (cffi:foreign-type-size '(:struct sockaddr-in))) 379 | (posix-error (c) 380 | (case (posix-error-code c) 381 | (:einprogress 382 | nil) 383 | (:econnrefused 384 | (return-from connect-to-ipv4-tcp-server 385 | (make-instance 'failed-ipv4-tcp-stream 386 | :socket socket 387 | :remote-port port 388 | :remote-host-address host-address))) 389 | (t 390 | (error c))))) 391 | 392 | (cffi:with-foreign-object (sockaddr-in-length 'socklen-t) 393 | (setf (cffi:mem-ref sockaddr-in-length 'socklen-t) (cffi:foreign-type-size '(:struct sockaddr-in))) 394 | (%ff-getsockname (file-descriptor socket) sockaddr-in sockaddr-in-length)) 395 | 396 | (make-instance 'ipv4-tcp-stream 397 | :socket socket 398 | :local-port (port-from-sockaddr-in sockaddr-in) 399 | :local-host-address (host-address-from-sockaddr-in sockaddr-in) 400 | :remote-port port 401 | :remote-host-address host-address))))) 402 | 403 | ;;;; Resolving IPv4 addresses. 404 | (defun resolve-ipv4-address (hostname) 405 | (labels ((process (address-info) 406 | (assert (not (cffi:null-pointer-p address-info))) 407 | (assert (= (cffi:foreign-type-size '(:struct sockaddr-in)) 408 | (cffi:foreign-slot-value address-info '(:struct addrinfo) 'ai-addrlen))) 409 | (%ff-inet-ntoa (cffi:foreign-slot-value (cffi:foreign-slot-pointer (cffi:foreign-slot-value address-info '(:struct addrinfo) 'ai-addr) 410 | '(:struct sockaddr-in) 411 | 'sin-addr) 412 | '(:struct in-addr) 413 | 's-addr)))) 414 | (cffi:with-foreign-objects ((ptr-address-info :pointer) 415 | (hints '(:struct addrinfo))) 416 | (dotimes (i (cffi:foreign-type-size '(:struct addrinfo))) 417 | (setf (cffi:mem-aref hints :uint8 i) 0)) 418 | (cffi:with-foreign-slots ((ai-family ai-socktype ai-protocol) hints (:struct addrinfo)) 419 | (setf ai-family :pf-inet)) 420 | (let ((error-code (%ff-getaddrinfo hostname (cffi:null-pointer) hints ptr-address-info))) 421 | (cond 422 | ((zerop error-code) 423 | (unwind-protect 424 | (process (cffi:mem-ref ptr-address-info :pointer)) 425 | (%ff-freeaddrinfo (cffi:mem-ref ptr-address-info :pointer)))) 426 | ((or (= error-code (cffi:foreign-enum-value 'addrinfo-error-codes :eai-noname)) 427 | #+linux 428 | (= error-code (cffi:foreign-enum-value 'addrinfo-error-codes :eai-nodata))) 429 | nil) 430 | (t 431 | (error "Error resolving address ~A: ~A" hostname (%ff-gai-strerror error-code)))))))) 432 | 433 | ;; Local Sockets 434 | (defgeneric local-pathname (socket) 435 | (:documentation "The pathname to the local socket.")) 436 | 437 | (defgeneric delete-on-close-p (socket) 438 | (:documentation "Delete the pathname when closing the socket.")) 439 | 440 | ;; - Local Streams 441 | (defclass local-stream (posix-stream) 442 | ((local-pathname 443 | :initarg :local-pathname 444 | :reader local-pathname))) 445 | 446 | (defmethod print-object ((object local-stream) stream) 447 | (print-unreadable-object (object stream :type t :identity t) 448 | (format stream "~S" (local-pathname object)))) 449 | 450 | (defclass local-server (posix-stream-server) 451 | ((local-pathname 452 | :initarg :local-pathname 453 | :reader local-pathname) 454 | (delete-on-close-p 455 | :initarg :delete-on-close-p 456 | :reader delete-on-close-p))) 457 | 458 | (defmethod close-socket ((socket local-server)) 459 | (when (delete-on-close-p socket) 460 | (delete-file (local-pathname socket)))) 461 | 462 | (eval-when (:compile-toplevel :load-toplevel :execute) 463 | (defun do-with-sockaddr-un (function pathname) 464 | (let ((pathname (namestring pathname)) 465 | (maximum-pathname-length (or #+darwin 104 466 | #+freebsd 104 467 | #+linux 108 468 | #-(or darwin freebsd linux) 469 | (error "Maximum pathname length not specified for this operating system. Please inspect sys/un.h.")))) 470 | (assert (<= (+ maximum-pathname-length (cffi:foreign-type-size 'posix-socket-address-family)) 471 | (cffi:foreign-type-size '(:struct sockaddr-un)))) 472 | (unless (<= (1+ (length pathname)) maximum-pathname-length) 473 | (error "Pathname for local socket exceeds the allowable length of ~d characters." maximum-pathname-length)) 474 | (cffi:with-foreign-object (sockaddr-un '(:struct sockaddr-un)) 475 | (zero-memory sockaddr-un '(:struct sockaddr-un)) 476 | (setf (cffi:foreign-slot-value sockaddr-un '(:struct sockaddr-un) 'sun-family) :af-local) 477 | (let ((sun-name-ptr (cffi:foreign-slot-pointer sockaddr-un '(:struct sockaddr-un) 'sun-path))) 478 | (dotimes (i (length pathname)) 479 | (setf (cffi:mem-aref sun-name-ptr :char i) (char-code (elt pathname i))))) 480 | (funcall function sockaddr-un (+ (cffi:foreign-type-size 'posix-socket-address-family) 481 | (length pathname) 482 | 1))))) 483 | 484 | (defmacro with-sockaddr-un ((ptr-var length-var pathname) &body body) 485 | `(do-with-sockaddr-un #'(lambda (,ptr-var ,length-var) 486 | ,@body) 487 | ,pathname))) 488 | 489 | (defun make-local-server (pathname &key (backlog 5) (delete-on-close t)) 490 | (let ((socket (make-posix-socket :pf-local :sock-stream 0))) 491 | (setf (operating-modes socket) '(o-nonblock)) 492 | (with-accessors ((file-descriptor file-descriptor)) socket 493 | (posix-socket-initialisation-progn (socket) 494 | (with-sockaddr-un (sockaddr-un sockaddr-length pathname) 495 | (%ff-bind file-descriptor sockaddr-un sockaddr-length)) 496 | 497 | (alexandria:unwind-protect-case () 498 | (progn 499 | (%ff-listen file-descriptor backlog) 500 | (make-instance 'local-server 501 | :local-pathname pathname 502 | :socket socket 503 | :delete-on-close-p delete-on-close)) 504 | (:abort 505 | (delete-file pathname))))))) 506 | 507 | (defmethod connection-available-p ((server local-server)) 508 | (let ((results (poll-socket server 'connection-available-p :immediate))) 509 | (if results t nil))) 510 | 511 | (defmethod accept-connection ((server local-server)) 512 | (cffi:with-foreign-object (ptr '(:struct sockaddr-un)) 513 | (cffi:with-foreign-object (ptr-size 'socklen-t) 514 | (setf (cffi:mem-ref ptr-size 'socklen-t) (cffi:foreign-type-size '(:struct sockaddr-un))) 515 | (let* ((fd (handler-case (%ff-accept (file-descriptor (socket server)) ptr ptr-size) 516 | (posix-error (c) 517 | (if (posix-error-would-block-p c) 518 | (error 'no-connection-available-error :socket server) 519 | (error c))))) 520 | (socket (make-instance 'posix-socket 521 | :namespace (namespace (socket server)) 522 | :communication-style (communication-style (socket server)) 523 | :protocol (protocol (socket server)) 524 | :file-descriptor fd))) 525 | ;; This shouldn't be necessary but on some systems the socket 526 | ;; options are not inherited. 527 | (setf (operating-modes socket) '(o-nonblock)) 528 | (make-instance 'local-stream 529 | :socket socket 530 | :local-pathname (local-pathname server)))))) 531 | 532 | (define-condition no-local-server-error () 533 | ((local-pathname 534 | :initarg :local-pathname 535 | :reader local-pathname)) 536 | (:report (lambda (condition stream) 537 | (format stream "No local server exists at pathname ~S." (local-pathname condition))))) 538 | 539 | (defun connect-to-local-server (pathname &key) 540 | (let ((socket (make-posix-socket :pf-local :sock-stream 0))) 541 | (posix-socket-initialisation-progn (socket) 542 | (setf (operating-modes socket) '(o-nonblock)) 543 | 544 | ;; Connect to the host. 545 | (with-sockaddr-un (sockaddr-un sockaddr-length pathname) 546 | (handler-case (%ff-connect (file-descriptor socket) sockaddr-un sockaddr-length) 547 | (posix-error (c) 548 | (if (posix-error-code-p c :enoent) 549 | (error 'no-local-server-error :local-pathname pathname) 550 | (error c))))) 551 | 552 | (make-instance 'local-stream 553 | :socket socket 554 | :local-pathname pathname)))) 555 | --------------------------------------------------------------------------------