;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: USOCKET; Base: 10 -*-


;;;; See LICENSE for licensing information.

(in-package :usocket)

(defclass genera-socket ()
    ((foreign-address :initform 0 :initarg :foreign-address :accessor gs-foreign-address)
     (foreign-port :initform 0 :initarg :foreign-port :accessor gs-foreign-port)
     (local-address :initform 0 :initarg :local-address :accessor gs-local-address)
     (local-port :initform 0 :initarg :local-port :accessor gs-local-port))
  )

(defclass genera-stream-socket (genera-socket)
    ((stream :initform nil :initarg :stream :accessor gs-stream))
  )

(defclass genera-stream-server-socket (genera-socket)
    ((backlog :initform nil :initarg :backlog :accessor gs-backlog)
     (element-type :initform nil :initarg :element-type :accessor gs-element-type)
     (pending-connections :initform nil :accessor gs-pending-connections))
  )

(defclass genera-datagram-socket (genera-socket)
    ((connection :initform nil :initarg :connection :accessor gs-connection))
  )

(defun host-to-host-object (host)
  (let ((host (host-to-hostname host)))
    (cond ((string-equal host "localhost")
	   net:*local-host*)
	  ((ip-address-string-p host)
	   (let ((quad (dotted-quad-to-vector-quad host)))
	     ;;---*** NOTE: This test is temporary until we have a loopback interface
	     (if (= (aref quad 0) 127)
		 net:*local-host*
		 (net:parse-host (format nil "INTERNET|~A" host)))))
	  (t
	   (net:parse-host host)))))

(defun element-type-to-format (element-type protocol)
  (cond ((null element-type)
	 (ecase protocol
	   (:stream :text)
	   (:datagram :binary)))
	((subtypep element-type 'character)
	 :text)
	(t :binary)))

(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
  (typecase condition
    ;;---*** TODO: Add additional conditions as appropriate
    (sys:connection-refused
      (error 'connection-refused-error :socket socket))
    ((or tcp::tcp-destination-unreachable-during-connection tcp::udp-destination-unreachable)
      (error 'host-unreachable-error :socket socket))
    (sys:host-not-responding-during-connection
      (error 'timeout-error :socket socket))
    (sys:unknown-host-name
      (error 'ns-host-not-found-error :host-or-ip host-or-ip))
    (sys:network-error
      (error 'unknown-error :socket socket :real-error condition :errno -1))))

(defun socket-connect (host port &key (protocol :stream) element-type
			    timeout deadline (nodelay nil nodelay-p)
			    local-host local-port)
  (declare (ignore local-host))
  (when deadline
    (unsupported 'deadline 'socket-connect))
  (when (and nodelay-p (not (eq nodelay :if-supported)))
    (unsupported 'nodelay 'socket-connect))
  (with-mapped-conditions (nil host)
    (ecase protocol
      (:stream
	(let* ((host-object (host-to-host-object host))
	       (format (element-type-to-format element-type protocol))
	       (characters (eq format :text))
	       (timeout (if timeout
			    (* 60 timeout)
			    tcp:*tcp-connect-timeout*))
	       (stream (tcp:open-tcp-stream host-object port local-port
					    :characters characters
					    :ascii-translation characters
					    :timeout timeout))
	       (gs (make-instance 'genera-stream-socket
				  :stream stream)))
	  (setf (gs-foreign-address gs) (scl:send stream :foreign-address))
	  (setf (gs-foreign-port gs) (scl:send stream :foreign-port))
	  (setf (gs-local-address gs) (scl:send stream :local-address))
	  (setf (gs-local-port gs) (scl:send stream :local-port))
	  (make-stream-socket :socket gs :stream stream)))
      (:datagram
	;;---*** TODO
	(unsupported 'datagram 'socket-connect)))))

(defmethod socket-close ((usocket usocket))
  (with-mapped-conditions (usocket)
    (socket-close (socket usocket))))

(defmethod socket-close ((socket genera-stream-socket))
  (with-slots (stream) socket
    (when stream
      (scl:send (shiftf stream nil) :close nil))))

(defmethod socket-close ((socket genera-stream-server-socket))
  (with-slots (local-port pending-connections) socket
    (when local-port
      (tcp:remove-tcp-port-listener local-port))
    (dolist (tcb pending-connections)
      (tcp::reject-tcb tcb))))

(defmethod socket-close ((socket genera-datagram-socket))
  (with-slots (connection) socket
    (when connection
      (scl:send (shiftf connection nil) :close nil))
    ;;---*** TODO: listening?
    ))

;;; Cribbed from TCP::MAKE-TCB
(defun gensym-tcp-port ()
  (loop as number = (incf tcp::*last-gensym-port-number*) then tcp::*last-gensym-port-number*
	do (cond ((loop for existing-tcb in tcp::*tcb-list*
			thereis (= number (tcp::tcb-local-port existing-tcb))))
		 ((and (<= #.(expt 2 10) number) (< number #.(expt 2 16)))
		  (return number))
		 (t
		  (setq tcp::*last-gensym-port-number* #.(expt 2 10))))))

(defun socket-listen (host port &key (reuse-address nil reuse-address-p)
				     (reuseaddress nil reuseaddress-p)
				     (backlog 5) (element-type 'character))
  (let ((host-object (host-to-host-object host))
	(port (if (zerop port) (gensym-tcp-port) port))
	(reuse-address (cond (reuse-address-p reuse-address)
			     (reuseaddress-p reuseaddress)
			     (t nil))))
    (when (<= port 1024)
      ;; Don't allow listening on "privileged" ports to mimic Unix/Linux semantics
      (error 'operation-not-permitted-error :socket nil))
    (when (tcp:tcp-port-protocol-name port)
      ;; Can't replace a Genera server
      (error 'address-in-use-error :socket nil))
    (when (tcp:tcp-port-listener port)
      (unless reuse-address
	(error 'address-in-use-error :socket nil)))
    (let ((gs (make-instance 'genera-stream-server-socket
			     :backlog backlog
			     :element-type element-type)))
      (setf (gs-local-address gs)
	    (loop for (network address) in (scl:send host-object :network-addresses)
		  when (typep network 'tcp:internet-network)
		    return address))
      (setf (gs-local-port gs) port)
      (flet ((add-to-queue (tcb)
	       (cond ((and (not (zerop (gs-local-address gs)))
			   (not (= (gs-local-address gs) (tcp::tcb-local-address tcb))))
		      ;; Reject if not destined for the proper address
		      (tcp::reject-tcb tcb))
		     ((<= (length (gs-pending-connections gs)) (gs-backlog gs))
		      (tcp::accept-tcb tcb)
		      (tcp::tcb-travel-through-states tcb "Accept" nil :listen :syn-received)
		      (setf (gs-pending-connections gs)
			    (append (gs-pending-connections gs) (list tcb))))
		      (t
			;; Reject if backlog is full
			(tcp::reject-tcb tcb)))))
	(tcp:add-tcp-port-listener port #'add-to-queue))
      (make-stream-server-socket gs :element-type element-type))))

(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
  (with-slots (pending-connections) (socket socket)
    (loop
      (process:process-block "Wait for connection" #'(lambda ()
						       (not (null pending-connections))))
      (let ((tcb (pop pending-connections)))
	(when tcb
	  (let* ((format (element-type-to-format (or element-type (element-type socket))
						 :stream))
		 (characters (eq format :text))
		 (stream (tcp::make-tcp-stream tcb
					       :characters characters
					       :ascii-translation characters))
		 (gs (make-instance 'genera-stream-socket
				    :stream stream)))
	    (setf (gs-foreign-address gs) (scl:send stream :foreign-address))
	    (setf (gs-foreign-port gs) (scl:send stream :foreign-port))
	    (setf (gs-local-address gs) (scl:send stream :local-address))
	    (setf (gs-local-port gs) (scl:send stream :local-port))
	    (return (make-stream-socket :socket gs :stream stream))))))))

(defmethod get-local-address ((usocket usocket))
  (hbo-to-vector-quad (gs-local-address (socket usocket))))

(defmethod get-peer-address ((usocket stream-usocket))
  (hbo-to-vector-quad (gs-foreign-address (socket usocket))))

(defmethod get-local-port ((usocket usocket))
  (gs-local-port (socket usocket)))

(defmethod get-peer-port ((usocket stream-usocket))
  (gs-foreign-port (socket usocket)))

(defmethod get-local-name ((usocket usocket))
  (values (get-local-address usocket)
          (get-local-port usocket)))

(defmethod get-peer-name ((usocket stream-usocket))
  (values (get-peer-address usocket)
          (get-peer-port usocket)))

(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
  ;;---*** TODO
  (unsupported 'datagram 'socket-send))

(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
  ;;---*** TODO
  (unsupported 'datagram 'socket-receive))

(defun get-host-by-address (address)
  ) ;; TODO

(defun get-hosts-by-name (name)
  (with-mapped-conditions (nil name)
    (let ((host-object (host-to-host-object name)))
      (loop for (network address) in (scl:send host-object :network-addresses)
	    when (typep network 'tcp:internet-network)
	      collect (hbo-to-vector-quad address)))))

(defun %setup-wait-list (wait-list)
  (declare (ignore wait-list)))

(defun %add-waiter (wait-list waiter)
  (declare (ignore wait-list waiter)))

(defun %remove-waiter (wait-list waiter)
  (declare (ignore wait-list waiter)))

(defun wait-for-input-internal (wait-list &key timeout)
  (with-mapped-conditions ()
    (process:process-block-with-timeout timeout "Wait for input"
      #'(lambda (wait-list)
	  (let ((ready-sockets nil))
	    (dolist (waiter (wait-list-waiters wait-list) ready-sockets)
	      (setf (state waiter)
		    (cond ((stream-usocket-p waiter)
			   (if (listen (socket-stream waiter))
			       :read
			       nil))
			  ((datagram-usocket-p waiter)
			   (let ((connection (gs-connection (socket waiter))))
			     (if (and connection
				      (not (scl:send connection :connection-pending-p)))
				 :read
				 nil)))
			  ((stream-server-usocket-p waiter)
			   (if (gs-pending-connections (socket waiter))
			       :read
			       nil))))
	      (when (not (null (state waiter)))
		(setf ready-sockets t)))))
      wait-list)
    wait-list))