;;; 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)"
"" )
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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 ()
(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-address->socket-address address32 port16)
(cond ((not (<= 0 address32 #xffffffff))
(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
(string-append (integer->string address32)
(integer->string 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 (string->integer (substring (socket-address:address sockaddr)
0 4))
(string->integer (substring (socket-address:address sockaddr)
4 8)))))
(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)))
(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-foreign %bind/errno
(scheme_bind (fixnum sockfd) ; socket fdes
(fixnum family) ; address family
(string-desc name)) ; scheme descriptor
(to-scheme fixnum errno_or_false))
(define-errno-syscall (%bind sockfd family name) %bind/errno)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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
(%connect (socket->fdes sock)
(socket:family sock)
(socket-address:address name))))))))
(define-foreign %connect/errno
(scheme_connect (fixnum sockfd) ; socket fdes
(fixnum family) ; address family
(desc name)) ; scheme descriptor
(to-scheme fixnum errno_or_false))
(define-errno-syscall (%connect sockfd family name) %connect/errno)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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))
(name (make-addr family))
(fd (%accept (socket->fdes sock) family name))
(in (make-input-fdport fd 0))
(out (dup->outport in)))
(values (make-socket family in out)
(make-socket-address family name)))))
(define-foreign %accept/errno
(scheme_accept (fixnum sockfd)
(fixnum family)
(string-desc name))
(multi-rep (to-scheme fixnum errno_or_false)
fixnum))
(define-errno-syscall (%accept sock family name) %accept/errno
sockfd)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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))
(name (make-addr family)))
(%peer-name (socket->fdes sock)
family
name)
(make-socket-address family name))))
(define-foreign %peer-name/errno
(scheme_peer_name (fixnum sockfd)
(fixnum family)
(string-desc name))
(to-scheme fixnum errno_or_false))
(define-errno-syscall (%peer-name sock family name) %peer-name/errno)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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))
(name (make-addr family)))
(%socket-name (socket->fdes sock)
family
name)
(make-socket-address family name))))
(define-foreign %socket-name/errno
(scheme_socket_name (fixnum sockfd)
(fixnum family)
(string-desc name))
(to-scheme fixnum "False_on_zero"))
(define-errno-syscall
(%socket-name sock family name) %socket-name/errno)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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->fdes socket) flags
s start end
recv-substring!/errno
(socket:family socket)))))))
(define (generic-receive-message! sockfd flags s start end reader from)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices"
reader sockfd flags
s start end from))
(let ((addr (make-addr from)))
(let loop ((i start))
(if (>= i end) (- i start)
(receive (err nread)
(reader sockfd flags s i end addr)
(cond (err (if (= err errno/intr) (loop i)
;; Give info on partially-read data in error packet.
(errno-error err reader sockfd flags
s start i end addr)))
((zero? nread) ; EOF
(values
(let ((result (- i start)))
(and (not (zero? result)) result))
from))
(else (loop (+ i nread)))))))))
(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->fdes socket)
flags
s start end
recv-substring!/errno
(socket:family socket)))))))
(define (generic-receive-message!/partial sockfd 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 ((addr (make-addr from)))
(let loop ()
(receive (err nread)
(reader sockfd flags s start end addr)
(cond ((not err)
(values (and (not (zero? nread)) nread)
(make-socket-address from addr)))
((= err errno/intr) (loop))
; No forward-progess here.
((or (= err errno/wouldblock)
(= err errno/again))
0)
(else (errno-error err reader sockfd flags
s start start end addr))))))))
(define-foreign recv-substring!/errno
(recv_substring (fixnum sockfd)
(fixnum flags)
(string-desc buf)
(size_t start)
(size_t end)
(string-desc name))
(multi-rep (to-scheme ssize_t errno_or_false)
ssize_t))
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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->fdes socket) flags
s start end
send-substring/errno
(if addr (socket-address:family addr) 0)
(and addr (socket-address:address addr)))))))
(define (generic-send-message sockfd flags s start end writer family addr)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices"
sockfd flags family addr
s start end writer))
(let ((addr (if addr (make-addr family) "")))
(let loop ((i start))
(if (< i end)
(receive (err nwritten)
(writer sockfd flags s i end family addr)
(cond ((not err) (loop (+ i nwritten)))
((= err errno/intr) (loop i))
(else (errno-error err sockfd flags family addr
s start i end writer))))))))
(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->fdes socket) flags
s start end
send-substring/errno
(if addr (socket-address:family addr) 0)
(if addr (socket-address:address addr)))))))
(define (generic-send-message/partial sockfd flags s start end writer family addr)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices"
sockfd flags family addr
s start end writer))
(if (= start end) 0 ; Vacuous request.
(let loop ()
(receive (err nwritten)
(writer sockfd flags s start end family addr)
(cond ((not err) nwritten)
((= err errno/intr) (loop))
((or (= err errno/again) (= err errno/wouldblock)) 0)
(else (errno-error err sockfd flags family addr
s start start end writer)))))))
(define-foreign send-substring/errno
(send_substring (fixnum sockfd)
(fixnum flags)
(string-desc buf)
(size_t start)
(size_t end)
(fixnum family)
(string-desc name))
(multi-rep (to-scheme ssize_t errno_or_false)
ssize_t))
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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 (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)
(receive (herrno name aliases addresses)
(%host-address->host-info/h-errno
(socket-address:address name))
(if herrno
(error "address->host-info: non-zero herrno ~s ~s" name herrno)
(make-host-info name
(vector->list
(C-string-vec->Scheme aliases #f))
(vector->list
(C-long-vec->Scheme addresses #f)))))))
(define-foreign %host-address->host-info/h-errno
(scheme_host_address2host_info (string-desc name))
(to-scheme fixnum "False_on_zero")
static-string ; host name
(C char**) ; alias list
(C char**)) ; address list
(define (name->host-info name)
(if (not (string? name))
(error "name->host-info: string expected ~s" name)
(receive (herrno name aliases addresses)
(%host-name->host-info/h-errno name)
(if herrno
(error "name->host-info: non-zero herrno ~s ~s" herrno name)
(make-host-info name
(vector->list
(C-string-vec->Scheme aliases #f))
(vector->list
(C-long-vec->Scheme addresses #f)))))))
(define-foreign %host-name->host-info/h-errno
(scheme_host_name2host_info (string name))
(to-scheme fixnum "False_on_zero")
static-string ; host name
(C char**) ; alias list
(C char**)) ; address list
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; network lookup
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define-record network-info
name ; Network name
aliases ; Alternative names
net) ; Network number
(define (network-info arg)
(cond ((string? arg) (name->network-info arg))
((socket-address? arg) (address->network-info arg))
(else
(error "network-info: string or socket-address expected ~s" arg))))
(define (address->network-info name)
(if (not (integer? name))
(error "address->network-info: integer expected ~s" name)
(let ((name (integer->string name))
(net (make-string 4)))
(receive (result name aliases)
(%net-address->network-info name net)
(make-network-info name
(vector->list
(C-string-vec->Scheme aliases #f))
(string->integer net))))))
(define-foreign %net-address->network-info
(scheme_net_address2net_info (string-desc name) (string-desc net))
(to-scheme fixnum "False_on_zero")
static-string ; net name
(C char**)) ; alias list
(define (name->network-info name)
(if (not (string? name))
(error "name->network-info: string expected ~s" name)
(let ((net (make-string 4)))
(receive (result name aliases)
(%net-name->network-info name net)
(make-network-info name
(vector->list
(C-string-vec->Scheme aliases #f))
(string->integer net))))))
(define-foreign %net-name->network-info
(scheme_net_name2net_info (string name) (string-desc net))
(to-scheme fixnum "False_on_zero")
static-string ; net name
(C char**)) ; alias list
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; service lookup
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define-record service-info
name ; Service name
aliases ; Alternative names
port ; Port number
protocol) ; Protocol name
(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
(receive (result name aliases port protocol)
(%service-port->service-info name proto)
(make-service-info name
(vector->list (C-string-vec->Scheme aliases #f))
port
protocol))))))
(define-foreign %service-port->service-info
(scheme_serv_port2serv_info (fixnum name) (string proto))
(to-scheme fixnum "False_on_zero")
static-string ; service name
(C char**) ; alias list
fixnum ; port number
static-string) ; protocol name
(define (name->service-info name . maybe-proto)
(receive (result name aliases port protocol)
(%service-name->service-info name (:optional maybe-proto ""))
(make-service-info name (vector->list (C-string-vec->Scheme aliases #f))
port protocol)))
(define-foreign %service-name->service-info
(scheme_serv_name2serv_info (string name) (string proto))
(to-scheme fixnum "False_on_zero")
static-string ; service name
(C char**) ; alias list
fixnum ; port number
static-string) ; protocol name
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; protocol lookup
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define-record protocol-info
name ; Protocol name
aliases ; Alternative names
number) ; Protocol number
(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)
(receive (result name aliases protocol)
(%protocol-port->protocol-info name)
(make-protocol-info name
(vector->list
(C-string-vec->Scheme aliases #f))
protocol))))
(define-foreign %protocol-port->protocol-info
(scheme_proto_num2proto_info (fixnum name))
(to-scheme fixnum "False_on_zero")
static-string ; protocol name
(C char**) ; alias list
fixnum) ; protocol number
(define (name->protocol-info name)
(if (not (string? name))
(error "name->protocol-info: string expected ~s" name)
(receive (result name aliases protocol)
(%protocol-name->protocol-info name)
(make-protocol-info name
(vector->list
(C-string-vec->Scheme aliases #f))
protocol))))
(define-foreign %protocol-name->protocol-info
(scheme_proto_name2proto_info (string name))
(to-scheme fixnum "False_on_zero")
static-string ; protocol name
(C char**) ; alias list
fixnum) ; protocol number
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; 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))))))