;; https://github.com/racket/unix-socket
;; License: Apache 2.0/MIT
;; FFI functions, constants, and types for unix domain sockets (unsafe)
#lang racket/base
(require ffi/unsafe
         ffi/unsafe/define
         ffi/unsafe/port)
(provide (protect-out (all-defined-out)))

;; platform : (U 'bsd 'linux #f)
;; Data structures and constants differ between platforms.
;; Mac OS X and the BSDs I tried seem to have consistent definitions.
(define platform
  (case (system-type 'os)
    [(macosx) 'bsd]
    [(unix)
     (define sys (path->string (system-library-subpath #f)))
     (cond [(regexp-match? #rx"-linux$" sys) 'linux]
           [(regexp-match? #rx"bsd$" sys) 'bsd]
           [else #f])]
    [else #f]))

(define unix-socket-available?
  (and platform #t))

;; ========================================
;; Constants

;; linux: bits/socket.h; bsd/macosx: sys/socket.h
(define AF-UNIX 1)
(define SOCK-STREAM 1)
(define SOCK-SEQPACKET 5)

;; linux: sys/socket.h; bsd/macosx: sys/socket.h
(define SHUT_RD 0)
(define SHUT_WR 1)

;; linux: asm-generic/{errno-base,errno}.h; bsd/macosx: sys/errno.h
(define EINTR           4)
(define EAGAIN          (case platform [(linux) 11]  [(bsd) 35]))
(define EWOULDBLOCK     EAGAIN)
(define EINPROGRESS     (case platform [(linux) 115] [(bsd) 36]))
(define ENOTCONN        (case platform [(linux) 107] [(bsd) 57]))

;; linux: asm-generic/fcntl.h; bsd/macosx: sys/fcntl.h
(define F_SETFL         4)
(define O_NONBLOCK      (case platform [(linux) #o4000] [(bsd) 4]))

;; linux: asm-generic/socket.h; bsd/macosx: sys/socket.h
(define SOL_SOCKET      (case platform [(linux) 1] [(bsd) #xFFFF]))
(define SO_ERROR        (case platform [(linux) 4] [(bsd) #x1007]))

;; linux: sys/un.h; bsd/macosx: sys/un.h
(define UNIX-PATH-MAX   (case platform [(linux) 108] [else 104]))

;; linux: bits/sockaddr.h; bsd/macosx: sys/un.h
(define _sa_family (case platform [(linux) _ushort] [else _ubyte]))

;; linux: bits/types.h; bsd/macosx: i386/_types.h
(define _socklen_t _uint32)

(define-cstruct _linux_sockaddr_un
  ([sun_family _sa_family]
   [sun_path   (make-array-type _byte UNIX-PATH-MAX)]))

(define-cstruct _bsd_sockaddr_un
  ([sun_len    _ubyte]
   [sun_family _sa_family]
   [sun_path   (make-array-type _byte UNIX-PATH-MAX)]))

(define _sockaddr_un-pointer
  (case platform
    [(linux)  _linux_sockaddr_un-pointer]
    [(bsd) _bsd_sockaddr_un-pointer]
    [else     _pointer]))

(define (make-sockaddr path-bytes)
  (case platform
    [(linux)
     (make-linux_sockaddr_un AF-UNIX path-bytes)]
    [(bsd)
     (make-bsd_sockaddr_un (bytes-length path-bytes) AF-UNIX path-bytes)]))

;; ========================================
;; System functions

(define-ffi-definer define-libc (ffi-lib #f)
  #:default-make-fail make-not-available)

(define-libc socket
  (_fun #:save-errno 'posix
        _int _int _int -> _int))

(define-libc connect
  (_fun #:save-errno 'posix
        _int _sockaddr_un-pointer _int -> _int))

(define-libc bind
  (_fun #:save-errno 'posix
        _int _sockaddr_un-pointer _int -> _int))

(define-libc listen
  (_fun #:save-errno 'posix
        _int _int -> _int))

(define-libc accept
  (_fun #:save-errno 'posix
        _int (_pointer = #f) (_pointer = #f)
        -> _int))

(define-libc close
  (_fun #:save-errno 'posix
        _int -> _int))

(define-libc shutdown
  (_fun #:save-errno 'posix
        _int _int -> _int))

(define-libc fcntl
  (_fun #:save-errno 'posix
        _int _int _int -> _int))

(define-libc getsockopt
  (_fun #:save-errno 'posix
        _int _int _int (value : (_ptr io _int) = 0) (len : (_ptr io _uint32) = (ctype-sizeof _int))
        -> (result : _int)
        -> (cond [(zero? result)
                   value]
                  [else
                   (error 'getsockopt "error~a" (errno-error-lines (saved-errno)))])))

(define strerror-name
  (case platform
    [(linux) "__xpg_strerror_r"]
    [else    "strerror_r"]))

(define strerror_r
  (get-ffi-obj strerror-name #f
               (_fun (errno) ::
                     (errno : _int)
                     (buf : _bytes = (make-bytes 1000))
                     (buf-len : _size = (bytes-length buf))
                     -> _void
                     -> (cast buf _bytes _string/locale))
               (lambda ()
                 (lambda (errno) #f))))

(define (errno-error-lines errno)
  (define err (strerror_r errno))
  (format "\n  errno: ~a~a" errno (if err (format "\n  error: ~a" err) "")))


;; ========================================
;; Racket constants and functions

;; indirection to support testing; see below
(define (fd->evt fd mode)
  (unsafe-fd->evt fd mode #t))

;; ============================================================
;; Testing

;; The unix socket code is difficult to test completely, because there
;; are errors/conditions that the kernel may return that are
;; infeasible to deliberately provoke. So optionally replace certain
;; system calls here with mock versions just for testing.

;; An alternative would be to use units; that would allow testing with
;; the mocked system calls without editing the source, but I don't
;; want the overhead of units :/

(when #f
  ;; -- mock for connect returning EINPROGRESS
  (let ([real-connect connect]
        [real-fd->evt fd->evt])
    ;; connecting-fds : hash[nat => #t]
    (define connecting-fds (make-hash))
    (set! connect
          (lambda (s addr len)
            (define r (real-connect s addr len))
            (cond [(zero? r)
                   (hash-set! connecting-fds s #t)
                   (saved-errno EINPROGRESS)
                   (eprintf "** mock connect: setting EINPROGRESS\n")
                   -1]
                  [else r])))
    (set! fd->evt
          (lambda (fd kind)
            (cond [(and (eq? kind 'write)
                        (hash-ref connecting-fds fd #f))
                   (define sema (make-semaphore))
                   (eprintf "** mock fd_to_sema: creating semaphore\n")
                   (thread (lambda ()
                             (sleep 1)
                             (eprintf "** mock fd_to_sema: posting to semaphore\n")
                             (semaphore-post sema)))
                   (hash-remove! connecting-fds fd)
                   sema]
                  [else
                   (real-fd->evt fd kind)])))))

;; mock for accept returning EWOULDBLOCK/EAGAIN no longer works,
;; probably because doesn't intercept unsafe-poll-ctx-fd-wakeup
(when #f
  ;; - mock for accept returning EWOULDBLOCK/EAGAIN
  (let ([real-accept accept]
        [real-fd->evt fd->evt])
    ;; accepting-fds : hash[nat => #t]
    (define accepting-fds (make-hash))
    (set! accept
          (lambda (s)
            (cond [(hash-ref accepting-fds s #f)
                   (hash-remove! accepting-fds s)
                   (real-accept s)]
                  [else
                   (eprintf "** mock accept: setting EWOULDBLOCK\n")
                   (hash-set! accepting-fds s #t)
                   (saved-errno EWOULDBLOCK)
                   -1])))
    (set! fd->evt
          (lambda (fd kind)
            (cond [(and (eq? kind 'read)
                        (hash-ref accepting-fds fd #f))
                   (define sema (make-semaphore))
                   (eprintf "** mock fd_to_sema: creating semaphore\n")
                   (thread (lambda ()
                             (sleep 1)
                             (eprintf "** mock fd_to_sema: posting to semaphore\n")
                             (semaphore-post sema)))
                   sema]
                  [else
                   (real-fd->evt fd kind)])))))