after sommerfelds fixes
now added error arg printing for mor readable errors
This commit is contained in:
bdc
parent
846439590d
commit
611ac55bb7
150
scsh/network.scm
150
scsh/network.scm
|
|
@ -37,13 +37,16 @@
|
|||
(service-info:port
|
||||
(service-info (cadr args) "tcp")))
|
||||
(else
|
||||
(error "socket-connect: bad arg")))))
|
||||
(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")))))
|
||||
(error "socket-connect: unsupported protocol-family ~s"
|
||||
protocol-family)))))
|
||||
(connect-socket sock addr)
|
||||
sock))
|
||||
|
||||
|
|
@ -56,14 +59,16 @@
|
|||
(service-info:port
|
||||
(service-info arg "tcp")))
|
||||
(else
|
||||
(error "socket-connect: bad arg")))))
|
||||
(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")))))
|
||||
(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)
|
||||
|
|
@ -95,9 +100,11 @@
|
|||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (internet-address->socket-address address32 port16)
|
||||
(cond ((not (<= 0 address32 #xffffffff))
|
||||
(error "internet-address->socket-address: address out of range"))
|
||||
(error "internet-address->socket-address: address out of range ~s"
|
||||
address32))
|
||||
((not (<= 0 port16 #xffff))
|
||||
(error "internet-address->socket-address: port out of range"))
|
||||
(error "internet-address->socket-address: port out of range ~s"
|
||||
port16))
|
||||
(else
|
||||
(make-socket-address address-family/internet
|
||||
(string-append (integer->string address32)
|
||||
|
|
@ -107,7 +114,8 @@
|
|||
(if (or (not (socket-address? sockaddr))
|
||||
(not (= (socket-address:family sockaddr)
|
||||
address-family/internet)))
|
||||
(error "socket-address->internet-address: internet socket expected")
|
||||
(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)
|
||||
|
|
@ -115,20 +123,21 @@
|
|||
|
||||
(define (unix-address->socket-address path)
|
||||
(if (> (string-length path) 108)
|
||||
(error "unix-address->socket-address: path too long")
|
||||
(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")
|
||||
(error "socket-address->unix-address expects an unix socket ~s" sockaddr)
|
||||
socket-address:address))
|
||||
|
||||
(define (make-addr af)
|
||||
(make-string (cond ((= af address-family/unix) 108)
|
||||
((= af address-family/internet) 8)
|
||||
(else (error "make-addr: unknown address-family")))))
|
||||
(else
|
||||
(error "make-addr: unknown address-family ~s" af)))))
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; socket syscall
|
||||
|
|
@ -139,7 +148,8 @@
|
|||
(if (not (and (integer? pf)
|
||||
(integer? type)
|
||||
(integer? protocol)))
|
||||
(error "create-socket: integer arguments expected")
|
||||
(error "create-socket: integer arguments expected ~s ~s ~s"
|
||||
pf type protocol)
|
||||
(let* ((fd (%socket pf type protocol))
|
||||
(in (make-input-fdport fd))
|
||||
(out (dup->outport in)))
|
||||
|
|
@ -168,14 +178,15 @@
|
|||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (bind-socket sock name)
|
||||
(cond ((not (socket? sock))
|
||||
(error "bind-socket: socket expected"))
|
||||
(error "bind-socket: socket expected ~s" sock))
|
||||
((not (socket-address? name))
|
||||
(error "bind-socket: socket-address expected"))
|
||||
(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")
|
||||
"bind-socket: trying to bind incompatible address to socket ~s"
|
||||
name)
|
||||
(%bind (socket->fdes sock)
|
||||
family
|
||||
(socket-address:address name)))))))
|
||||
|
|
@ -193,14 +204,15 @@
|
|||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (connect-socket sock name)
|
||||
(cond ((not (socket? sock))
|
||||
(error "connect-socket: socket expected"))
|
||||
(error "connect-socket: socket expected ~s" sock))
|
||||
((not (socket-address? name))
|
||||
(error "connect-socket: socket-address expected"))
|
||||
(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"))
|
||||
"connect: trying to connect socket to incompatible address ~s"
|
||||
name))
|
||||
(else
|
||||
(%connect (socket->fdes sock)
|
||||
(socket:family sock)
|
||||
|
|
@ -219,9 +231,9 @@
|
|||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (listen-socket sock backlog)
|
||||
(cond ((not (socket? sock))
|
||||
(error "listen-socket: socket expected"))
|
||||
(error "listen-socket: socket expected ~s" sock))
|
||||
((not (integer? backlog))
|
||||
(error "listen-socket: integer expected"))
|
||||
(error "listen-socket: integer expected ~s" backlog))
|
||||
(else
|
||||
(%listen (socket->fdes sock) backlog))))
|
||||
|
||||
|
|
@ -237,7 +249,7 @@
|
|||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (accept-connection sock)
|
||||
(if (not (socket? sock))
|
||||
(error "accept-connection: socket expected")
|
||||
(error "accept-connection: socket expected ~s" sock)
|
||||
(let* ((family (socket:family sock))
|
||||
(name (make-addr family))
|
||||
(fd (%accept (socket->fdes sock) family name))
|
||||
|
|
@ -263,7 +275,7 @@
|
|||
(define (socket-remote-address sock)
|
||||
(if (or (not (socket? sock))
|
||||
(not (= (socket:family sock) address-family/internet)))
|
||||
(error "socket-remote-address: internet socket expected")
|
||||
(error "socket-remote-address: internet socket expected ~s" sock)
|
||||
(let* ((family (socket:family sock))
|
||||
(name (make-addr family)))
|
||||
(%peer-name (socket->fdes sock)
|
||||
|
|
@ -285,7 +297,7 @@
|
|||
(define (socket-local-address sock)
|
||||
(if (or (not (socket? sock))
|
||||
(not (= (socket:family sock) address-family/internet)))
|
||||
(error "socket-local-address: internet socket expected")
|
||||
(error "socket-local-address: internet socket expected ~s" sock)
|
||||
(let* ((family (socket:family sock))
|
||||
(name (make-addr family)))
|
||||
(%socket-name (socket->fdes sock)
|
||||
|
|
@ -307,9 +319,9 @@
|
|||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (shutdown-socket sock how)
|
||||
(cond ((not (socket? sock))
|
||||
(error "shutdown-socket: socket expected"))
|
||||
(error "shutdown-socket: socket expected ~s" sock))
|
||||
((not (integer? how))
|
||||
(error "shutdown-socket: integer expected"))
|
||||
(error "shutdown-socket: integer expected ~s" how))
|
||||
(else
|
||||
(%shutdown (socket->fdes sock) how))))
|
||||
|
||||
|
|
@ -326,7 +338,7 @@
|
|||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
(define (create-socket-pair type)
|
||||
(if (not (integer? type))
|
||||
(error "create-socket-pair: integer argument expected")
|
||||
(error "create-socket-pair: integer argument expected ~s" type)
|
||||
(receive (s1 s2)
|
||||
(%socket-pair type)
|
||||
(let* ((in1 (make-input-fdport s1))
|
||||
|
|
@ -357,10 +369,10 @@
|
|||
(receive (flags)
|
||||
(parse-optionals maybe-flags 0)
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message: socket expected"))
|
||||
(error "receive-message: socket expected ~s" socket))
|
||||
((or (not (integer? flags))
|
||||
(not (integer? len)))
|
||||
(error "receive-message: integer expected"))
|
||||
(error "receive-message: integer expected ~s ~s" flags len))
|
||||
(else
|
||||
(let ((s (make-string len)))
|
||||
(receive (nread from)
|
||||
|
|
@ -373,15 +385,16 @@
|
|||
|
||||
(define (receive-message! socket s . maybe-args)
|
||||
(if (not (string? s))
|
||||
(error "receive-message!: string expected")
|
||||
(error "receive-message!: string expected ~s" s)
|
||||
(receive (start end flags)
|
||||
(parse-optionals maybe-args 0 (string-length s) 0)
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message!: socket expected"))
|
||||
(error "receive-message!: socket expected ~s" socket))
|
||||
((not (or (integer? flags)
|
||||
(integer? start)
|
||||
(integer? end)))
|
||||
(error "receive-message!: integer expected"))
|
||||
(error "receive-message!: integer expected ~s ~s ~s"
|
||||
flags start end))
|
||||
(else
|
||||
(generic-receive-message! (socket->fdes socket) flags
|
||||
s start end
|
||||
|
|
@ -414,10 +427,10 @@
|
|||
(receive (flags)
|
||||
(parse-optionals maybe-flags 0)
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message/partial: socket expected"))
|
||||
(error "receive-message/partial: socket expected ~s" socket))
|
||||
((or (not (integer? flags))
|
||||
(not (integer? len)))
|
||||
(error "receive-message/partial: integer expected"))
|
||||
(error "receive-message/partial: integer expected ~s ~s" flags len))
|
||||
(else
|
||||
(let ((s (make-string len)))
|
||||
(receive (nread addr)
|
||||
|
|
@ -430,13 +443,15 @@
|
|||
|
||||
(define (receive-message!/partial socket s . maybe-args)
|
||||
(if (not (string? s))
|
||||
(error "receive-message!/partial: string expected")
|
||||
(error "receive-message!/partial: string expected ~s" s)
|
||||
(receive (start end flags)
|
||||
(parse-optionals maybe-args 0 (string-length s) 0)
|
||||
(cond ((not (socket? socket))
|
||||
(error "receive-message!/partial: socket expected"))
|
||||
(error "receive-message!/partial: socket expected ~s"
|
||||
socket))
|
||||
((not (integer? flags))
|
||||
(error "receive-message!/partial: integer expected"))
|
||||
(error "receive-message!/partial: integer expected ~s"
|
||||
flags))
|
||||
(else
|
||||
(generic-receive-message!/partial (socket->fdes socket)
|
||||
flags
|
||||
|
|
@ -483,11 +498,11 @@
|
|||
(parse-optionals maybe-args
|
||||
0 (string-length s) 0 #f)
|
||||
(cond ((not (socket? socket))
|
||||
(error "send-message: socket expected"))
|
||||
(error "send-message: socket expected ~s" socket))
|
||||
((not (integer? flags))
|
||||
(error "send-message: integer expected"))
|
||||
(error "send-message: integer expected ~s" flags))
|
||||
((not (string? s))
|
||||
(error "send-message: string expected"))
|
||||
(error "send-message: string expected ~s" s))
|
||||
(else
|
||||
(generic-send-message (socket->fdes socket) flags
|
||||
s start end
|
||||
|
|
@ -517,11 +532,11 @@
|
|||
(parse-optionals maybe-args
|
||||
0 (string-length s) 0 #f)
|
||||
(cond ((not (socket? socket))
|
||||
(error "send-message/partial: socket expected"))
|
||||
(error "send-message/partial: socket expected ~s" socket))
|
||||
((not (integer? flags))
|
||||
(error "send-message/partial: integer expected"))
|
||||
(error "send-message/partial: integer expected ~s" flags))
|
||||
((not (string? s))
|
||||
(error "send-message/partial: string expected"))
|
||||
(error "send-message/partial: string expected ~s" s))
|
||||
(else
|
||||
(generic-send-message/partial (socket->fdes socket) flags
|
||||
s start end
|
||||
|
|
@ -564,29 +579,33 @@
|
|||
|
||||
(define (socket-option sock level option)
|
||||
(cond ((not (socket? sock))
|
||||
(error "socket-option: socket expected"))
|
||||
(error "socket-option: socket expected ~s" sock))
|
||||
((or (not (integer? level))(not (integer? option)))
|
||||
(error "socket-option: integer expected"))
|
||||
(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"))
|
||||
(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"))
|
||||
(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"))
|
||||
(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"))
|
||||
(cond ((= result/secs -1)
|
||||
(error "socket-option ~s ~s ~s" sock level option))
|
||||
(else (+ result/secs (/ usecs 1000))))))
|
||||
(else
|
||||
"socket-option: unknown option type")))
|
||||
"socket-option: unknown option type ~s" option)))
|
||||
|
||||
(define-foreign %getsockopt/errno
|
||||
(scheme_getsockopt (integer sockfd)
|
||||
|
|
@ -630,9 +649,9 @@
|
|||
|
||||
(define (set-socket-option sock level option value)
|
||||
(cond ((not (socket? sock))
|
||||
(error "set-socket-option: socket expected"))
|
||||
(error "set-socket-option: socket expected ~s" sock))
|
||||
((or (not (integer? level)) (not (integer? option)))
|
||||
(error "set-socket-option: integer expected"))
|
||||
(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)
|
||||
|
|
@ -713,17 +732,17 @@
|
|||
(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"))))
|
||||
(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")
|
||||
(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" herrno)
|
||||
(error "address->host-info: non-zero herrno ~s ~s" name herrno)
|
||||
(make-host-info name
|
||||
(vector->list
|
||||
(C-string-vec->Scheme aliases #f))
|
||||
|
|
@ -739,11 +758,11 @@
|
|||
|
||||
(define (name->host-info name)
|
||||
(if (not (string? name))
|
||||
(error "name->host-info: string expected")
|
||||
(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" herrno)
|
||||
(error "name->host-info: non-zero herrno ~s ~s" herrno name)
|
||||
(make-host-info name
|
||||
(vector->list
|
||||
(C-string-vec->Scheme aliases #f))
|
||||
|
|
@ -769,11 +788,12 @@
|
|||
(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"))))
|
||||
(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")
|
||||
(error "address->network-info: integer expected ~s" name)
|
||||
(let ((name (integer->string name))
|
||||
(net (make-string 4)))
|
||||
(receive (result name aliases)
|
||||
|
|
@ -792,7 +812,7 @@
|
|||
|
||||
(define (name->network-info name)
|
||||
(if (not (string? name))
|
||||
(error "name->network-info: string expected")
|
||||
(error "name->network-info: string expected ~s" name)
|
||||
(let ((net (make-string 4)))
|
||||
(receive (result name aliases)
|
||||
(%net-name->network-info name net)
|
||||
|
|
@ -819,15 +839,15 @@
|
|||
(define (service-info . args)
|
||||
(cond ((string? (car args)) (apply name->service-info args))
|
||||
((integer? (car args)) (apply port->service-info args))
|
||||
(else (error "service-info: string or integer expected"))))
|
||||
(else (error "service-info: string or integer expected ~s" args))))
|
||||
|
||||
(define (port->service-info name . maybe-proto)
|
||||
(receive (proto)
|
||||
(parse-optionals maybe-proto "")
|
||||
(cond ((not (integer? name))
|
||||
(error "port->service-info: integer expected"))
|
||||
(error "port->service-info: integer expected ~s" name))
|
||||
((not (string? proto))
|
||||
(error "port->service-info: string expected"))
|
||||
(error "port->service-info: string expected ~s" proto))
|
||||
(else
|
||||
(receive (result name aliases port protocol)
|
||||
(%service-port->service-info name proto)
|
||||
|
|
@ -851,7 +871,7 @@
|
|||
(parse-optionals maybe-proto "")
|
||||
(if (or (not (string? name))
|
||||
(not (string? name)))
|
||||
(error "name->service-info: string expected")
|
||||
(error "name->service-info: string expected ~s" name)
|
||||
(receive (result name aliases port protocol)
|
||||
(%service-name->service-info name proto)
|
||||
(make-service-info name
|
||||
|
|
@ -879,11 +899,11 @@
|
|||
(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"))))
|
||||
(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")
|
||||
(error "number->protocol-info: integer expected ~s" name)
|
||||
(receive (result name aliases protocol)
|
||||
(%protocol-port->protocol-info name)
|
||||
(make-protocol-info name
|
||||
|
|
@ -900,7 +920,7 @@
|
|||
|
||||
(define (name->protocol-info name)
|
||||
(if (not (string? name))
|
||||
(error "name->protocol-info: string expected")
|
||||
(error "name->protocol-info: string expected ~s" name)
|
||||
(receive (result name aliases protocol)
|
||||
(%protocol-name->protocol-info name)
|
||||
(make-protocol-info name
|
||||
|
|
|
|||
Loading…
Reference in New Issue