(define-c-library libc
                  `("sys/types.h"
                    "sys/socket.h"
                    "sys/un.h"
                    "netinet/in.h"
                    "netdb.h"
                    "errno.h"
                    "fcntl.h"
                    "poll.h"
                    "string.h")
                  libc-name
                  '((additional-versions ("0" "6"))))

(define-c-procedure c-socket libc 'socket 'int '(int int int))
(define-c-procedure c-setsockopt libc 'setsockopt 'int '(int int int pointer int))
(define-c-procedure c-getaddrinfo libc 'getaddrinfo 'int '(pointer pointer pointer pointer))
(define-c-procedure c-connect libc 'connect 'int '(int pointer int))
(define-c-procedure c-bind libc 'bind 'int '(int pointer int))
(define-c-procedure c-listen libc 'listen 'int '(int int))
(define-c-procedure c-accept libc 'accept 'int '(int pointer pointer))
(define-c-procedure c-perror libc 'perror 'void '(pointer))
(define-c-procedure c-fcntl libc 'fcntl 'int '(int int int))
(define-c-procedure c-htons libc 'htons 'u16 '(u16))
(define-c-procedure c-send libc 'send 'int '(int pointer int int))
(define-c-procedure c-read libc 'read 'int '(int pointer int))
(define-c-procedure c-poll libc 'poll 'int '(pointer int int))
(define-c-procedure c-strcpy libc 'strcpy 'int '(pointer pointer))
(define-c-procedure c-close libc 'close 'int '(int))
(define-c-procedure c-shutdown libc 'shutdown 'int '(int int))


(define-record-type <socket>
  (make-socket file-descriptor)
  socket?
  (file-descriptor socket-file-descriptor))

(define *af-inet* 2)
(define *af-inet6* 10)
(define *af-unix* 1)
(define *af-unspec* 0)

(define *sock-stream* 1)
(define *sock-dgram* 2)

(define *ai-canonname* 2)
(define *ai-numerichost* 4)
(define *ai-v4mapped* 8)
(define *ai-all* 16)
(define *ai-addrconfig* 32)

(define *ipproto-ip* 0)
(define *ipproto-tcp* 6)
(define *ipproto-udp* 17)

(define *msg-peek* 17)
(define *msg-oob* 1)
(define *msg-waitall* 256)

(define *shut-rd* 0)
(define *shut-wr* 1)
(define *shut-rdwr* 2)

(define F-SETFL 4)
(define O-NONBLOCK 2048)
(define EINPROGRESS 115)
(define SOL-SOCKET 1)
(define SO-ERROR 4)
(define POLLIN 1)
(define POLLOUT 4)
(define INADDR-ANY 0)
(define SO-REUSEADDR 2)
(define SO-REUSEPORT 15)
(define AI-PASSIVE 1)

(define +sockaddr-size+ 16)
(define +ai-family-size+ 2)

(define socket-merge-flags (lambda flags (apply + flags)))
(define (socket-purge-flags base-flag . flags) (apply - (cons base-flag flags)))

(define (make-network-socket node service ai-family ai-socktype ai-flags ai-protocol)
  (let* ((ai-family-offset (c-type-size 'int))
         (ai-socktype-offset (* (c-type-size 'int) 2))
         (ai-protocol-offset (* (c-type-size 'int) 3))
         (addrinfo-hints
           (let ((pointer (make-c-bytevector 128 0)))
             (c-bytevector-set! pointer 'int ai-family-offset ai-family)
             (c-bytevector-set! pointer 'int ai-socktype-offset ai-socktype)
             pointer))
         (addrinfo (make-c-bytevector 128 0))
         (addrinfo-result
           (call-with-address-of
             addrinfo
             (lambda (addrinfo-address)
               (call-with-address-of
                 addrinfo-hints
                 (lambda (addrinfo-hints-address)
                   (c-getaddrinfo (string->c-utf8 node)
                                  (string->c-utf8 service)
                                  addrinfo-hints
                                  addrinfo-address))))))
         (socket-file-descriptor
           (c-socket
             (c-bytevector-ref addrinfo 'int ai-family-offset)
             (c-bytevector-ref addrinfo 'int ai-socktype-offset)
             (c-bytevector-ref addrinfo 'int ai-protocol-offset))))
    (when (< addrinfo-result 0)
      (c-perror (string->c-utf8 "make-client-socket (addrinfo) error"))
      (raise-continuable "make-client-socket (addrinfo) error"))
    (when (< socket-file-descriptor 0)
      (c-perror (string->c-utf8 "make-client-socket (socket) error"))
      (raise-continuable "make-client-socket (socket) error"))
    (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0)
      (c-perror (string->c-utf8 "make-client-socket (fcntl) error"))
      (raise-continuable "make-client-socket (fcntl) error"))
    (letrec* ((ai-addr-offset (* (c-type-size 'int) 6))
              (ai-addrlen-offset (* (c-type-size 'int) 4))
              (connect-result
                (c-connect socket-file-descriptor
                           (c-bytevector-ref addrinfo 'pointer ai-addr-offset)
                           (c-bytevector-ref addrinfo 'int ai-addrlen-offset)))
              (pollfd (make-c-bytevector 128 0)))
      (c-bytevector-set! pollfd 'uint 0 socket-file-descriptor)
      (c-bytevector-set! pollfd 'int 0 0)
      ;; FIXME No magic numbers, like 8 or 1 here. Put into variable with good name
      ;; TODO Why 8 works but 1 does not?
      (when (= (c-poll pollfd 8 5000) 0)
        (error "make-client-socket (poll) error")))
    (make-socket socket-file-descriptor)))

(define (make-unix-socket node service ai-family ai-socktype ai-flags ai-protocol)
  (let* ((socket-file-descriptor (c-socket ai-family ai-socktype 0))
         (sockaddr
           (let* ((pointer (make-c-bytevector 128 0))
                  (pointer-address (c-bytevector->address pointer))
                  (node-pointer (address->c-bytevector
                                  (+ pointer-address +ai-family-size+))))
             (c-bytevector-set! pointer 'u16 0 *af-unix*)
             (c-strcpy node-pointer (string->c-utf8 node))
             pointer))
         (sockaddr-size (+ +ai-family-size+ (bytevector-length (string->utf8 node)))))
    (when (< socket-file-descriptor 0)
      (c-perror (string->c-utf8 "make-client-socket (socket) error"))
      (raise-continuable "make-client-socket (socket) error"))
    (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0)
      (c-perror (string->c-utf8 "make-client-socket (fcntl) error"))
      (raise-continuable "make-client-socket (fcntl) error"))
    (let ((connect-result (c-connect socket-file-descriptor sockaddr sockaddr-size)))
      (when (< connect-result 0)
        (c-perror (string->c-utf8 "make-client-socket (connect) error"))
        (raise-continuable "make-client-socket (connect) error"))
      (make-socket socket-file-descriptor))))

(define (make-client-socket node service . args)
  (let* ((ai-family (if (>= (length args) 1) (list-ref args 0) *af-inet*))
         (ai-socktype (if (>= (length args) 2) (list-ref args 1) *sock-stream*))
         (ai-flags (if (>= (length args) 3)
                     (list-ref args 2)
                     (socket-merge-flags *ai-v4mapped* *ai-addrconfig*)))
         (ai-protocol
           (if (>= (length args) 4)
             (list-ref args 3)
             *ipproto-ip*)))
    (if (equal? ai-family *af-unix*)
      (make-unix-socket node service ai-family ai-socktype ai-flags ai-protocol)
      (make-network-socket node service ai-family ai-socktype ai-flags ai-protocol))))

(define message-type
  (lambda names
    (if (null? names)
      #f
      (map
        (lambda (name)
          (cond ((equal? name 'none) #f)
                ((equal? name 'peek) *msg-peek*)
                ((equal? name 'oob) *msg-oob*)
                ((equal? name 'wait-all) *msg-waitall*)))
        names))))

(define (socket-send socket bv . flags)
  (let* ((msg (bytevector->c-bytevector bv))
         (msg-len (bytevector-length bv))
         (sent-count (c-send (socket-file-descriptor socket) msg msg-len 0)))
    (when (= sent-count -1)
      (c-perror (string->c-utf8 "socket-send error"))
      (raise-continuable "socket-send error"))
    sent-count))

(define (socket-recv-loop socket bytes-pointer size)
  (let ((read-result (c-read (socket-file-descriptor socket)
                             bytes-pointer
                             size)))
    (cond ((< read-result 1) (socket-recv-loop socket bytes-pointer size))
          (else
            (c-bytevector->bytevector bytes-pointer size)))))

(define (socket-recv socket size . flags)
  ;; TODO FIXME If connection is closed return empty bytevector
  (let* ((msg-type (if (null? flags)
                     (message-type 'none)
                     (apply message-type flags)))
         (bytes-pointer (make-c-bytevector size 0)))
    (socket-recv-loop socket bytes-pointer size)))

(define (socket-close socket)
  (when (not (socket? socket))
    (error "socket-close: Not a socket" socket))
  (c-close (socket-file-descriptor socket)))

(define (make-network-server-socket-old service ai-family ai-socktype ai-protocol)
  (let* ((socket-file-descriptor (c-socket ai-family ai-socktype 0))
         (node "127.0.0.1")
         (sockaddr
           (let* ((pointer (make-c-bytevector 128 0))
                  (pointer-address (c-bytevector->address pointer))
                  (node-pointer (address->c-bytevector
                                  (+ pointer-address +ai-family-size+))))
             (c-bytevector-set! pointer 'u16 0 *af-inet*)
             (c-bytevector-set! pointer
                                'u16
                                (c-type-size 'u16)
                                (c-htons (string->number service)))
             (c-bytevector-set! pointer 'u16 (* (c-type-size 'u16) 2) INADDR-ANY)
             ;(c-strcpy node-pointer (string->c-utf8 node))
             pointer))
         (option (let ((pointer (make-c-bytevector (c-type-size 'int))))
                   (c-bytevector-set! pointer 'int 0 1)
                   pointer))
         (sockaddr-size (+ +ai-family-size+ (bytevector-length (string->utf8 node)))))
    (when (< socket-file-descriptor 0)
      (c-perror (string->c-utf8 "make-server-socket (socket) error"))
      (raise-continuable "make-server-socket (socket) error"))
    (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0)
      (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error"))
      (raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error"))
    (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0)
      (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error"))
      (raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error"))
    (when (< (c-bind socket-file-descriptor sockaddr +sockaddr-size+) 0)
      (c-perror (string->c-utf8 "socket-accept (bind) error"))
      (raise-continuable "socket-accept (bind) error"))
    (when (< (c-listen socket-file-descriptor 0) 0)
      (c-perror (string->c-utf8 "make-server-socket (listen) error"))
      (raise-continuable "make-server-socket (listen) error"))
    (make-socket socket-file-descriptor)))

(define (make-network-server-socket service ai-family ai-socktype ai-protocol)
  (let* ((ai-flags AI-PASSIVE)
         (ai-flags-offset 0)
         (ai-family-offset (c-type-size 'int))
         (ai-socktype-offset (* (c-type-size 'int) 2))
         (ai-protocol-offset (* (c-type-size 'int) 3))
         (addrinfo-hints
           (let ((pointer (make-c-bytevector 128 0)))
             (c-bytevector-set! pointer 'int ai-flags-offset ai-flags)
             (c-bytevector-set! pointer 'int ai-family-offset ai-family)
             (c-bytevector-set! pointer 'int ai-socktype-offset ai-socktype)
             pointer))
         (addrinfo (make-c-bytevector 128 0))
         (addrinfo-result
           (call-with-address-of
             addrinfo
             (lambda (addrinfo-address)
               (call-with-address-of
                 addrinfo-hints
                 (lambda (addrinfo-hints-address)
                   (c-getaddrinfo (string->c-utf8 "0.0.0.0")
                                  (string->c-utf8 service)
                                  addrinfo-hints
                                  addrinfo-address))))))
         (socket-file-descriptor
           (c-socket
             (c-bytevector-ref addrinfo 'int ai-family-offset)
             (c-bytevector-ref addrinfo 'int ai-socktype-offset)
             (c-bytevector-ref addrinfo 'int ai-protocol-offset)))
         (option (let ((pointer (make-c-bytevector (c-type-size 'int))))
                   (c-bytevector-set! pointer 'int 0 1)
                   pointer))
         (ai-addr-offset (* (c-type-size 'int) 6))
         (ai-addr (c-bytevector-ref addrinfo 'pointer ai-addr-offset))
         (ai-addrlen-offset (* (c-type-size 'int) 4))
         (ai-addr-len (c-bytevector-ref addrinfo 'int ai-addrlen-offset)))
    (when (< addrinfo-result 0)
      (c-perror (string->c-utf8 "make-server-socket (addrinfo) error"))
      (raise-continuable "make-server-socket (addrinfo) error"))
    (when (< socket-file-descriptor 0)
      (c-perror (string->c-utf8 "make-server-socket (socket) error"))
      (raise-continuable "make-server-socket (socket) error"))
    (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0)
      (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error"))
      (raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error"))
    (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0)
      (c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error"))
      (raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error"))
    (when (< (c-bind socket-file-descriptor ai-addr ai-addr-len) 0)
      (c-perror (string->c-utf8 "make-server-socket (bind) error"))
      (raise-continuable "make-servever-socket (bind) error"))
    (when (< (c-listen socket-file-descriptor 5) 0)
      (c-perror (string->c-utf8 "make-server-socket (listen) error"))
      (raise-continuable "make-server-socket (listen) error"))
    (make-socket socket-file-descriptor)))

(define (make-server-socket service . args)
  (let* ((ai-family (if (>= (length args) 1) (list-ref args 0) *af-inet*))
         (ai-socktype (if (>= (length args) 2) (list-ref args 1) *sock-stream*))
         (ai-protocol (if (>= (length args) 3) (list-ref args 2) *ipproto-ip*)))
    (if (equal? ai-family *af-unix*)
      ;(make-unix-server-socket node service ai-family ai-socktype ai-protocol)
      (error "Unix server sockets are WIP")
      (make-network-server-socket service ai-family ai-socktype ai-protocol))))

(define (socket-accept socket)
  (let* ((addrlen (let ((pointer (make-c-bytevector (c-type-size 'int))))
                    (c-bytevector-set! pointer 'int 0 128)
                    pointer))
         (client-sockaddr (make-c-bytevector 128 0))
         (accepted-socket (c-accept (socket-file-descriptor socket)
                                    client-sockaddr
                                    addrlen)))
    (when (< accepted-socket 0)
      (c-perror (string->c-utf8 "socket-accept (accept) error"))
      (raise-continuable "socket-accept (accept) error"))
    (make-socket accepted-socket)))

(define (call-with-socket socket thunk)
  (let ((result (apply thunk (list socket))))
    (socket-close socket)
    result))

(define (socket-shutdown socket how)
  (c-shutdown (socket-file-descriptor socket) how))

(define-syntax address-family
  (syntax-rules ()
    ((_ name)
     (cond ((symbol=? 'name 'inet) *af-inet*)
           ((symbol=? 'name 'inet6) *af-inet6*)
           ((symbol=? 'name 'unspec) *af-unspec*)
           ((symbol=? 'name 'unix) *af-unix*)
           (else (error "address-family: Unrecognized name" name))))))

(define-syntax address-info
  (syntax-rules ()
    ((_ names ...)
     (apply socket-merge-flags
            (map (lambda (name)
                   (cond ((symbol=? name 'canoname) *ai-canoname*)
                         ((symbol=? name 'numerichost) *ai-numerichost*)
                         ((symbol=? name 'v4mapped) *ai-v4mapped*)
                         ((symbol=? name 'all) *ai-all*)
                         ((symbol=? name 'addrconfig) *ai-addrconfig*)
                         (else (error "address-info: Unrecognized name" name))))
                 '(names ...))))))

(define-syntax socket-domain
  (syntax-rules ()
    ((_ name)
     (cond ((symbol=? 'name 'stream) *sock-stream*)
           ((symbol=? 'name 'datagram) *af-unix*)
           (else (error "socket-domain: Unrecognized name" name))))))

(define-syntax ip-protocol
  (syntax-rules ()
    ((_ name)
     (cond ((symbol=? 'name 'ip) *ipproto-ip*)
           ((symbol=? 'name 'tcp) *ipproto-tcp*)
           ((symbol=? 'name 'udp) *ipproto-udp*)
           (else (error "ip-protocol: Unrecognized name" name))))))

(define-syntax shutdown-method
  (syntax-rules ()
    ((_ names ...)
     (cond ((and (member 'read '(names ...))
                 (member 'write '(names ...)))
            *shut-rdwr*)
           ((symbol=? (member 'read '(names ...)) 'read) *shut-rd*)
           ((symbol=? (member 'write '(names ...)) 'write) *shut-wr*)
           (else (error "shutdown-method: Names must be either read, write or both"))))))