968 lines
32 KiB
Scheme
968 lines
32 KiB
Scheme
;;; Networking for the Scheme Shell
|
|
;;; Copyright (c) 1994-1995 by Brian D. Carlstrom.
|
|
;;; Copyright (c) 1994 by Olin Shivers.
|
|
|
|
;;; Scheme48 implementation.
|
|
|
|
(foreign-init-name "network")
|
|
|
|
(foreign-source
|
|
"#include <sys/types.h>"
|
|
"#include <sys/socket.h>"
|
|
""
|
|
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
|
"#include \"network1.h\""
|
|
""
|
|
"extern int errno;"
|
|
"extern int h_errno;"
|
|
""
|
|
"#define errno_on_zero_or_false(x) ((x) ? S48_FALSE : s48_enter_fixnum(errno))"
|
|
"#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
|
"#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)"
|
|
"" )
|
|
|
|
(define (byte-vector->integer bv)
|
|
(let ((number (byte-vector-ref bv 0)))
|
|
(set! number (bitwise-ior number (arithmetic-shift (byte-vector-ref bv 1)
|
|
8)))
|
|
(set! number (bitwise-ior number (arithmetic-shift (byte-vector-ref bv 2)
|
|
16)))
|
|
(bitwise-ior number (arithmetic-shift (byte-vector-ref bv 3)
|
|
24))))
|
|
|
|
(define (integer->byte-vector number)
|
|
(let ((bv (make-byte-vector 4 0)))
|
|
(byte-vector-set! bv 0 (bitwise-and number #xff))
|
|
(byte-vector-set! bv 1 (bitwise-and (arithmetic-shift number -8) #xff))
|
|
(byte-vector-set! bv 2 (bitwise-and (arithmetic-shift number -16) #xff))
|
|
(byte-vector-set! bv 3 (bitwise-and (arithmetic-shift number -24) #xff))
|
|
bv))
|
|
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; High Level Prototypes
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
|
|
(define (socket-connect protocol-family socket-type . args)
|
|
(let* ((sock (create-socket protocol-family
|
|
socket-type))
|
|
(addr (cond ((= protocol-family
|
|
protocol-family/internet)
|
|
(let* ((host (car args))
|
|
(port (cadr args))
|
|
(host (car (host-info:addresses
|
|
(name->host-info host))))
|
|
(port (cond ((integer? port) port)
|
|
((string? port)
|
|
(service-info:port
|
|
(service-info (cadr args) "tcp")))
|
|
(else
|
|
(error
|
|
"socket-connect: bad arg ~s"
|
|
args)))))
|
|
(internet-address->socket-address host port)))
|
|
((= protocol-family
|
|
protocol-family/unix)
|
|
(unix-address->socket-address (car args)))
|
|
(else
|
|
(error "socket-connect: unsupported protocol-family ~s"
|
|
protocol-family)))))
|
|
;; Close the socket and free the file-descriptors
|
|
;; if the connect fails:
|
|
(let ((connected #f))
|
|
(dynamic-wind
|
|
(lambda () #f)
|
|
(lambda () (connect-socket sock addr) (set! connected #t))
|
|
(lambda () #f
|
|
;(if (not connected)
|
|
; (close-socket sock))
|
|
))
|
|
(if connected
|
|
sock
|
|
#f))))
|
|
|
|
(define (bind-listen-accept-loop protocol-family proc arg)
|
|
(let* ((sock (create-socket protocol-family socket-type/stream))
|
|
(addr (cond ((= protocol-family
|
|
protocol-family/internet)
|
|
(let ((port (cond ((integer? arg) arg)
|
|
((string? arg)
|
|
(service-info:port
|
|
(service-info arg "tcp")))
|
|
(else
|
|
(error "socket-connect: bad arg ~s"
|
|
arg)))))
|
|
(internet-address->socket-address internet-address/any
|
|
arg)))
|
|
((= protocol-family
|
|
protocol-family/unix)
|
|
(unix-address->socket-address arg))
|
|
(else
|
|
(error "bind-listen-accept-loop: unsupported protocol-family ~s"
|
|
protocol-family)))))
|
|
(set-socket-option sock level/socket socket/reuse-address #t)
|
|
(bind-socket sock addr)
|
|
(listen-socket sock 5)
|
|
(let loop ()
|
|
(call-with-values
|
|
(lambda () (accept-connection sock))
|
|
proc)
|
|
(loop))))
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; Socket Record Structure
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define-record socket
|
|
family ; protocol family
|
|
inport ; input port
|
|
outport) ; output port
|
|
|
|
(define-record socket-address
|
|
family ; address family
|
|
address) ; address
|
|
|
|
;;; returns the fdes of a socket
|
|
;;; not exported
|
|
(define (socket->fdes sock)
|
|
(fdport-data:fd (port-data (socket:inport sock))))
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; Socket Address Routines
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (internet-host-address-from-number address32)
|
|
(integer->byte-vector address32))
|
|
|
|
(define (internet-host-address-from-bytes b4 b3 b2 b1)
|
|
(let ((bv (make-byte-vector 4 0)))
|
|
(byte-vector-set! bv 0 b1)
|
|
(byte-vector-set! bv 1 b2)
|
|
(byte-vector-set! bv 2 b3)
|
|
(byte-vector-set! bv 3 b4)
|
|
bv))
|
|
|
|
(define (internet-host-address-to-bytes address)
|
|
(list (byte-vector-ref address 3)
|
|
(byte-vector-ref address 2)
|
|
(byte-vector-ref address 1)
|
|
(byte-vector-ref address 0)))
|
|
|
|
;;; This proc and its inverse should be in a general IP module.
|
|
(define (internet-host-address->dotted-string bv)
|
|
(let* ((byte0 (byte-vector-ref bv 0))
|
|
(byte1 (byte-vector-ref bv 1))
|
|
(byte2 (byte-vector-ref bv 2))
|
|
(byte3 (byte-vector-ref bv 3)))
|
|
(string-append (number->string byte3) "." (number->string byte2) "."
|
|
(number->string byte1) "." (number->string byte0))))
|
|
|
|
(define (internet-host-address-to-number address)
|
|
(byte-vector->integer address))
|
|
|
|
(set! internet-address/any
|
|
(internet-host-address-from-number internet-address/any ))
|
|
(set! internet-address/loopback
|
|
(internet-host-address-from-number internet-address/loopback ))
|
|
(set! internet-address/broadcast
|
|
(internet-host-address-from-number internet-address/broadcast ))
|
|
|
|
(define (internet-address->socket-address address32 port16)
|
|
(cond ((not (and (byte-vector? address32)
|
|
(= (byte-vector-length address32) 4)))
|
|
(error "internet-address->socket-address: address out of range ~s"
|
|
address32))
|
|
((not (<= 0 port16 #xffff))
|
|
(error "internet-address->socket-address: port out of range ~s"
|
|
port16))
|
|
(else
|
|
(make-socket-address address-family/internet
|
|
(cons address32 port16)))))
|
|
|
|
(define (socket-address->internet-address sockaddr)
|
|
(if (or (not (socket-address? sockaddr))
|
|
(not (= (socket-address:family sockaddr)
|
|
address-family/internet)))
|
|
(error "socket-address->internet-address: internet socket expected ~s"
|
|
sockaddr)
|
|
(values (car (socket-address:address sockaddr))
|
|
(cdr (socket-address:address sockaddr)))))
|
|
|
|
(define (unix-address->socket-address path)
|
|
(if (> (string-length path) 108)
|
|
(error "unix-address->socket-address: path too long ~s" path)
|
|
(make-socket-address address-family/unix path)))
|
|
|
|
(define (socket-address->unix-address sockaddr)
|
|
(if (or (not (socket-address? sockaddr))
|
|
(not (= (socket-address:family sockaddr)
|
|
address-family/unix)))
|
|
(error "socket-address->unix-address expects an unix socket ~s" sockaddr)
|
|
(socket-address:address sockaddr)))
|
|
|
|
(define (make-addr af)
|
|
(make-string (cond ((= af address-family/unix) 108)
|
|
((= af address-family/internet) 8)
|
|
(else
|
|
(error "make-addr: unknown address-family ~s" af)))))
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; socket syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (create-socket pf type . maybe-protocol)
|
|
(let ((protocol (:optional maybe-protocol 0)))
|
|
(if (not (and (integer? pf)
|
|
(integer? type)
|
|
(integer? protocol)))
|
|
(error "create-socket: integer arguments expected ~s ~s ~s"
|
|
pf type protocol)
|
|
(let* ((fd (%socket pf type protocol))
|
|
(in (make-input-fdport fd 0))
|
|
(out (dup->outport in)))
|
|
(set-fdes-status in open/non-blocking)
|
|
(set-fdes-status out open/non-blocking)
|
|
(make-socket pf in out)))))
|
|
|
|
|
|
;;; Turn a file descriptor into a socket.
|
|
;;; Useful if running as inetd-child
|
|
|
|
(define (fd->socket fd pf)
|
|
(let* ((in (make-input-fdport fd 0))
|
|
(out (dup->outport in)))
|
|
(set-fdes-status fd open/non-blocking) ; this raises an error if fd was not
|
|
; a socket
|
|
(set-fdes-status out open/non-blocking)
|
|
(make-socket pf in out)))
|
|
|
|
(define-foreign %socket/errno
|
|
(socket (fixnum pf)
|
|
(fixnum type)
|
|
(fixnum protocol))
|
|
(multi-rep (to-scheme fixnum errno_or_false)
|
|
fixnum))
|
|
|
|
(define-errno-syscall (%socket pf type protocol) %socket/errno
|
|
sockfd)
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; close syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (close-socket sock)
|
|
(close (socket:inport sock))
|
|
(close (socket:outport sock)))
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; bind syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (bind-socket sock name)
|
|
(cond ((not (socket? sock))
|
|
(error "bind-socket: socket expected ~s" sock))
|
|
((not (socket-address? name))
|
|
(error "bind-socket: socket-address expected ~s" name))
|
|
(else
|
|
(let ((family (socket:family sock)))
|
|
(if (not (= family (socket-address:family name)))
|
|
(error
|
|
"bind-socket: trying to bind incompatible address to socket ~s"
|
|
name)
|
|
(%bind (socket->fdes sock)
|
|
family
|
|
(socket-address:address name)))))))
|
|
|
|
(define-stubless-foreign %bind (sockfd family name) "scheme_bind")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; connect syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (connect-socket sock name)
|
|
(cond ((not (socket? sock))
|
|
(error "connect-socket: socket expected ~s" sock))
|
|
((not (socket-address? name))
|
|
(error "connect-socket: socket-address expected ~s" name))
|
|
(else
|
|
(let ((family (socket:family sock)))
|
|
(cond ((not (= family (socket-address:family name)))
|
|
(error
|
|
"connect: trying to connect socket to incompatible address ~s"
|
|
name))
|
|
(else
|
|
(let loop ()
|
|
((structure-ref interrupts disable-interrupts!))
|
|
(let ((res (%connect (socket->fdes sock)
|
|
(socket:family sock)
|
|
(socket-address:address name))))
|
|
(cond ((eq? res #t)
|
|
((structure-ref interrupts enable-interrupts!)))
|
|
(else (wait-for-channel
|
|
(fdport-data:channel
|
|
(fdport-data (socket:inport sock))))
|
|
(if (eq? res 0)
|
|
(handle-EINPROGRESS sock)
|
|
(loop))))))))))))
|
|
|
|
;;; If connect returned EINPROGRESS, we can check it's success after
|
|
;;; the next success with getsockopt
|
|
|
|
(define (handle-EINPROGRESS sock)
|
|
(let ((val (socket-option sock level/socket socket/error)))
|
|
(if (not (zero? val))
|
|
(errno-error val "scheme_connect"))))
|
|
|
|
(define-stubless-foreign %connect (sockfd family name) "scheme_connect")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; listen syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (listen-socket sock backlog)
|
|
(cond ((not (socket? sock))
|
|
(error "listen-socket: socket expected ~s" sock))
|
|
((not (integer? backlog))
|
|
(error "listen-socket: integer expected ~s" backlog))
|
|
(else
|
|
(%listen (socket->fdes sock) backlog))))
|
|
|
|
(define-foreign %listen/errno
|
|
(listen (fixnum sockfd) ; socket fdes
|
|
(fixnum backlog)) ; backlog
|
|
no-declare ; for Linux
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (%listen sockfd backlog) %listen/errno)
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; accept syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (accept-connection sock)
|
|
(if (not (socket? sock))
|
|
(error "accept-connection: socket expected ~s" sock)
|
|
(let ((family (socket:family sock)))
|
|
(let loop ()
|
|
((structure-ref interrupts disable-interrupts!))
|
|
(let ((fd-addr (%accept (socket->fdes sock) family)))
|
|
(cond ((pair? fd-addr)
|
|
(let ((fd (car fd-addr))
|
|
(addr (cdr fd-addr)))
|
|
((structure-ref interrupts
|
|
enable-interrupts!))
|
|
(let* ((in (make-input-fdport fd 0))
|
|
(out (dup->outport in)))
|
|
(values (make-socket family in out)
|
|
(make-socket-address family addr)))))
|
|
(else (wait-for-channel
|
|
(fdport-data:channel
|
|
(fdport-data (socket:inport sock))))
|
|
(loop))))))))
|
|
|
|
(define-stubless-foreign %accept (sockfd family) "scheme_accept")
|
|
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; getpeername syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (socket-remote-address sock)
|
|
(if (or (not (socket? sock))
|
|
(not (= (socket:family sock) address-family/internet)))
|
|
(error "socket-remote-address: internet socket expected ~s" sock)
|
|
(let* ((family (socket:family sock))
|
|
(addr (%peer-name (socket->fdes sock)
|
|
family)))
|
|
(make-socket-address family addr))))
|
|
|
|
(define-stubless-foreign %peer-name (sockfd family) "scheme_peer_name")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; getsockname syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (socket-local-address sock)
|
|
(if (or (not (socket? sock))
|
|
(not (= (socket:family sock) address-family/internet)))
|
|
(error "socket-local-address: internet socket expected ~s" sock)
|
|
(let* ((family (socket:family sock))
|
|
(addr (%socket-name (socket->fdes sock) family)))
|
|
(make-socket-address family addr))))
|
|
|
|
(define-stubless-foreign %socket-name (sockfd family) "scheme_socket_name")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; shutdown syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (shutdown-socket sock how)
|
|
(cond ((not (socket? sock))
|
|
(error "shutdown-socket: socket expected ~s" sock))
|
|
((not (integer? how))
|
|
(error "shutdown-socket: integer expected ~s" how))
|
|
(else
|
|
(%shutdown (socket->fdes sock) how))))
|
|
|
|
(define-foreign %shutdown/errno
|
|
(shutdown (fixnum sockfd)
|
|
(fixnum how))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall
|
|
(%shutdown sock how) %shutdown/errno)
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; socketpair syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (create-socket-pair type)
|
|
(if (not (integer? type))
|
|
(error "create-socket-pair: integer argument expected ~s" type)
|
|
(receive (s1 s2)
|
|
(%socket-pair type)
|
|
(let* ((in1 (make-input-fdport s1 0))
|
|
(out1 (dup->outport in1))
|
|
(in2 (make-input-fdport s2 0))
|
|
(out2 (dup->outport in2)))
|
|
(values (make-socket protocol-family/unix in1 out1)
|
|
(make-socket protocol-family/unix in2 out2))))))
|
|
|
|
;; based on pipe in syscalls.scm
|
|
(define-foreign %socket-pair/errno
|
|
(scheme_socket_pair (fixnum type))
|
|
(to-scheme fixnum errno_or_false)
|
|
fixnum
|
|
fixnum)
|
|
|
|
(define-errno-syscall
|
|
(%socket-pair type) %socket-pair/errno
|
|
sockfd1
|
|
sockfd2)
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; recv syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define (receive-message socket len . maybe-flags)
|
|
(let ((flags (:optional maybe-flags 0)))
|
|
(cond ((not (socket? socket))
|
|
(error "receive-message: socket expected ~s" socket))
|
|
((or (not (integer? flags))
|
|
(not (integer? len)))
|
|
(error "receive-message: integer expected ~s ~s" flags len))
|
|
(else
|
|
(let ((s (make-string len)))
|
|
(receive (nread from)
|
|
(receive-message! socket s 0 len flags)
|
|
(values
|
|
(cond ((not nread) #f) ; EOF
|
|
((= nread len) s)
|
|
(else (substring s 0 nread)))
|
|
from)))))))
|
|
|
|
(define (receive-message! socket s . args)
|
|
(if (not (string? s))
|
|
(error "receive-message!: string expected ~s" s)
|
|
(let-optionals args ((start 0) (end (string-length s)) (flags 0))
|
|
(cond ((not (socket? socket))
|
|
(error "receive-message!: socket expected ~s" socket))
|
|
((not (or (integer? flags)
|
|
(integer? start)
|
|
(integer? end)))
|
|
(error "receive-message!: integer expected ~s ~s ~s"
|
|
flags start end))
|
|
(else
|
|
(generic-receive-message! socket flags
|
|
s start end
|
|
recv-substring!
|
|
(socket:family socket)))))))
|
|
|
|
(define (generic-receive-message! socket flags s start end reader family)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices"
|
|
reader socket flags
|
|
s start end family))
|
|
(let loop ((i start) (remote #f))
|
|
(if (>= i end)
|
|
(values (- i start) (make-socket-address family remote))
|
|
(let* ((res (reader socket flags s i end)))
|
|
(apply (lambda (nread from)
|
|
(cond ((zero? nread) ; EOF
|
|
(values
|
|
(let ((result (- i start)))
|
|
(and (not (zero? result)) result))
|
|
(make-socket-address family from)))
|
|
(else (loop (+ i nread) from))))
|
|
res)))))
|
|
|
|
(define (receive-message/partial socket len . maybe-flags)
|
|
(let ((flags (:optional maybe-flags 0)))
|
|
(cond ((not (socket? socket))
|
|
(error "receive-message/partial: socket expected ~s" socket))
|
|
((or (not (integer? flags))
|
|
(not (integer? len)))
|
|
(error "receive-message/partial: integer expected ~s ~s" flags len))
|
|
(else
|
|
(let ((s (make-string len)))
|
|
(receive (nread addr)
|
|
(receive-message!/partial socket s 0 len flags)
|
|
(values
|
|
(cond ((not nread) #f) ; EOF
|
|
((= nread len) s)
|
|
(else (substring s 0 nread)))
|
|
addr)))))))
|
|
|
|
(define (receive-message!/partial socket s . args)
|
|
(if (not (string? s))
|
|
(error "receive-message!/partial: string expected ~s" s)
|
|
(let-optionals args ((start 0) (end (string-length s)) (flags 0))
|
|
(cond ((not (socket? socket))
|
|
(error "receive-message!/partial: socket expected ~s"
|
|
socket))
|
|
((not (integer? flags))
|
|
(error "receive-message!/partial: integer expected ~s"
|
|
flags))
|
|
(else
|
|
(generic-receive-message!/partial socket
|
|
flags
|
|
s start end
|
|
recv-substring!
|
|
(socket:family socket)))))))
|
|
|
|
(define (generic-receive-message!/partial socket flags s start end reader from)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices" reader s start end))
|
|
|
|
(if (= start end) 0 ; Vacuous request.
|
|
(let loop ()
|
|
(apply (lambda (nread addr)
|
|
(values (and (not (zero? nread)) nread)
|
|
(make-socket-address from addr)))
|
|
(reader socket flags s start end)))))
|
|
|
|
|
|
(define (recv-substring! socket flags buf start end)
|
|
(let loop ()
|
|
((structure-ref interrupts disable-interrupts!))
|
|
(let ((maybe-size-addr
|
|
(%recv-substring! (socket->fdes socket)
|
|
flags buf start end)))
|
|
(cond (maybe-size-addr
|
|
((structure-ref interrupts
|
|
enable-interrupts!))
|
|
maybe-size-addr)
|
|
(else (wait-for-channel
|
|
(fdport-data:channel
|
|
(fdport-data (socket:inport socket))))
|
|
(loop))))))
|
|
|
|
(define-stubless-foreign %recv-substring! (sockfd flags buf start end)
|
|
"recv_substring")
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; send syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
|
|
(define (send-message socket s . args)
|
|
(let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f))
|
|
(cond ((not (socket? socket))
|
|
(error "send-message: socket expected ~s" socket))
|
|
((not (integer? flags))
|
|
(error "send-message: integer expected ~s" flags))
|
|
((not (string? s))
|
|
(error "send-message: string expected ~s" s))
|
|
(else
|
|
(generic-send-message socket flags
|
|
s start end
|
|
send-substring
|
|
(if addr (socket-address:family addr) 0)
|
|
(if addr (socket-address:address addr) #f))))))
|
|
|
|
(define (generic-send-message socket flags s start end writer family addr)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices"
|
|
socket flags family addr
|
|
s start end writer))
|
|
|
|
(let loop ((i start))
|
|
(if (< i end)
|
|
(loop (+ i (writer socket flags s i end family addr))))))
|
|
|
|
|
|
(define (send-message/partial socket s . args)
|
|
(let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f))
|
|
(cond ((not (socket? socket))
|
|
(error "send-message/partial: socket expected ~s" socket))
|
|
((not (integer? flags))
|
|
(error "send-message/partial: integer expected ~s" flags))
|
|
((not (string? s))
|
|
(error "send-message/partial: string expected ~s" s))
|
|
(else
|
|
(generic-send-message/partial socket flags
|
|
s start end
|
|
send-substring
|
|
(if addr (socket-address:family addr) 0)
|
|
(if addr
|
|
(socket-address:address addr)
|
|
#f))))))
|
|
|
|
(define (generic-send-message/partial socket flags s start end writer family
|
|
addr)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices"
|
|
socket flags family addr
|
|
s start end writer))
|
|
(if (= start end)
|
|
0 ; Vacuous request.
|
|
(writer socket flags s start end family addr)))
|
|
|
|
(define (send-substring socket flags buf start end family name)
|
|
(let loop ()
|
|
((structure-ref interrupts disable-interrupts!))
|
|
(cond ((%send-substring (socket->fdes socket) flags buf start end
|
|
family name)
|
|
=> (lambda (nwritten)
|
|
((structure-ref interrupts
|
|
enable-interrupts!))
|
|
nwritten))
|
|
(else (wait-for-channel
|
|
(fdport-data:channel
|
|
(fdport-data (socket:inport socket))))
|
|
(loop)))))
|
|
|
|
(define-stubless-foreign
|
|
%send-substring (sockfd flags buf start end family name)
|
|
"send_substring")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; getsockopt syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
|
|
(define (socket-option sock level option)
|
|
(cond ((not (socket? sock))
|
|
(error "socket-option: socket expected ~s" sock))
|
|
((or (not (integer? level))(not (integer? option)))
|
|
(error "socket-option: integer expected ~s ~s" level option))
|
|
((boolean-option? option)
|
|
(let ((result (%getsockopt (socket->fdes sock) level option)))
|
|
(cond ((= result -1)
|
|
(error "socket-option ~s ~s ~s" sock level option))
|
|
(else (not (= result 0))))))
|
|
((value-option? option)
|
|
(let ((result (%getsockopt (socket->fdes sock) level option)))
|
|
(cond ((= result -1)
|
|
(error "socket-option ~s ~s ~s" sock level option))
|
|
(else result))))
|
|
((linger-option? option)
|
|
(receive (result/on-off time)
|
|
(%getsockopt-linger (socket->fdes sock) level option)
|
|
(cond ((= result/on-off -1)
|
|
(error "socket-option ~s ~s ~s" sock level option))
|
|
(else (if (= result/on-off 0) #f time)))))
|
|
((timeout-option? option)
|
|
(receive (result/secs usecs)
|
|
(%getsockopt-linger (socket->fdes sock) level option)
|
|
(cond ((= result/secs -1)
|
|
(error "socket-option ~s ~s ~s" sock level option))
|
|
(else (+ result/secs (/ usecs 1000))))))
|
|
(else
|
|
"socket-option: unknown option type ~s" option)))
|
|
|
|
(define-foreign %getsockopt/errno
|
|
(scheme_getsockopt (fixnum sockfd)
|
|
(fixnum level)
|
|
(fixnum optname))
|
|
(multi-rep (to-scheme fixnum errno_or_false)
|
|
fixnum))
|
|
|
|
(define-errno-syscall (%getsockopt sock level option) %getsockopt/errno
|
|
value)
|
|
|
|
(define-foreign %getsockopt-linger/errno
|
|
(scheme_getsockopt_linger (fixnum sockfd)
|
|
(fixnum level)
|
|
(fixnum optname))
|
|
(multi-rep (to-scheme fixnum errno_or_false)
|
|
fixnum) ; error/on-off
|
|
fixnum) ; linger time
|
|
|
|
(define-errno-syscall
|
|
(%getsockopt-linger sock level option) %getsockopt-linger/errno
|
|
on-off
|
|
linger)
|
|
|
|
(define-foreign %getsockopt-timeout/errno
|
|
(scheme_getsockopt_timeout (fixnum sockfd)
|
|
(fixnum level)
|
|
(fixnum optname))
|
|
(multi-rep (to-scheme fixnum errno_or_false)
|
|
fixnum) ; error/secs
|
|
fixnum) ; usecs
|
|
|
|
(define-errno-syscall
|
|
(%getsockopt-timeout sock level option) %getsockopt-timeout/errno
|
|
secs
|
|
usecs)
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; setsockopt syscall
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
|
|
(define (set-socket-option sock level option value)
|
|
(cond ((not (socket? sock))
|
|
(error "set-socket-option: socket expected ~s" sock))
|
|
((or (not (integer? level)) (not (integer? option)))
|
|
(error "set-socket-option: integer expected ~s ~s" level option))
|
|
((boolean-option? option)
|
|
(%setsockopt (socket->fdes sock) level option (if value 1 0)))
|
|
((value-option? option)
|
|
(%setsockopt (socket->fdes sock) level option value))
|
|
((linger-option? option)
|
|
(%setsockopt-linger (socket->fdes sock)
|
|
level option
|
|
(if value 1 0)
|
|
(if value value 0)))
|
|
((timeout-option? option)
|
|
(let ((secs (truncate value)))
|
|
(%setsockopt-timeout (socket->fdes sock) level option
|
|
secs
|
|
(truncate (* (- value secs) 1000)))))
|
|
(else
|
|
"set-socket-option: unknown option type")))
|
|
|
|
(define-foreign %setsockopt/errno
|
|
(scheme_setsockopt (fixnum sockfd)
|
|
(fixnum level)
|
|
(fixnum optname)
|
|
(fixnum optval))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall
|
|
(%setsockopt sock level option value) %setsockopt/errno)
|
|
|
|
|
|
(define-foreign %setsockopt-linger/errno
|
|
(scheme_setsockopt_linger (fixnum sockfd)
|
|
(fixnum level)
|
|
(fixnum optname)
|
|
(fixnum on-off)
|
|
(fixnum time))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall
|
|
(%setsockopt-linger sock level option on-off time) %setsockopt-linger/errno)
|
|
|
|
(define-foreign %setsockopt-timeout/errno
|
|
(scheme_setsockopt_timeout (fixnum sockfd)
|
|
(fixnum level)
|
|
(fixnum optname)
|
|
(fixnum secs)
|
|
(fixnum usecs))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall
|
|
(%setsockopt-timeout sock level option secs usecs) %setsockopt-timeout/errno)
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; socket-option routines
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
|
|
(define (boolean-option? opt)
|
|
(member opt options/boolean))
|
|
|
|
(define (value-option? opt)
|
|
(member opt options/value))
|
|
|
|
(define (linger-option? opt)
|
|
(member opt options/linger))
|
|
|
|
(define (timeout-option? opt)
|
|
(member opt options/timeout))
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; host lookup
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define-record host-info
|
|
name ; Host name
|
|
aliases ; Alternative names
|
|
addresses ; Host addresses
|
|
|
|
((disclose hi) ; Make host-info records print like
|
|
(list "host" (host-info:name hi)))) ; #{host clark.lcs.mit.edu}.
|
|
|
|
(define-exported-binding "host-info-type" type/host-info)
|
|
|
|
(define (host-info arg)
|
|
(cond ((string? arg) (name->host-info arg))
|
|
((socket-address? arg) (address->host-info arg))
|
|
(else (error "host-info: string or socket-address expected ~s" arg))))
|
|
|
|
(define (address->host-info name)
|
|
(if (or (not (socket-address? name))
|
|
(not (= (socket-address:family name) address-family/internet)))
|
|
(error "address->host-info: internet address expected ~s" name)
|
|
(let ((res (%host-address->host-info/h-errno
|
|
(socket-address:address name))))
|
|
(if (number? res)
|
|
(error "address->host-info: non-zero herrno ~s ~s" res name)
|
|
res))))
|
|
|
|
(define-stubless-foreign %host-address->host-info/h-errno (name)
|
|
"scheme_host_address2host_info")
|
|
|
|
(define (name->host-info name)
|
|
(if (not (string? name))
|
|
(error "name->host-info: string expected ~s" name)
|
|
(let ((res (%host-name->host-info/h-errno name)))
|
|
(if (number? res)
|
|
(error "name->host-info: non-zero herrno ~s ~s" res name)
|
|
res))))
|
|
|
|
(define-stubless-foreign %host-name->host-info/h-errno (name)
|
|
"scheme_host_name2host_info")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; network lookup
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define-record network-info
|
|
name ; Network name
|
|
aliases ; Alternative names
|
|
net) ; Network number
|
|
|
|
(define-exported-binding "network-info-type" type/network-info)
|
|
|
|
(define (network-info arg)
|
|
(cond ((string? arg) (name->network-info arg))
|
|
((socket-address? arg) (car (socket-address:address arg)))
|
|
(else
|
|
(error "network-info: string or socket-address expected ~s" arg))))
|
|
|
|
(define (address->network-info addr)
|
|
(if (not (byte-vector? addr))
|
|
(error "address->network-info: byte-vector expected ~s" addr)
|
|
(%net-address->network-info addr)))
|
|
|
|
(define-stubless-foreign %net-address->network-info (addr)
|
|
"scheme_net_address2net_info")
|
|
|
|
(define (name->network-info name)
|
|
(if (not (string? name))
|
|
(error "name->network-info: string expected ~s" name)
|
|
(%net-name->network-info name)))
|
|
|
|
(define-stubless-foreign %net-name->network-info (name)
|
|
"scheme_net_name2net_info")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; service lookup
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define-record service-info
|
|
name ; Service name
|
|
aliases ; Alternative names
|
|
port ; Port number
|
|
protocol) ; Protocol name
|
|
|
|
(define-exported-binding "service-info-type" type/service-info)
|
|
|
|
(define (service-info . args)
|
|
(apply (cond ((string? (car args)) name->service-info)
|
|
((integer? (car args)) port->service-info)
|
|
(else (error "service-info: string or integer expected ~s" args)))
|
|
args))
|
|
|
|
(define (port->service-info name . maybe-proto)
|
|
(let ((proto (:optional maybe-proto "")))
|
|
(cond ((not (integer? name))
|
|
(error "port->service-info: integer expected ~s" name))
|
|
((not (string? proto))
|
|
(error "port->service-info: string expected ~s" proto))
|
|
(else
|
|
(%service-port->service-info name (if (equal? "" proto)
|
|
#f
|
|
proto))))))
|
|
|
|
(define-stubless-foreign %service-port->service-info (port proto)
|
|
"scheme_serv_port2serv_info")
|
|
|
|
(define (name->service-info name . maybe-proto)
|
|
(let ((proto (:optional maybe-proto "")))
|
|
(cond ((not (string? name))
|
|
(error "name->service-info: integer expected ~s" name))
|
|
((not (string? proto))
|
|
(error "name->service-info: string expected ~s" proto))
|
|
(else
|
|
(%service-name->service-info name (if (equal? "" proto)
|
|
#f
|
|
proto))))))
|
|
|
|
(define-stubless-foreign %service-name->service-info (name proto)
|
|
"scheme_serv_name2serv_info")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; protocol lookup
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
(define-record protocol-info
|
|
name ; Protocol name
|
|
aliases ; Alternative names
|
|
number) ; Protocol number
|
|
|
|
(define-exported-binding "protocol-info-type" type/protocol-info)
|
|
|
|
(define (protocol-info arg)
|
|
(cond ((string? arg) (name->protocol-info arg))
|
|
((integer? arg) (number->protocol-info arg))
|
|
(else (error "protocol-info: string or integer expected ~s" arg))))
|
|
|
|
(define (number->protocol-info name)
|
|
(if (not (integer? name))
|
|
(error "number->protocol-info: integer expected ~s" name)
|
|
(%protocol-port->protocol-info name)))
|
|
|
|
(define-stubless-foreign %protocol-port->protocol-info (name)
|
|
"scheme_proto_num2proto_info")
|
|
|
|
(define (name->protocol-info name)
|
|
(if (not (string? name))
|
|
(error "name->protocol-info: string expected ~s" name)
|
|
(%protocol-name->protocol-info name)))
|
|
|
|
(define-stubless-foreign %protocol-name->protocol-info (name)
|
|
"scheme_proto_name2proto_info")
|
|
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;;; Lowlevel junk
|
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
;; Used to pull address list back
|
|
;; based on C-string-vec->Scheme from cig/libcig.scm
|
|
(define (C-long-vec->Scheme cvec veclen) ; No free.
|
|
(let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
|
|
(mapv! (lambda (ignore) (make-string 4)) vec)
|
|
(%set-long-vector-carriers! vec cvec)
|
|
(mapv! string->integer vec)))
|
|
|
|
(define (integer->string num32)
|
|
(let* ((str (make-string 4))
|
|
(num24 (arithmetic-shift num32 -8))
|
|
(num16 (arithmetic-shift num24 -8))
|
|
(num08 (arithmetic-shift num16 -8))
|
|
(byte0 (bitwise-and #b11111111 num08))
|
|
(byte1 (bitwise-and #b11111111 num16))
|
|
(byte2 (bitwise-and #b11111111 num24))
|
|
(byte3 (bitwise-and #b11111111 num32)))
|
|
(string-set! str 0 (ascii->char byte0))
|
|
(string-set! str 1 (ascii->char byte1))
|
|
(string-set! str 2 (ascii->char byte2))
|
|
(string-set! str 3 (ascii->char byte3))
|
|
str))
|
|
|
|
(define (string->integer str)
|
|
(+ (arithmetic-shift(char->ascii(string-ref str 0))24)
|
|
(arithmetic-shift(char->ascii(string-ref str 1))16)
|
|
(arithmetic-shift(char->ascii(string-ref str 2)) 8)
|
|
(char->ascii(string-ref str 3))))
|
|
|
|
;; also from cig/libcig.scm
|
|
(define-foreign %c-veclen-or-false
|
|
(veclen ((C "const long * ~a") c-vec)); redefining can we open cig-aux?
|
|
desc) ; integer or #f if arg is NULL.
|
|
|
|
;; also from cig/libcig.scm
|
|
(define-foreign %set-long-vector-carriers!
|
|
(set_longvec_carriers (vector-desc svec)
|
|
((C "long const * const * ~a") cvec))
|
|
ignore)
|
|
|
|
;; also from cig/libcig.scm
|
|
(define (mapv! f v)
|
|
(let ((len (vector-length v)))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i len) v)
|
|
(vector-set! v i (f (vector-ref v i))))))
|