;; -*- Mode: Irken -*-
(cinclude "sys/types.h")
(cinclude "sys/socket.h")
(cinclude "netinet/in.h")
(cinclude "arpa/inet.h")
;; better than trying to muck about with the variadic (and evil) fcntl.
(cverbatim "
void
set_nonblocking (int fd)
{
int flag;
flag = fcntl (fd, F_GETFL, 0);
flag |= (O_NDELAY);
fcntl (fd, F_SETFL, flag);
}
")
(define SOCK_STREAM (%%cexp int "SOCK_STREAM"))
(define AF_INET (%%cexp int "AF_INET"))
;; it'd be nice if we could have these act more like #define
;; so we could use them in pattern matches
(define EAGAIN (%%cexp int "EAGAIN"))
(define EINPROGRESS (%%cexp int "EINPROGRESS"))
(define EWOULDBLOCK (%%cexp int "EWOULDBLOCK"))
(define (socket family type protocol)
(let ((fd (syscall
(%%cexp (int int int -> int)
"socket (%0, %1, %2)"
family type protocol))))
(set-nonblocking fd)
fd))
(define (set-nonblocking fd)
(%%cexp (int -> undefined) "set_nonblocking (%0)" fd))
(define (inet_pton af ascii buf)
(syscall
(%%cexp (int string (buffer (struct sockaddr_in)) -> int)
"inet_pton (%0, %1, &(%2->sin_addr))"
af ascii buf)))
(define (inet_ntop af buf)
(let ((ascii (make-string 100)))
(%%cexp (int (buffer (struct sockaddr_in)) string int -> int)
"inet_ntop (%0, &(%1->sin_addr), %2, %3)"
af buf ascii (string-length ascii))
;; should strip this to NUL
ascii))
(define (make-in-addr ip port)
(let ((ss (%callocate (struct sockaddr_in) 1)))
(%%cexp ((buffer (struct sockaddr_in)) -> undefined) "(%0->sin_family = PF_INET, PXLL_UNDEFINED)" ss)
(%%cexp ((buffer (struct sockaddr_in)) int -> undefined) "(%0->sin_port = htons(%1), PXLL_UNDEFINED)" ss port)
(inet_pton AF_INET ip ss)
ss))
(define (bind fd addr)
(syscall
(%%cexp (int (buffer (struct sockaddr_in)) -> int)
"bind (%0, (struct sockaddr *) %1, sizeof(struct sockaddr_in))"
fd addr)))
(define (listen fd backlog)
(syscall
(%%cexp (int int -> int) "listen (%0, %1)" fd backlog)))
(define (accept fd)
(let ((sockaddr (%callocate (struct sockaddr_in) 1))
(address-len (%callocate socklen_t 1)))
(%%cexp ((buffer socklen_t) -> undefined) "*%0 = sizeof(struct sockaddr_in)" address-len)
(let loop ()
(try
(syscall
(%%cexp (int (buffer (struct sockaddr_in)) (buffer socklen_t) -> int)
"accept (%0, (struct sockaddr *) %1, %2)"
fd sockaddr address-len))
except
(:OSError e) -> (if (eq? e EWOULDBLOCK)
(begin (poller/wait-for-read fd) (loop))
(raise (:OSError e)))
))))
(define (connect fd addr)
(try
(syscall
(%%cexp (int (buffer (struct sockaddr_in)) -> int)
"connect (%0, (struct sockaddr *) %1, sizeof (struct sockaddr_in))"
fd addr))
except
(:OSError e) -> (if (or (eq? e EINPROGRESS)
(eq? e EWOULDBLOCK))
(begin (poller/wait-for-write fd) 0)
(raise (:OSError e)))
))
(define (recv-buffer fd buf)
(let loop ()
(try
(syscall
(%%cexp (int string int -> int)
"recv (%0, %1, %2, 0)"
fd buf (string-length buf)))
except
(:OSError e) -> (if (eq? e EWOULDBLOCK)
(begin (poller/wait-for-read fd) (loop))
(raise (:OSError e)))
)))
(define (recv fd size)
(let ((buffer (make-string size))
(r (recv-buffer fd buffer)))
(if (= r size)
buffer
(copy-string buffer r))))
(define (send fd s)
(let loop ()
(try
(syscall
(%%cexp (int string int -> int)
"send (%0, %1, %2, 0)"
fd s (string-length s)))
except
(:OSError e) -> (if (eq? e EWOULDBLOCK)
(begin (poller/wait-for-write fd) (loop))
(raise (:OSError e)))
)))