;;; -*- Mode: Scheme -*-

;;;; BSD getifaddrs(3) Interface

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; 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 names of the authors nor the names of contributors
;;;   may 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.

(begin-c-stub "bsd-ifaddrs")

(c-system-include "sys/types.h")
(c-system-include "sys/socket.h")
(c-system-include "ifaddrs.h")

(define-c-record interface-address "struct ifaddrs"
    (make-interface-address name flags %address %netmask %destination data)
  (c->record "ifa"
    (name (c-copied-asciz-string "ifa -> ifa_name"))
    (flags (c-unsigned "u_int" "ifa -> ifa_flags"))
    (%address
     (c-if "(ifa -> ifa_addr) != 0"
       (c-copied-byte-vector "ifa -> ifa_addr"
                             "0"
                             "(ifa -> ifa_addr) -> sa_len")
       (c-false)))
    (%netmask
     (c-if "(ifa -> ifa_netmask) != 0"
       (c-copied-byte-vector "ifa -> ifa_netmask"
                             "0"
                             "(ifa -> ifa_netmask) -> sa_len")
       (c-false)))
    (%destination
     (c-if "(ifa -> ifa_dstaddr) != 0"
       (c-copied-byte-vector "ifa -> ifa_dstaddr"
                             "0"
                             "(ifa -> ifa_dstaddr) -> sa_len")
       (c-false)))
    (data (c-alien "void *" "ifa -> ifa_data")))
  (record->c "ifa"
      ((name c-immutable-asciz-string)
       (flags (c-unsigned "u_int"))
       (%address (c-immutable-byte-vector "address" "address_length"))
       (%netmask (c-immutable-byte-vector "netmask" "netmask_length"))
       (%destination
        (c-immutable-byte-vector "destination" "destination_length"))
       (data (c-alien "void *")))
    ;; There's no sensible way to do this, because we don't know how
    ;; freeifaddrs works, so there's no correct way to allocate storage
    ;; for the parts (the name and socket addresses).
    "(void) (* ((char *) 0));"))

(define %interface-address.address interface-address.%address)
(define %interface-address.netmask interface-address.%netmask)
(define %interface-address.destination interface-address.%destination)

(define (interface-address.address interface-address)
  (cond ((%interface-address.address interface-address)
         => byte-vector->socket-address)
        (else #f)))

(define (interface-address.netmask interface-address)
  (cond ((%interface-address.netmask interface-address)
         => byte-vector->socket-address)
        (else #f)))

(define (interface-address.destination interface-address)
  (cond ((%interface-address.destination interface-address)
         => byte-vector->socket-address)
        (else #f)))

(define (interface-address.broadcast interface-address)
  (interface-address.destination interface-address))

;;; This is somewhat hairy in order to be robust against interrupts
;;; without leaving dangling struct ifaddrs in memory.

(define (get-interface-addresses)
  (with-ifaddrs-alien
    (lambda (alien)
      (%get-ifaddrs alien)
      (let loop ((alien alien) (interface-addresses '()))
        (if (%ifaddrs-null? alien)
            (reverse interface-addresses)
            (receive (interface-address alien*) (%parse-ifaddrs alien)
              (loop alien* (cons interface-address interface-addresses))))))))

(define-unix-void-syscall
    (%get-ifaddrs (ifaddrs (c-alien-pointer "struct ifaddrs *")))
  ("getifaddrs" "ifaddrs")
  (c-unspecific))

(define-c (%free-ifaddrs (ifaddrs (c-alien-pointer "struct ifaddrs *")))
  (c-void "if ((*ifaddrs) != 0) { freeifaddrs (*ifaddrs); (*ifaddrs) = 0; }"))

(define-c (%ifaddrs-null? (ifaddrs (c-alien "struct ifaddrs *")))
  (c-boolean "ifaddrs == 0"))

(define-c (%parse-ifaddrs (ifaddrs (c-alien "struct ifaddrs *")))
  (c-values (c-interface-address "ifaddrs")
            (c-alien "struct ifaddrs *" "ifaddrs -> ifa_next")))

(define-record-type <ifaddrs>
    (%make-ifaddrs alien)
    ifaddrs?
  (alien ifaddrs.alien set-ifaddrs.alien!))

(define (with-ifaddrs-alien receiver)
  (let ((ifaddrs (allocate-ifaddrs)))
    (receive results (receiver (ifaddrs.alien ifaddrs))
      (release-ifaddrs ifaddrs)
      (apply values results))))

(define (allocate-ifaddrs)
  (let* ((alien (allocate-ifaddrs-alien))
         (ifaddrs (%make-ifaddrs alien)))
    (finalizer/add-object! ifaddrs-finalizer ifaddrs alien)
    ifaddrs))

(define (release-ifaddrs ifaddrs)
  (finalizer/remove-object! ifaddrs-finalizer ifaddrs))

(define-c (allocate-ifaddrs-alien)
  (c-alien "struct ifaddr *" "0"))

(define ifaddrs-finalizer
  (make-default-finalizer (lambda (alien) (%free-ifaddrs alien))
                          (lambda (object) (ifaddrs? object))
                          (lambda (ifaddrs alien)
                            (set-ifaddrs.alien! ifaddrs alien))))

(end-c-stub)