;;;; unix-sockets.scm
;
; Copyright (c) 2000-2011, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Send bugs, suggestions and ideas to: 
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Unter den Gleichen 1
; 37130 Gleichen
; Germany

(require-library easyffi)

(module unix-sockets

  (unix-connect
   unix-accept
   unix-accept-ready?
   unix-listener-fileno unix-listener-path
   unix-close
   unix-listener?
   unix-listen)

;; TODO: errno should be accessed using the proper API?
(import scheme (except chicken errno) easyffi foreign)
(use ports posix)

#>
#include <fcntl.h>
#include <sys/types.h>
#include <unistd.h>
#include <errno.h>
#include <sys/socket.h>
#include <sys/un.h>
#include <sys/time.h>

static struct sockaddr_un socket_name;
<#

#>!
static int
create_socket(const char *filename, int backlog)
{
  int sock;
  socklen_t size;
     
  /* Create the socket. */
  sock = socket (PF_LOCAL, SOCK_STREAM, 0);

  if (sock < 0) return -1;
     
  /* Bind a name to the socket. */
  socket_name.sun_family = AF_LOCAL;
  strncpy (socket_name.sun_path, filename, sizeof (socket_name.sun_path));
  socket_name.sun_path[sizeof (socket_name.sun_path) - 1] = '\0';
  size = SUN_LEN(&socket_name);
     
  if(bind (sock, (struct sockaddr *) &socket_name, size) < 0) return -1;

  if(listen(sock, backlog) < 0) return -1;

  return sock;
}

     
static int
connect_to_server(const char *filename)
{
  int sock;
  socklen_t size;
     
  /* Create the socket. */
  sock = socket (PF_LOCAL, SOCK_STREAM, 0);

  if (sock < 0) return -1;
     
  socket_name.sun_family = AF_LOCAL;
  strncpy(socket_name.sun_path, filename, sizeof(socket_name.sun_path));
  socket_name.sun_path[sizeof (socket_name.sun_path) - 1] = '\0';
  size = SUN_LEN(&socket_name);

  /* Connect to the server. */
  if (connect(sock, (struct sockaddr *) &socket_name, size) < 0)
    return -1;

  return sock;
}


static int
accept_connection(int sock, char *filename)
{
  int s2;
  socklen_t size;

  socket_name.sun_family = AF_LOCAL;
  strncpy(socket_name.sun_path, filename, sizeof(socket_name.sun_path));
  socket_name.sun_path[sizeof (socket_name.sun_path) - 1] = '\0';
  size = SUN_LEN(&socket_name);
  s2 = accept(sock, (struct sockaddr *)&socket_name, &size);

  if(s2 < 0) return -1;

  return s2;
}
<#


(define strerror (foreign-lambda c-string "strerror" int))
(define close (foreign-lambda void "close" int))
(define fd-read (foreign-lambda int "read" int scheme-pointer int))
(define fd-write (foreign-lambda int "write" int scheme-pointer int))

(define-foreign-variable errno int)

(define-foreign-variable EWOULDBLOCK int)
(define-foreign-variable SHUT_RD int)
(define-foreign-variable SHUT_WR int)

(define (unix-error loc msg . args)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'message (string-append msg " - " (strerror errno)) 'location loc args args)
    (make-property-condition 'unix 'errno errno) ) ) )

(define (unix-connect filename)
  (let ([n (##sys#pathname-resolution filename (lambda (f) (connect_to_server f)))])
    (if (negative? n)
	(unix-error 'unix-connect "can not connect" filename)
	(io-ports 'unix-connect n) ) ) )

(define-constant +buffer-size+ 1024)

(define make-nonblocking
  (foreign-lambda* bool ([int fd])
    "int val = fcntl(fd, F_GETFL, 0);"
    "if(val == -1) return(0);"
    "return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);") )

(define (yield)
  (##sys#call-with-current-continuation
   (lambda (return)
     (let ((ct ##sys#current-thread))
       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
       (##sys#schedule) ) ) ) )

(define select-read
  (foreign-lambda* int ((int fd))
    "fd_set in;
     struct timeval tm;
     FD_ZERO(&in);
     FD_SET(fd, &in);
     tm.tv_sec = tm.tv_usec = 0;
     if(select(fd + 1, &in, NULL, NULL, &tm) == -1) return(-1);
     else return(FD_ISSET(fd, &in) ? 1 : 0);") )

#;(define select-write
  (foreign-lambda* int ((int fd))
    "fd_set out;
     struct timeval tm;
     FD_ZERO(&out);
     FD_SET(fd, &out);
     tm.tv_sec = tm.tv_usec = 0;
     if(select(fd + 1, NULL, &out, NULL, &tm) == -1) return(-1);
     else return(FD_ISSET(fd, &out) ? 1 : 0);") )

(define shutdown (foreign-lambda int "shutdown" int int))

(define io-ports
  (let ([make-input-port make-input-port]
	[make-output-port make-output-port] 
	[make-string make-string] 
	[substring substring] )
    (lambda (loc fd)
      (unless (make-nonblocking fd)
	(unix-error loc "can not create unix socket ports") )
      (let* ([buf (make-string +buffer-size+)]
	     [data (vector fd #f #f)]
	     [buflen 0]
	     [bufindex 0]
	     [iclosed #f] 
	     [oclosed #f]
	     [in
	      (make-input-port
	       (lambda ()
		 (when (fx>= bufindex buflen)
		   (let ([n (let loop ()
			      (let ([n (fd-read fd buf +buffer-size+)])
				(if (eq? -1 n)
				    (if (eq? errno EWOULDBLOCK) 
					(begin
					  (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
					  (yield)
					  (loop) )
					(unix-error loc "can not read from socket" fd) )
				    n) ) ) ] )
		     (set! buflen n)
		     (set! bufindex 0) ) )
		 (if (fx>= bufindex buflen)
		     #!eof
		     (let ([c (##core#inline "C_subchar" buf bufindex)])
		       (set! bufindex (fx+ bufindex 1))
		       c) ) )
	       (lambda ()
		 (or (fx< bufindex buflen)
		     (let ([f (select-read fd)])
		       (when (eq? f -1)
			 (unix-error loc "can not check socket for input" fd) )
		       (eq? f 1) ) ) )
	       (lambda ()
		 (unless iclosed
		   (set! iclosed #t)
		   (unless (##sys#slot data 1) (shutdown fd SHUT_RD))
		   (when (and oclosed (eq? -1 (close fd)))
		     (unix-error loc "can not close socket input port" fd) ) ) ) ) ]
	     [out
	      (make-output-port
	       (lambda (s) 
		 (let ([len (##sys#size s)])
		   (let loop ()
		     (let ([n (fd-write fd s len)])
		       (cond [(eq? -1 n)
			      (if (eq? errno EWOULDBLOCK)
				  (begin
				    ;(##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
				    (yield) 
				    (loop) )
				  (unix-error loc "can not write to socket" fd s) ) ]
			     [(fx< n len)
			      (set! s (substring s n len))
			      (set! len (##sys#size s))
			      (loop) ] ) ) ) ) )
	       (lambda ()
		 (unless oclosed
		   (set! oclosed #t)
		   (unless (##sys#slot data 2) (shutdown fd SHUT_WR))
		   (when (and iclosed (eq? -1 (close fd)))
		     (unix-error loc "can not close socket output port" fd) ) ) ) ) ] )
	(##sys#setslot in 3 "(unix)")
	(##sys#setslot out 3 "(unix)")
	(##sys#setslot in 7 'socket)
	(##sys#setslot out 7 'socket)
	(##sys#setslot (##sys#port-data in) 0 data)
	(##sys#setslot (##sys#port-data out) 0 data)
	(values in out) ) ) ) )

(define (unix-listen filename #!optional (backlog 10))
  (when (file-exists? filename)
    (delete-file filename) )
  (let ([n (##sys#pathname-resolution filename (lambda (name) (create_socket name backlog)))])
    (if (negative? n)
	(unix-error 'unix-listen "can not create socket" filename)
	(##sys#make-structure 'unix-listener n filename) ) ) )

(define (unix-accept listener)
  (##sys#check-structure listener 'unix-listener 'unix-accept)
  (let ([fd (##sys#slot listener 1)])
    (let loop ()
      (if (eq? 1 (select-read fd))
	  (let ([fd (accept_connection fd (##sys#slot listener 2))])
	    (when (negative? fd)
	      (unix-error 'unix-accept "could not accept from listener" listener) )
	    (io-ports 'unix-accept fd) )
	  (begin
	    (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
	    (yield)
	    (loop) ) ) ) ) )

(define (unix-accept-ready? listener)
  (##sys#check-structure listener 'unix-listener 'unix-accept-ready?)
  (let ([f (select-read (##sys#slot listener 1))])
    (when (eq? -1 f)
      (unix-error 'unix-accept-ready? "can not check socket for input" listener) )
    (eq? 1 f) ) )

(define (unix-listener? x)
  (##sys#structure? x 'unix-listener) )

(define (unix-listener-fileno x)
  (##sys#check-structure x 'unix-listener 'unix-listener-fileno)
  (##sys#slot x 1) )

(define (unix-listener-path x)
  (##sys#check-structure x 'unix-listener 'unix-listener-path)
  (##sys#slot x 2) )

(define (unix-close l)
  (##sys#check-structure l 'unix-listener)
  (let ([s (##sys#slot l 1)])
    (when (fx= -1 (close s))
      (unix-error 'unix-close "can not close unix socket" l) ) ) )
)