;;;; $Id$
;;;; $URL$

;;;; See the LICENSE file for licensing information.

(defpackage :trivial-usocket
  (:use #:cl
        #:trivial-gray-streams
        #:usocket)
  (:export #:open-stream
           #:usocket
           #:unsupported
           #:open-server
           #:with-server
           #:accept-connection))

(in-package :trivial-usocket)

;; Condition raised by operations with unsupported arguments
;; For trivial-sockets compatibility.

(define-condition unsupported (error)
  ((feature :initarg :feature :reader unsupported-feature)))


(defclass usocket-mixin (trivial-gray-stream-mixin)
  ((socket
    :initarg :usocket
    :accessor usocket
    :documentation ""))
  (:documentation "A stream which forwards all calls to the stream
associated with the socket, still allowing the original socket to be
retrieved."))

;; retrieval of the socket is something not all implementations allow
;; for the streams they associate with the sockets; that's why we have
;; a special stream which does allow it.


;; We need to implement these symbols (for forwarding-stream-mixin):

(defmethod stream-read-char ((stream usocket-mixin))
  (read-char (socket-stream (usocket stream)) nil :eof))

(defmethod stream-unread-char ((stream usocket-mixin) char)
  (unread-char char (socket-stream (usocket stream))))

(defmethod stream-read-char-no-hang ((stream usocket-mixin))
  (read-char-no-hang (socket-stream (usocket stream))))

(defmethod stream-peek-char ((stream usocket-mixin))
  (peek-char nil (socket-stream (usocket stream)) nil :eof))

(defmethod stream-listen ((stream usocket-mixin))
  (listen (socket-stream (usocket stream))))

(defmethod stream-read-line ((stream usocket-mixin))
  (let ((line (read-line (socket-stream (usocket stream)) nil :eof)))
    (if (eq line :eof)
        (values "" t)
      (values line nil))))

(defmethod stream-clear-input ((stream usocket-mixin))
  (clear-input (socket-stream (usocket stream))))

(defmethod stream-write-char ((stream usocket-mixin) char)
  (write-char char (socket-stream (usocket stream))))

(defmethod stream-line-column ((stream usocket-mixin))
  nil)

(defmethod stream-start-line-p ((stream usocket-mixin))
  nil)

(defmethod stream-write-string ((stream usocket-mixin)
                                string &optional start end)
  (write-string string (socket-stream (usocket stream))
                :start (or start 0)
                :end (or end (length string))))

(defmethod stream-terpri ((stream usocket-mixin))
  (terpri (socket-stream (usocket stream))))

(defmethod stream-fresh-line ((stream usocket-mixin))
  (fresh-line (socket-stream (usocket stream))))

(defmethod stream-finish-output ((stream usocket-mixin))
  (finish-output (socket-stream (usocket stream))))

(defmethod stream-force-output ((stream usocket-mixin))
  (force-output (socket-stream (usocket stream))))

(defmethod stream-clear-output ((non-stream usocket-mixin))
  (clear-output (socket-stream (usocket non-stream))))

(defmethod stream-advance-to-column ((stream usocket-mixin) column)
  nil)

(defmethod close ((stream usocket-mixin) &key abort)
  (close (socket-stream (usocket stream)) :abort abort))

(defmethod stream-read-byte ((non-stream usocket-mixin))
  (read-byte (socket-stream (usocket non-stream)) nil :eof))

(defmethod stream-write-byte ((non-stream usocket-mixin) integer)
  (write-byte integer (socket-stream (usocket non-stream))))

(defmethod stream-read-sequence ((stream usocket-mixin) seq start end
                                 &key &allow-other-keys)
  (read-sequence seq (socket-stream (usocket stream))
                 :start (or start 0)
                 :end (or end (length seq))))

(defmethod stream-write-sequence ((stream usocket-mixin) seq start end
                                  &key &allow-other-keys)
  (write-sequence seq (socket-stream (usocket stream))
                  :start (or start 0)
                  :end (or end (length seq))))


;; We also need to implement forwarding streams:
;;
;; forwarding-input-stream
;; forwarding-output-stream
;; forwarding-io-stream
;;
;; which are derived from their ancestors (fundamental-*) and
;; the forwarding mixin.

(defclass usocket-input-stream (fundamental-input-stream usocket-mixin)
  ())

(defclass usocket-output-stream (fundamental-output-stream usocket-mixin)
  ())

(defclass usocket-io-stream (fundamental-input-stream
                             fundamental-output-stream
                             usocket-mixin)
  ())

(defun wrap-usocket-stream (usocket &rest rest)
  ""
  (let* ((ustream (socket-stream usocket))
         (istream-p (input-stream-p ustream))
         (ostream-p (output-stream-p ustream)))
    (apply #'make-instance
           (cond
            ((and istream-p ostream-p)
             'usocket-io-stream)
            (istream-p 'usocket-input-stream)
            (ostream-p 'usocket-output-stream)
            (t (error "Unsupported stream type")))
           :usocket usocket
           rest)))

;;
;; The actual compat functions

(defun open-stream (peer-host peer-port
                              &key (local-host :any)
                                   (local-port 0)
                                   (external-format :default)
                                   (element-type #-lispworks 'character
                                                 #+lispworks 'base-char)
                                   (protocol :tcp))
  (unless (eq protocol :tcp)
    (error 'unsupported :feature `(:protocol ,protocol)))
  (unless (and (eql local-host :any) (eql local-port 0))
    (error 'unsupported :feature :bind))
  (unless (eql external-format :default)
    (error 'unsupported :feature :external-format))
  (let ((socket (socket-connect peer-host peer-port
                                :element-type element-type)))
    (wrap-usocket-stream socket)))


(defun open-server (&key (host :any)
                         (port 0)
                         (reuse-address t)
                         (backlog 1)
                         (protocol :tcp))
  (unless (eq protocol :tcp)
    (error 'unsupported :feature `(:protocol ,protocol)))
  (socket-listen (if (eq host :any) *wildcard-host* host)
                 port
                 :reuseaddress reuse-address
                 :backlog backlog))

(defun close-server (server)
  (socket-close server))

(defun accept-connection (server &key (external-format :default)
                                 (element-type #-lispworks 'character
                                               #+lispworks 'base-char))
  (unless (eql external-format :default)
    (error 'unsupported :feature :external-format))
  (wrap-usocket-stream (socket-accept server :element-type element-type)))

(defmacro with-server ((server args) &body forms)
  (let ((hostsym (gensym))
        (portsym (gensym))
        (newargs (gensym)))
    `(let* ((,hostsym (or (getf ,args :host)
                          *wildcard-host*))
            (,portsym (or (getf ,args :port)
                          *wildcard-port*))
            (,newargs (copy-list ,args)))
       (remf ,newargs :host)
       (remf ,newargs :port)
       (let ((,server (apply #'socket-listen ,hostsym ,portsym ,newargs)))
         (when ,server
           (unwind-protect
               (progn
                 ,@forms)
             (when ,server
               (socket-close ,server))))))))