[[project @ 1996-12-21 04:06:57 by ghouston] ghouston**19961221040658 Ignore-this: 498dfb62f309e1147182db5ad24a0ad1 * network.scm: (close-socket, bind-socket, create-socket, connect-socket, listen-socket, accept-connection, socket-remote-address, socket-local-address, shutdown-socket, create-socket-pair, receive-message, use Guile network primitives. (socket-address->list family address): new procedure. (make-addr): comment out. (address-vector->socket-address): new procedure. * network.scm (internet-address->socket-address): store the address/port in a pair instead of packing them into a string. (socket-address->internet-address): equal and opposite change. (throughout): replace :optional with optional. (socket->port sock): replaces socket->fdes. * init.scm: define integer->string, load netconst.scm. define define-foreign, define-errno-syscall, define-record-dicloser (do nothing.) load network.scm. * netconst.scm: new file, defines network constants. * network.scm: copied from SCSH ] addfile ./netconst.scm addfile ./network.scm hunk ./ChangeLog 1 +Sat Dec 21 01:49:23 1996 Gary Houston + + * network.scm: (close-socket, bind-socket, create-socket, + connect-socket, listen-socket, accept-connection, + socket-remote-address, socket-local-address, shutdown-socket, + create-socket-pair, receive-message, + + use Guile network primitives. + (socket-address->list family address): new procedure. + (make-addr): comment out. + (address-vector->socket-address): new procedure. + +Thu Dec 19 05:29:30 1996 Gary Houston + + * network.scm (internet-address->socket-address): store the + address/port in a pair instead of packing them into a string. + (socket-address->internet-address): equal and opposite change. + (throughout): replace :optional with optional. + (socket->port sock): replaces socket->fdes. + + * init.scm: define integer->string, load netconst.scm. + define define-foreign, define-errno-syscall, + define-record-dicloser (do nothing.) + load network.scm. + +Wed Dec 18 22:44:02 1996 Gary Houston + + * netconst.scm: new file, defines network constants. + hunk ./ChangeLog 32 + * network.scm: copied from SCSH + + * init.scm: define foreign-source, does nothing. + hunk ./ChangeLog 38 - + hunk ./INCOMPAT 4 -utilities.scm shouldn't be at the top level. +everything is defined at the top level, no modules hunk ./init.scm 6 +(define (foreign-source . args) #f) +(defmacro define-foreign args #f) +(defmacro define-errno-syscall args #f) +(defmacro define-record-discloser args #f) + +(define integer->string number->string) + hunk ./init.scm 27 +(load-from-path "scsh/netconst.scm") +(load-from-path "scsh/network.scm") + hunk ./netconst.scm 1 +(defmacro maybe-define (name value) + `(if (defined? ',value) + (define ,name ,value))) + +(maybe-define address-family/unspecified AF_UNSPEC) +(maybe-define address-family/unix AF_UNIX) +(maybe-define address-family/internet AF_INET) + +(maybe-define protocol-family/unspecified PF_UNSPEC) +(maybe-define protocol-family/unix PF_UNIX) +(maybe-define protocol-family/internet PF_INET) + +(maybe-define socket-type/stream SOCK_STREAM) +(maybe-define socket-type/datagram SOCK_DGRAM) +(maybe-define socket-type/raw SOCK_RAW) + +(maybe-define internet-address/any INADDR_ANY) +(maybe-define internet-address/broadcast INADDR_BROADCAST) +(maybe-define internet-address/loopback INADDR_LOOPBACK) + +(maybe-define level/socket SOL_SOCKET) + +(maybe-define socket/debug SO_DEBUG) +(maybe-define socket/reuse-address SO_REUSEADDR) +(maybe-define socket/style SO_STYLE) +(maybe-define socket/type SO_TYPE) +(maybe-define socket/error SO_ERROR) +(maybe-define socket/dont-route SO_DONTROUTE) +(maybe-define socket/broadcast SO_BROADCAST) +(maybe-define socket/send-buffer SO_SNDBUF) +(maybe-define socket/receive-buffer SO_RCVBUF) +(maybe-define socket/keep-alive SO_KEEPALIVE) +(maybe-define socket/no-check SO_NO_CHECK) +(maybe-define socket/priority SO_PRIORITY) +(maybe-define socket/linger SO_LINGER) + +(maybe-define message/out-of-band MSG_OOB) +(maybe-define message/peek MSG_PEEK) +(maybe-define message/dont-route MSG_DONTROUTE) + +(define shutdown/receives 0) +(define shutdown/sends 1) +(define shutdown/sends+receives 2) hunk ./network.scm 1 +;;; Networking for the Scheme Shell +;;; Copyright (c) 1994-1995 by Brian D. Carlstrom. +;;; Copyright (c) 1994 by Olin Shivers. + +;;; Scheme48 implementation. + +(foreign-source + "#include " + "#include " + "" + "/* 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) ? SCHFALSE : ENTER_FIXNUM(errno))" + "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)" + "#define False_on_zero(x) ((x) ? ENTER_FIXNUM(x) : SCHFALSE)" + "" ) + +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;; 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))))) + (connect-socket sock addr) + sock)) + +(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 port of a socket +;;; not exported +(define (socket->port sock) + (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 + (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 (address-vector->socket-address vec) + (if (eq? vec #f) + #f + (let ((family (vector-ref vec 0))) + (cond ((= family address-family/internet) + (internet-address->socket-address (vector-ref vec 1) + (vector-ref vec 2))) + ((= family address-family/unix) + (unix-address->socket-address (vector-ref vec 1))) + (else + (error "Unrecognised socket address type" family)))))) + +;(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* ((sock (socket pf type protocol))) + (make-socket pf sock sock))))) + +(define-foreign %socket/errno + (socket (integer pf) + (integer type) + (integer protocol)) + (multi-rep (to-scheme integer errno_or_false) + integer)) + +(define-errno-syscall (%socket pf type protocol) %socket/errno + sockfd) + +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;; close syscall +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +(define (close-socket sock) + (close-port (socket:inport sock))) + +(define (socket-address->list address) + (let ((family (socket-address:family address))) + (cond ((= family address-family/unix) + (list family (socket-address:address address))) + ((= family address-family/internet) + (list family + (car (socket-address:address address)) + (cdr (socket-address:address address)))) + (else + (error + "unrecognised socket family" family))))) + +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;; 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) + (apply bind + (socket->port sock) + (socket-address->list name))))))) + +(define-foreign %bind/errno + (scheme_bind (integer sockfd) ; socket fdes + (integer family) ; address family + (string-desc name)) ; scheme descriptor + (to-scheme integer 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 + (apply connect (socket->port sock) + (socket-address->list name)))))))) + +(define-foreign %connect/errno + (scheme_connect (integer sockfd) ; socket fdes + (integer family) ; address family + (desc name)) ; scheme descriptor + (to-scheme integer 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->port sock) backlog)))) + +(define-foreign %listen/errno + (listen (integer sockfd) ; socket fdes + (integer backlog)) ; backlog + (to-scheme integer 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)) + (rv (accept (socket->port sock))) + (new-socket (car rv)) + (address-vector (cdr rv))) + (values (make-socket family new-socket new-socket) + (address-vector->socket-address address-vector))))) + +(define-foreign %accept/errno + (scheme_accept (integer sockfd) + (integer family) + (string-desc name)) + (multi-rep (to-scheme integer errno_or_false) + integer)) + +(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)) + (peer (getpeername (socket->port sock)))) + (address-vector->socket-address peer)))) + +(define-foreign %peer-name/errno + (scheme_peer_name (integer sockfd) + (integer family) + (string-desc name)) + (to-scheme integer 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 (getsockname (socket->port sock)))) + (address-vector->socket-address name)))) + +(define-foreign %socket-name/errno + (scheme_socket_name (integer sockfd) + (integer family) + (string-desc name)) + (to-scheme integer "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->port sock) how)))) + +(define-foreign %shutdown/errno + (shutdown (integer sockfd) + (integer how)) + (to-scheme integer 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) + (let* ((pair (socketpair protocol-family/unix type 0))) + (values (make-socket protocol-family/unix (car pair) (car pair)) + (make-socket protocol-family/unix (cdr pair) (cdr pair)))))) + +;; based on pipe in syscalls.scm +(define-foreign %socket-pair/errno + (scheme_socket_pair (integer type)) + (to-scheme integer errno_or_false) + integer + integer) + +(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 + (recv (socket->port socket) len flags))))) + +(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 + (recv (socket->port 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 (integer sockfd) + (integer flags) + (string-desc buf) + (integer start) + (integer end) + (string-desc name)) + (multi-rep (to-scheme integer errno_or_false) + integer)) + +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;; 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 (integer sockfd) + (integer flags) + (string-desc buf) + (integer start) + (integer end) + (integer family) + (string-desc name)) + (multi-rep (to-scheme integer errno_or_false) + integer)) + +;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +;;; 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 (integer sockfd) + (integer level) + (integer optname)) + (multi-rep (to-scheme integer errno_or_false) + integer)) + +(define-errno-syscall (%getsockopt sock level option) %getsockopt/errno + value) + +(define-foreign %getsockopt-linger/errno + (scheme_getsockopt_linger (integer sockfd) + (integer level) + (integer optname)) + (multi-rep (to-scheme integer errno_or_false) + integer) ; error/on-off + integer) ; linger time + +(define-errno-syscall + (%getsockopt-linger sock level option) %getsockopt-linger/errno + on-off + linger) + +(define-foreign %getsockopt-timeout/errno + (scheme_getsockopt_timeout (integer sockfd) + (integer level) + (integer optname)) + (multi-rep (to-scheme integer errno_or_false) + integer) ; error/secs + integer) ; 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 (integer sockfd) + (integer level) + (integer optname) + (integer optval)) + (to-scheme integer errno_or_false)) + +(define-errno-syscall + (%setsockopt sock level option value) %setsockopt/errno) + + +(define-foreign %setsockopt-linger/errno + (scheme_setsockopt_linger (integer sockfd) + (integer level) + (integer optname) + (integer on-off) + (integer time)) + (to-scheme integer 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 (integer sockfd) + (integer level) + (integer optname) + (integer secs) + (integer usecs)) + (to-scheme integer 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-string-vec->Scheme addresses #f))))))) + +(define-foreign %host-address->host-info/h-errno + (scheme_host_address2host_info (string-desc name)) + (to-scheme integer "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 integer "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 integer "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 integer "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 (integer name) (string proto)) + (to-scheme integer "False_on_zero") + static-string ; service name + (C char**) ; alias list + integer ; 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 integer "False_on_zero") + static-string ; service name + (C char**) ; alias list + integer ; 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 (integer name)) + (to-scheme integer "False_on_zero") + static-string ; protocol name + (C char**) ; alias list + integer) ; 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 integer "False_on_zero") + static-string ; protocol name + (C char**) ; alias list + integer) ; 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))))))