;; This file is part of address-info for CHICKEN
;; Copyright (c) 2017 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(module address-info
  (make-address-info address-info?
   address-info-family address-info-type address-info-host address-info-port
   address-infos)

(import
  scheme
  (chicken base)
  (chicken foreign)
  (chicken condition)
  (only (srfi 1) unfold))

(declare
  (usual-integrations)
  (no-procedure-checks-for-usual-bindings))

#>
#include <errno.h>
#ifdef _WIN32
# ifdef _MSC_VER
#   include <winsock2.h>
# else
#   include <ws2tcpip.h>
# endif
#else
# include <sys/types.h>
# include <sys/socket.h>
# include <netdb.h>
# include <arpa/inet.h>
# include <netinet/in.h>
#endif
<#

(define-foreign-type addrinfo
  (c-pointer (struct "addrinfo")))

(define (type-error loc msg . args)
  (abort
    (make-composite-condition
      (make-property-condition 'exn
        'location loc
        'message msg
        'arguments args)
      (make-property-condition 'type))))

(define-foreign-type addrfamily
  int
  (lambda (family)
    (case family
      [(ipv4) (foreign-value "AF_INET" int)]
      [(ipv6) (foreign-value "AF_INET6" int)]
      [(#f) (foreign-value "AF_UNSPEC" int)]
      [else (type-error 'address-infos "bad address family" family)]))
  (lambda (family)
    (cond
      [(= family (foreign-value "AF_INET" int)) 'ipv4]
      [(= family (foreign-value "AF_INET6" int)) 'ipv6]
      [else #f])))

(define-foreign-type socktype
  int
  (lambda (type)
    (case type
      [(tcp stream) (foreign-value "SOCK_STREAM" int)]
      [(udp datagram) (foreign-value "SOCK_DGRAM" int)]
      [(raw) (foreign-value "SOCK_RAW" int)]
      [(#f) 0]
      [else (type-error 'address-infos "bad socket type" type)]))
  (lambda (type)
    (cond
      [(= type (foreign-value "SOCK_STREAM" int)) 'tcp]
      [(= type (foreign-value "SOCK_DGRAM" int)) 'udp]
      [(= type (foreign-value "SOCK_RAW" int)) 'raw]
      [else #f])))

(define addrinfo-get
  (foreign-lambda* addrinfo ([c-string node] [c-string service] [addrfamily family] [socktype type] [bool server] [bool numeric])
    "struct addrinfo hints;"
    "struct addrinfo *info = NULL;\n"
    "memset(&hints, 0, sizeof(struct addrinfo));\n"
    "hints.ai_family = family;\n"
    "hints.ai_socktype = type;\n"
    "hints.ai_protocol = 0;\n"
    "hints.ai_flags = (server ? AI_PASSIVE : 0) | (numeric ? AI_NUMERICHOST : 0);\n"
    "if (getaddrinfo(node, service, &hints, &info) != 0 && info) {\n"
    "  freeaddrinfo(info);\n"
    "  info = NULL;\n"
    "}\n"
    "C_return(info);\n"))

(define addrinfo-free!
  (foreign-lambda void "freeaddrinfo" addrinfo))

(define addrinfo-next
  (foreign-lambda* addrinfo ([addrinfo info])
    "C_return(info->ai_next);"))

(define addrinfo-family
  (foreign-lambda* addrfamily ([addrinfo info])
    "C_return(info->ai_family);"))

(define addrinfo-type
  (foreign-lambda* socktype ([addrinfo info])
    "C_return(info->ai_socktype);"))

(define addrinfo-host
  (foreign-lambda* c-string ([addrinfo info] [scheme-pointer buf])
    "socklen_t len = info->ai_addrlen;\n"
    "const void *src = info->ai_addr;\n"
    "switch (info->ai_family) {\n"
    "case AF_INET:\n"
    "  src = &((struct sockaddr_in *)src)->sin_addr;\n"
    "  len = sizeof(struct sockaddr_in);\n"
    "  break;\n"
    "case AF_INET6:\n"
    "  src = &((struct sockaddr_in6 *)src)->sin6_addr;\n"
    "  len = sizeof(struct sockaddr_in6);\n"
    "  break;\n"
    "}\n"
    "C_return(inet_ntop(info->ai_family, src, (char *)buf, len));"))

(define addrinfo-port
  (foreign-lambda* scheme-object ([addrinfo info])
    "uint16_t port = 0;\n"
    "switch (info->ai_family) {\n"
    "case AF_INET:\n"
    "  port = ((struct sockaddr_in *)info->ai_addr)->sin_port;\n"
    "  break;\n"
    "case AF_INET6:\n"
    "  port = ((struct sockaddr_in6 *)info->ai_addr)->sin6_port;\n"
    "  break;\n"
    "}\n"
    "if (port > 0)\n"
    "  C_return(C_fix(ntohs(port)));\n"
    "else\n"
    "  C_return(C_SCHEME_FALSE);\n"))

(define-record-type address-info
  (make-address-info family type host port)
  address-info?
  [family address-info-family]
  [type address-info-type]
  [host address-info-host]
  [port address-info-port])

(define-record-printer (address-info info out)
  (display "#<address-info" out)
  (cond
    [(address-info-type info)
     => (lambda (type)
          (let ([host (address-info-host info)]
                [port (address-info-port info)])
            (display #\space out)
            (display type out)
            (display "://" out)
            (if host
              (if (eq? (address-info-family info) 'ipv6)
                (begin
                  (display #\[ out)
                  (display host out)
                  (display #\] out))
                (display host out))
              (display #\* out))
            (when port
              (display #\: out)
              (display port out))))])
  (display #\> out))

(define (addrinfo->address-info info)
  (make-address-info
    (addrinfo-family info)
    (addrinfo-type info)
    (addrinfo-host info (make-string 64))
    (addrinfo-port info)))

(define (address-infos host #!key [port #f] [family #f] [type #f] [server? (not host)] [numeric? #f])
  (when (number? port)
    (set! port (number->string port)))
  (and-let* ([info (addrinfo-get host port family type server? numeric?)])
    (dynamic-wind
      void
      (lambda ()
        (unfold not addrinfo->address-info addrinfo-next info))
      (lambda ()
        (addrinfo-free! info)))))

)

;; vim: set ai et ts=4 sts=2 sw=2 ft=scheme: ;;