;;; -*- Mode: Scheme; scheme48-package: networking -*-

;;; Copyright (c) 1993-2003 Richard Kelsey and Jonathan Rees
;;; Copyright (c) 1994-2003 by Olin Shivers and Brian D. Carlstrom.
;;; Copyright (c) 1999-2003 by Martin Gasbichler.
;;; Copyright (c) 2001-2003 by Michael Sperber.
;;; 
;;; All rights reserved.
;;; 
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. The name of the authors may not be used to endorse or promote products
;;;    derived from this software without specific prior written permission.
;;; 
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.

(define (socket-connect protocol-family socket-type . args)
  (let* ((sock (create-socket protocol-family
                              socket-type))
         (addr (cond ((eqv? 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 port arg ~s"
                                           args)))))
                        (internet-address->socket-address host port)))
                     ((eqv? 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)
  (bind-prepare-listen-accept-loop protocol-family (lambda () #t) proc arg))

(define (bind-prepare-listen-accept-loop protocol-family prepare proc arg)
  (let* ((sock (create-socket protocol-family socket-type/stream))
         (addr
          (cond
           ((eqv? 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)))
           ((eqv? 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)
    (with-handler
      (lambda (condition more)
        (with-handler
          (lambda (condition ignore) (more))
          (lambda () (close-socket sock)))
        (more))
      prepare)
    (listen-socket sock 5)
    (with-handler
      (lambda (condition more)
        (with-handler
          (lambda (condition ignore) (more))
          (lambda () (close-socket sock)))
        (more))
      (lambda ()
        (let loop ()
          (call-with-values
              (lambda () (accept-connection sock))
            proc)
          (loop))))))