;;; -*- Mode: Scheme; scheme48-package: network-sockets -*-

;;;; Scheme48 Networking Interface
;;;; Sockets

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define-record-type socket :socket
  (%make-socket channel family condvar inport outport)
  socket?
  (channel      socket:channel)
  (family       socket:family)
  (condvar      socket:condvar)
  (inport       socket:inport)
  (outport      socket:outport))

(define (make-socket channel out-name family)
  (%make-socket channel family
                (make-condvar)
                (input-channel->port channel)
                (output-channel->port
                 (dup-channel channel
                              (enum channel-status-option OUTPUT)
                              out-name))))

(define-record-discloser :socket
  (lambda (socket)
    (list 'SOCKET
          (socket:family socket)
          (socket:channel socket))))

(define (create-socket protocol-family socket-type . protocol-option)
  (let ((channel-or-errno
         (%create-socket protocol-family socket-type
                         (or (and (pair? protocol-option)
                                  (car protocol-option))
                             0)
                         "socket input")))
    (if (integer? channel-or-errno)
        (apply syscall-error channel-or-errno create-socket
               protocol-family socket-type protocol-option)
        (make-socket channel-or-errno
                     "socket output"
                     protocol-family))))

(define (create-socket-pair domain type . protocol-option)
  (let ((pair-or-errno
         (%create-socket-pair domain type
                              (or (and (pair? protocol-option)
                                       (car protocol-option))
                                  0)
                              "left socket input"
                              "right socket input")))
    (if (integer? pair-or-errno)
        (apply syscall-error pair-or-errno create-socket-pair
               domain type protocol-option)
        (values (make-socket (car pair-or-errno)
                             "left socket output"
                             domain)
                (make-socket (cdr pair-or-errno)
                             "right socket output"
                             domain)))))

(define (close-socket socket)
  (if (socket? socket)
      (begin (close-input-port (socket:inport socket))
             (close-output-port (socket:outport socket)))
      (call-error "invalid argument" close-socket socket)))

(define (port->socket port family)
  (cond ((port->channel port)
         => (lambda (channel)
              (make-socket channel "socket output" family)))
        (else
         (call-error "invalid argument -- not a channel port"
                     port->socket port family))))

(define-record-type socket-address :socket-address
  (%%make-socket-address data)
  socket-address?
  (data socket-address-data))

(define (%make-socket-address data)
  (if (>= (byte-vector-length data)
          (+ sockaddr.family-offset
             sockaddr.family-size))
      (%%make-socket-address (make-immutable! data))
      (error "invalid sockaddr data" data)))

(define (socket-address:family socket-address)
  (sockaddr.family (socket-address-data socket-address) 0))

(define (make-socket-address family data)
  (set-sockaddr.family! data 0 family)
  (%make-socket-address data))

(define (unix-address->socket-address pathname)
  (if (and (string? pathname)
           (<= (string-length pathname)
               sockaddr-un.path-size))
      (make-socket-address
       address-family/unix
       (let ((sockaddr (allocate-sockaddr-un)))
         (copy-bytes! pathname 0
                      sockaddr sockaddr-un.path-offset
                      (string-length pathname))
         sockaddr))
      (call-error "invalid argument -- pathname too long"
                  unix-address->socket-address
                  pathname)))

(define (internet-address->socket-address host port)
  (let ((lose (lambda ()
                (call-error "invalid arguments"
                            internet-address->socket-address
                            host port))))
    (if (and (exact-integer? port)
             (<= 0 port #xFFFF))
        (decompose-integer32 host
          (lambda (a b c d)
            (make-socket-address
             address-family/internet
             (make-sockaddr-in port (byte-vector a b c d))))
          lose)
        (lose))))

(define (socket-address->unix-address socket-address)
  (if (= (socket-address:family socket-address)
         address-family/unix)
      (sockaddr-un.path (socket-address-data socket-address))
      (call-error "not a Unix socket address"
                  socket-address->unix-address
                  socket-address)))

(define (socket-address->internet-address socket-address)
  (if (= (socket-address:family socket-address)
         address-family/internet)
      (let ((data (socket-address-data socket-address)))
        (values (compose-integer32 (sockaddr-in.address-ref data 0 0)
                                   (sockaddr-in.address-ref data 0 1)
                                   (sockaddr-in.address-ref data 0 2)
                                   (sockaddr-in.address-ref data 0 3))
                (sockaddr-in.port data 0)))
      (call-error "not an internet socket address"
                  socket-address->internet-address
                  socket-address)))

(define-record-discloser :socket-address
  (lambda (socket-address)
    (list 'SOCKET-ADDRESS
          (socket-address:family-name socket-address)
          (socket-address->string socket-address))))

(define (socket-address:family-name socket-address)
  (let ((family (socket-address:family socket-address)))
    (cond ((= family address-family/unix)       'UNIX)
          ((= family address-family/internet)   'INTERNET)
          (else
           (error "socket with unrecognized address family"
                  socket-address)))))

(define (socket-address->string socket-address)
  (let ((family (socket-address:family socket-address))
        (data (socket-address-data socket-address)))
    (cond ((= family address-family/unix)
           (sockaddr-un.path data))
          ((= family address-family/internet)
           (let ((octet (lambda (index)
                          (number->string
                           (sockaddr-in.address-ref data 0 index)
                           10))))
             (string-append (octet 0) "." (octet 1) "."
                            (octet 2) "." (octet 3) ":"
                            (number->string (sockaddr-in.port data 0)
                                            10))))
          (else
           (error "socket with unrecognized address family"
                  socket-address)))))

;++ This relies on byte vectors and strings being isomorphic.  This is
;++ a bad assumption.  It would probably be better just to use byte
;++ vectors the whole way.

(define (sockaddr-un.path data)
  (let* ((offset sockaddr-un.path-offset)
         (limit (+ offset sockaddr-un.path-size)))
    (do ((i offset (+ i 1)))
        ((or (= i limit)
             (zero? (byte-vector-ref data i)))
         (byte-vector->string data offset i)))))

(define (byte-vector->string bv start end)
  (let* ((length (- end start))
         (string (make-string length)))
    (copy-bytes! bv start string 0 length)
    string))

;; (put 'decompose-integer32 'scheme-indent-function 1)

(define (decompose-integer32 datum win lose)
  (cond ((and (exact-integer? datum)
              (<= 0 datum #xFFFFFFFF))
         (win (arithmetic-shift datum -24)
              (bitwise-and (arithmetic-shift datum -16) #xFF)
              (bitwise-and (arithmetic-shift datum -8) #xFF)
              (bitwise-and datum #xFF)))
        ((and (byte-vector? datum)
              (= 4 (byte-vector-length datum)))
         (win (byte-vector-ref datum 0)
              (byte-vector-ref datum 1)
              (byte-vector-ref datum 2)
              (byte-vector-ref datum 3)))
        (else
         (lose))))

(define (compose-integer32 a b c d)
  (bitwise-ior (arithmetic-shift a 24)
               (arithmetic-shift b 16)
               (arithmetic-shift c 8)
               d))

(define (connect-socket socket socket-address)
  (*connect-socket socket socket-address connect-socket
                   really-connect-socket))

(define (really-connect-socket channel address condvar)
  (let loop ((retrying? #f))
    (if (not (maybe-connect-socket channel address condvar retrying?))
        (begin (wait-for-condvar condvar)
               (loop #t)))))

(define (connect-socket-no-wait socket socket-address)
  (*connect-socket socket socket-address connect-socket-no-wait
                   really-connect-socket-no-wait))

(define (really-connect-socket-no-wait channel address condvar)
  (maybe-connect-socket channel address condvar #f))

(define (maybe-connect-socket channel address condvar retrying?)
  (let ((interrupts (disable-interrupts!)))
    (if (%connect-socket channel address retrying?)
        (begin (set-enabled-interrupts! interrupts)
               #t)
        (begin (wait-for-channel channel condvar)
               (set-enabled-interrupts! interrupts)
               #f))))

(define (*connect-socket socket socket-address caller body)
  (cond ((not (and (socket? socket)
                   (socket-address? socket-address)))
         (call-error "invalid arguments"
                     caller socket socket-address))
        ((not (= (socket:family socket)
                 (socket-address:family socket-address)))
         (call-error "mismatched socket protocol and address families"
                     caller socket socket-address))
        (else
         (body (socket:channel socket)
               (socket-address-data socket-address)
               (socket:condvar socket)))))

(define (connect-socket-successful? socket)
  ;; No error is zero; if we use boolean options, this maps to false.
  (not (boolean-socket-option socket level/socket socket/error)))

;;; %BIND-SOCKET and %LISTEN-SOCKET return false to indicate success
;;; and an errno value as an integer to indicate failure.

(define (bind-socket socket address)
  (cond ((%bind-socket (socket:channel socket)
                       (socket-address-data address))
         => (lambda (errno)
              (syscall-error errno bind-socket socket address)))))

(define (listen-socket socket backlog)
  (cond ((%listen-socket (socket:channel socket)
                         backlog)
         => (lambda (errno)
              (syscall-error errno listen-socket socket backlog)))))

(define (accept-connection socket)
  (let ((channel (socket:channel socket))
        (condvar (socket:condvar socket)))
    (let loop ()
      (let ((interrupts (disable-interrupts!)))
        (cond ((%accept-connection channel "accepted socket input")
               => (lambda (result)
                    (set-enabled-interrupts! interrupts)
                    (if (integer? result)
                        (syscall-error result
                                       accept-connection
                                       socket)
                        (values (make-socket (car result)
                                             "accepted socket output"
                                             (socket:family socket))
                                (%make-socket-address (cdr result))))))
              (else
               (wait-for-channel* channel condvar interrupts)
               (loop)))))))

(define (wait-for-channel* channel condvar interrupts)
  (wait-for-channel channel condvar)
  (set-enabled-interrupts! interrupts)
  (wait-for-condvar condvar))

(define (wait-for-condvar condvar)
  (with-new-proposal (lose)
    (if (not (maybe-commit-and-wait-for-condvar condvar))
        (lose))))

(define (socket-local-address socket)
  (if (= (socket:family socket) protocol-family/unix)
      (call-error "invalid argument -- Unix domain socket"
                  socket-local-address socket)
      (let ((address-or-errno
             (%socket-local-address (socket:channel socket))))
        (if (integer? address-or-errno)
            (syscall-error address-or-errno
                           socket-local-address socket)
            (%make-socket-address address-or-errno)))))

(define (socket-remote-address socket)
  (if (= (socket:family socket) protocol-family/unix)
      (call-error "invalid argument -- Unix domain socket"
                  socket-remote-address socket)
      (let ((address-or-errno
             (%socket-remote-address (socket:channel socket))))
        (if (integer? address-or-errno)
            (syscall-error address-or-errno
                           socket-remote-address socket)
            (%make-socket-address address-or-errno)))))

(define (shutdown-socket socket how)
  (cond ((%shutdown-socket (socket:channel socket) how)
         => (lambda (errno)
              (syscall-error errno shutdown-socket socket how)))))

(define (socket-option socket level option)
  (cond ((socket-option-accessor option)
         => (lambda (accessor)
              (accessor socket level option)))
        (else
         (call-error "invalid option argument"
                     socket-option socket level option))))

(define (set-socket-option socket level option value)
  (cond ((socket-option-modifier option)
         => (lambda (modifier)
              (cond ((modifier (socket:channel socket)
                               level
                               option
                               value)
                     => (lambda (errno)
                          (syscall-error errno set-socket-option
                                         socket level option
                                         value))))))
        (else
         (call-error "invalid option argument"
                     set-socket-option socket level option value))))

(define (socket-option-accessor option)
  (cond ((boolean-socket-option? option) boolean-socket-option)
        ((integer-socket-option? option) integer-socket-option)
        ((linger-socket-option?  option)  linger-socket-option)
        ((timeout-socket-option? option) timeout-socket-option)
        (else #f)))

(define (socket-option-modifier option)
  (cond ((boolean-socket-option? option) %set-boolean-socket-option)
        ((integer-socket-option? option) %set-integer-socket-option)
        ((linger-socket-option?  option)  %set-linger-socket-option)
        ((timeout-socket-option? option)  set-timeout-socket-option)
        (else #f)))

(define (boolean-socket-option socket level option)
  (let ((result (%boolean-socket-option (socket:channel socket)
                                        level
                                        option)))
    (if (integer? result)
        (syscall-error result socket-option socket level option)
        result)))

(define (integer-socket-option socket level option)
  (let ((result (%integer-socket-option (socket:channel socket)
                                        level
                                        option)))
    (let ((ok? (car result))
          (value (cdr result)))
      (if (not ok?)
          (syscall-error value socket-option socket level option)
          value))))

(define (linger-socket-option socket level option)
  (let ((result (%linger-socket-option (socket:channel socket)
                                       level
                                       option)))
    (let ((ok? (car result))
          (value (cdr result)))
      (if (not ok?)
          (syscall-error value socket-option socket level option)
          value))))

(define (timeout-socket-option socket level option)
  (let ((result (%timeout-socket-option (socket:channel socket)
                                        level
                                        option)))
    (if (integer? result)
        (syscall-error result socket-option socket level option)
        (+ (* (car result) 1000)
           (cdr result)))))

(define (set-timeout-socket-option socket level option timeout)
  (%set-timeout-socket-option socket level option
                              (quotient  timeout 1000)
                              (remainder timeout 1000)))

(define (boolean-socket-option? option)
  (memq option (list socket/debug
                     socket/accept-connect
                     socket/reuse-address
                     socket/keep-alive
                     socket/dont-route
                     socket/broadcast
                     socket/use-loop-back
                     socket/oob-inline
                     socket/reuse-port
                     tcp/no-delay
                     )))

(define (integer-socket-option? option)
  (memq option (list socket/send-buffer
                     socket/receive-buffer
                     socket/send-low-water
                     socket/receive-low-water
                     socket/error
                     socket/type
                     ip/time-to-live
                     tcp/max-segment
                     )))

(define (linger-socket-option? option)
  (eq? option socket/linger))

(define (timeout-socket-option? option)
  (or (eq? option socket/send-timeout)
      (eq? option socket/receive-timeout)))

(define (send-message socket bytev . args)
  (let-optionals args ((start 0)
                       (end (byte-vector-length bytev))
                       (flags 0)
                       (address #f))
    (if (not (and (socket? socket)
                  (byte-vector-range? bytev start end)
                  (exact-nonnegative-integer? flags)
                  (or (not address)
                      (socket-address? address))))
        (apply call-error "invalid arguments"
               send-message socket bytev args)
        (send-loop socket bytev start end flags
                   (if address
                       (sender-to address)
                       %socket-send)
                   `(,send-message ,bytev ,@args)))))

(define (send-loop socket bytev start end flags sender error-cruft)
  (let ((channel (socket:channel socket))
        (condvar (socket:condvar socket)))
    (let loop ((start start))
      (if (< start end)
          (let ((interrupts (disable-interrupts!)))
            (cond ((sender channel bytev start end flags)
                   => (lambda (result)
                        (set-enabled-interrupts! interrupts)
                        (let ((ok? (car result))
                              (value (cdr result)))
                          (if (not ok?)
                              (apply syscall-error value error-cruft)
                              (loop (+ start value))))))
                  (else
                   (wait-for-channel* channel condvar interrupts)
                   (loop start))))))))

(define (sender-to address)
  (let ((address (socket-address-data address)))
    (lambda (channel bytev start end flags)
      (%socket-sendto channel address bytev start end flags))))

(define (send-message/partial socket bytev . args)
  (let-optionals args ((start 0)
                       (end (byte-vector-length bytev))
                       (flags 0)
                       (address #f))
    (if (not (and (socket? socket)
                  (byte-vector-range? bytev start end)
                  (exact-nonnegative-integer? flags)
                  (or (not address)
                      (socket-address? address))))
        (apply call-error "invalid arguments"
               send-message/partial socket bytev args)
        (send/partial-loop socket bytev start end flags
                           (if address
                               (sender-to address)
                               %socket-send)
                           `(,send-message/partial ,socket ,bytev
                                                   ,@args)))))

(define (send/partial-loop socket bytev start end flags sender
                           error-cruft)
  (if (= start end)
      0
      (let ((channel (socket:channel socket))
            (condvar (socket:condvar socket)))
        (let loop ()
          (let ((interrupts (disable-interrupts!)))
            (cond ((sender channel bytev start end flags)
                   => (lambda (result)
                        (set-enabled-interrupts! interrupts)
                        (let ((ok? (car result))
                              (value (cdr result)))
                          (if (not ok?)
                              (apply syscall-error value error-cruft)
                              value))))
                  (else
                   (wait-for-channel channel condvar)
                   (set-enabled-interrupts! interrupts)
                   (wait-for-condvar condvar)
                   (loop))))))))

(define (receive-message socket length . flags)
  (let ((flags (:optional flags 0)))
    (cond ((not (and (socket? socket)
                     (exact-nonnegative-integer? length)
                     (exact-nonnegative-integer? flags)))
           (apply call-error "invalid arguments"
                  receive-message socket length flags))
          ((zero? length)
           (make-byte-vector 0 0))
          (else
           (let ((bytev (make-byte-vector length 0)))
             (receive (received address)
                      (%receive-message! socket bytev 0 length flags
                                         `(,receive-message ,socket
                                                            ,length
                                                            ,@flags))
               (values (cond ((not received) #f)     ; EOF
                             ((= received length) bytev)
                             (else (byte-subvector bytev 0 received)))
                       address)))))))

(define (receive-message! socket bytev . args)
  (let-optionals args ((start 0)
                       (end (byte-vector-length bytev))
                       (flags 0))
    (cond ((not (and (socket? socket)
                     (byte-vector-range? bytev start end)
                     (exact-nonnegative-integer? flags)))
           (apply call-error "invalid arguments"
                  receive-message! socket bytev args))
          ((= start end) 0)
          (else
           (%receive-message! socket bytev start end flags
                              `(,%receive-message! ,socket ,bytev
                                                   ,@args))))))

(define (%receive-message! socket bytev start end flags error-cruft)
  (let ((channel (socket:channel socket))
        (condvar (socket:condvar socket)))
    (let loop ((i start) (address #f))
      (if (> i start)
          (values (- i start) (%make-socket-address address))
          (let ((interrupts (disable-interrupts!)))
            (cond ((%socket-recvfrom channel bytev start end flags)
                   => (lambda (result)
                        (set-enabled-interrupts! interrupts)
                        (if (integer? result)
                            (apply syscall-error result error-cruft)
                            (let ((received (car result))
                                  (address (cdr result)))
                              (if (zero? received)
                                  (values (and (positive? (- i start))
                                               (- i start))
                                          (%make-socket-address
                                           address))
                                  (loop (+ i received) address))))))
                  (else
                   (wait-for-channel* channel condvar interrupts)
                   (loop i address))))))))

(define (receive-message/partial socket length . flags)
  (let-optionals flags ((flags 0))
    (cond ((not (and (socket? socket)
                     (exact-nonnegative-integer? length)
                     (exact-nonnegative-integer? flags)))
           (apply call-error "invalid arguments"
                  receive-message/partial socket length flags))
          ((zero? length)
           (make-byte-vector 0 0))
          (else
           (let ((bytev (make-byte-vector length 0)))
             (receive (received address)
                      (%receive-message!/partial
                       socket bytev 0 length flags
                       `(,receive-message/partial ,socket ,length
                                                  ,@flags))
               (values (cond ((not received) #f)        ; EOF
                             ((= received length) bytev)
                             (else (byte-subvector bytev 0 received)))
                       address)))))))

(define (receive-message!/partial socket bytev . args)
  (let-optionals args ((start 0)
                       (end (byte-vector-length bytev))
                       (flags 0))
    (cond ((not (and (socket? socket)
                     (byte-vector-range? bytev start end)
                     (exact-nonnegative-integer? flags)))
           (apply call-error "invalid arguments"
                  receive-message!/partial socket bytev args))
          ((= start end) 0)
          (else
           (%receive-message!/partial socket bytev start end flags
                                      `(,receive-message!/partial
                                        ,socket ,bytev ,@args))))))

(define (%receive-message!/partial socket bytev start end flags
                                   error-cruft)
  (let ((channel (socket:channel socket))
        (condvar (socket:condvar socket)))
    (let loop ()
      (let ((interrupts (disable-interrupts!)))
        (cond ((%socket-recvfrom channel bytev start end flags)
               => (lambda (result)
                    (set-enabled-interrupts! interrupts)
                    (if (integer? result)
                        (apply syscall-error result error-cruft)
                        (let ((received (car result))
                              (address (cdr result)))
                          (values (and (positive? received)
                                       received)
                                  (%make-socket-address address))))))
              (else
               (wait-for-channel* channel condvar interrupts)
               (loop)))))))

(define (exact-integer? obj)
  (and (integer? obj) (exact? obj)))

(define (exact-nonnegative-integer? obj)
  (and (exact-integer? obj) (<= 0 obj)))

(define (byte-vector-range? bytev start end)
  (and (byte-vector? bytev)
       (exact-integer? start)
       (exact-integer? end)
       (<= start end)
       (let ((length (byte-vector-length bytev)))
         (and (<= 0 start length)
              (<= 0 end length)))))

(define (byte-subvector bytev start end)
  (let* ((length (- end start))
         (result (make-byte-vector length 0)))
    (do ((i start (+ i 1))
         (j   0   (+ j 1)))
        ((= j length) result)
      (byte-vector-set! result j (byte-vector-ref bytev i)))))

(import-lambda-definition %create-socket (domain type protocol id)
                          "s48_create_socket")
(import-lambda-definition %create-socket-pair (domain type protocol
                                                      id0 id1)
                          "s48_create_socket_pair")
(import-lambda-definition %shutdown-socket (socket how)
                          "s48_shutdown_socket")

(import-lambda-definition %bind-socket (socket address)
                          "s48_bind_socket")
(import-lambda-definition %listen-socket (socket backlog)
                          "s48_listen_socket")

(import-lambda-definition %socket-local-address (socket)
                          "s48_socket_local_address")
(import-lambda-definition %socket-remote-address (socket)
                          "s48_socket_remote_address")

(import-lambda-definition %socket-send (socket bytev start end flags)
                          "s48_socket_send")
(import-lambda-definition %socket-recv (socket bytev start end flags)
                          "s48_socket_recv")
(import-lambda-definition %socket-sendto (socket address
                                                 bytev start end
                                                 flags)
                          "s48_socket_sendto")
(import-lambda-definition %socket-recvfrom (socket bytev start end
                                                   flags)
                          "s48_socket_recvfrom")

(import-lambda-definition %connect-socket (socket address retrying?)
                          "s48_connect_socket")
(import-lambda-definition %accept-connection (socket id)
                          "s48_accept_connection")

(import-lambda-definition %boolean-socket-option (socket level optname)
                          "s48_boolean_socket_option")
(import-lambda-definition %integer-socket-option (socket level optname)
                          "s48_integer_socket_option")
(import-lambda-definition %linger-socket-option (socket level optname)
                          "s48_linger_socket_option")
(import-lambda-definition %timeout-socket-option (socket level optname)
                          "s48_timeout_socket_option")

(import-lambda-definition %set-boolean-socket-option
                          (socket level optname optval)
                          "s48_set_boolean_socket_option")
(import-lambda-definition %set-integer-socket-option
                          (socket level optname optval)
                          "s48_set_integer_socket_option")
(import-lambda-definition %set-linger-socket-option
                          (socket level optname maybe-linger)
                          "s48_set_linger_socket_option")
(import-lambda-definition %set-timeout-socket-option
                          (socket level optname seconds milliseconds)
                          "s48_set_timeout_socket_option")

(define (dup-channel channel status id)
  (let ((channel-or-errno (%dup-channel channel status id)))
    (if (integer? channel-or-errno)
        (syscall-error channel-or-errno dup-channel channel status id)
        channel-or-errno)))

(import-lambda-definition %dup-channel (channel status id)
                          "s48_dup_channel")

(define (syscall-error errno . error-cruft)
  (apply call-error (errno-message errno) error-cruft))

(import-lambda-definition errno-message (errno) "s48_strerror")