;;;; quicknet.lisp
;;;;
;;;; An experiment in using CLOS for cross-implementation networking
;;;; support, by Zach Beane <xach@xach.com>.
;;;;
;;;; For more information, please see http://xach.livejournal.com/192603.html
;;;;

(defpackage #:quicknet
  (:use #:cl)
  (:nicknames #:qn)
  (:export #:open-connection
           #:read-octets
           #:write-octets
           #:close-connection)
  (:export #:lisp
           #:connections-are-streams)
  (:export #:%open-connection
           #:%read-octets
           #:%write-octets
           #:%close-connection)
  (:export #:*lisp*))

(in-package #:quicknet)

(deftype octet ()
  '(unsigned-byte 8))

(defvar *lisp* nil
  "The current Lisp implementation instance.")

(defgeneric %open-connection (host port lisp))
(defgeneric %read-octets (buffer connection lisp))
(defgeneric %write-octets (buffer connection lisp))
(defgeneric %close-connection (connection lisp))

(defgeneric open-connection (host port)
  (:documentation "Return a network connection to PORT on HOST.")
  (:method (host port)
    (%open-connection host port *lisp*)))

(defgeneric read-octets (buffer connection)
  (:documentation "Read available octets on CONNECTION into BUFFER and
  return the number of octets read.")
  (:method (buffer connection)
    (%read-octets buffer connection *lisp*)))

(defgeneric write-octets (buffer connection)
  (:documentation "Write all octets of BUFFER to CONNECTION.")
  (:method (buffer connection)
    (%write-octets buffer connection *lisp*)))

(defgeneric close-connection (connection)
  (:method (connection)
    (%close-connection connection *lisp*)))

(defmacro with-connection ((connection host port) &body body)
  `(let (,connection)
     (unwind-protect
          (progn
            (setf ,connection (open-connection ,host ,port))
            ,@body)
       (when ,connection
         (close-connection ,connection)))))


;;; Implementation-specific package setup 

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun error-unimplemented (&rest args)
    (declare (ignore args))
    (error "Not implemented")))

(defmacro neuter-package (name)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (let ((definition (fdefinition 'error-unimplemented)))
       (do-external-symbols (symbol ,(string name))
         (setf (fdefinition symbol) definition)))))

(defmacro define-implementation-package (feature package-name &rest options)
  (let ((imports (mapcan (lambda (option)
                           (and (eql (first option) :import-from)
                                (list option)))
                         options))
        (exports (cdr (assoc :export options)))
        (prep (cdr (assoc :prep options)))
        (effectivep (member feature *features*)))
    `(progn
       ,@(when effectivep
           prep)
       (defpackage ,package-name
         (:use)
         (:export #:lisp
                  ,@exports)
         ,@(when effectivep
             imports))
       ,@(unless effectivep
           `((neuter-package ,package-name))))))

(defclass lisp () ())


;;; Most connections are treated like streams

(defclass connections-are-streams () ())

(defmethod %read-octets (buffer connection (lisp connections-are-streams))
  (read-sequence buffer connection))

(defmethod %write-octets (buffer connection (lisp connections-are-streams))
  (write-sequence buffer connection)
  (finish-output connection))

(defmethod %close-connection (connection (lisp connections-are-streams))
  (close connection))


;;; LispWorks

(define-implementation-package :lispworks #:qn.lw
  (:prep
   (require "comm"))
  (:import-from #:comm
                #:open-tcp-stream)
  (:import-from #:system
                #:wait-for-input-streams)
  (:export #:open-tcp-stream
           #:wait-for-input-streams
           #:lisp))

(defclass qn.lw:lisp (lisp connections-are-streams) ())

(defmethod %open-connection (host port (lisp qn.lw:lisp))
  (qn.lw:open-tcp-stream host port
                          :direction :io
                          :read-timeout 0
                          :element-type 'octet
                          :timeout 5))

(defmethod %read-octets :before (buffer connection (lisp qn.lw:lisp))
  (declare (ignore buffer))
  (qn.lw:wait-for-input-streams (list connection)))

#+lispworks
(setf *lisp* (make-instance 'qn.lw:lisp))


;;; SBCL

(define-implementation-package :sbcl #:qn.sbcl
  (:prep
   (require 'sb-bsd-sockets))
  (:import-from #:sb-bsd-sockets
                #:get-host-by-name
                #:host-ent-address
                #:socket-connect
                #:socket-receive
                #:socket-send
                #:socket-close
                #:inet-socket)
  (:export #:get-host-by-name
           #:host-ent-address
           #:socket-connect
           #:socket-receive
           #:socket-send
           #:socket-close
           #:inet-socket
           #:lisp))

(defclass qn.sbcl:lisp (lisp) ())

(defun sbcl/host-network-address (host)
  (let ((ent (qn.sbcl:get-host-by-name host)))
    (qn.sbcl:host-ent-address ent)))

(defmethod %open-connection (host port (lisp qn.sbcl:lisp))
  (let ((endpoint (sbcl/host-network-address host))
        (socket (make-instance 'qn.sbcl:inet-socket
                               :protocol :tcp
                               :type :stream)))
    (qn.sbcl:socket-connect socket endpoint port)
    socket))

(defmethod %write-octets (buffer connection (lisp qn.sbcl:lisp))
  (qn.sbcl:socket-send connection buffer nil))

(defmethod %read-octets (buffer connection (lisp qn.sbcl:lisp))
  (nth-value 1 (qn.sbcl:socket-receive connection buffer nil)))

(defmethod %close-connection (connection (lisp qn.sbcl:lisp))
  (qn.sbcl:socket-close connection))

#+sbcl
(setf *lisp* (make-instance 'qn.sbcl:lisp))


;;; ECL. FIXME: lots of duplication from SBCL, as ECL clones the
;;; sb-bsd-sockets socket interface

(define-implementation-package :ecl #:qn.ecl
  (:prep
   (require 'sockets))
  (:import-from #:sb-bsd-sockets
                #:get-host-by-name
                #:host-ent-address
                #:socket-connect
                #:socket-receive
                #:socket-send
                #:socket-close
                #:inet-socket)
  (:export #:get-host-by-name
           #:host-ent-address
           #:socket-connect
           #:socket-receive
           #:socket-send
           #:socket-close
           #:inet-socket
           #:lisp))

(defclass qn.ecl:lisp (lisp) ())

(defun ecl/host-network-address (host)
  (let ((ent (qn.ecl:get-host-by-name host)))
    (qn.ecl:host-ent-address ent)))

(defmethod %open-connection (host port (lisp qn.ecl:lisp))
  (let ((endpoint (ecl/host-network-address host))
        (socket (make-instance 'qn.ecl:inet-socket
                               :protocol :tcp
                               :type :stream)))
    (qn.ecl:socket-connect socket endpoint port)
    socket))

(defmethod %write-octets (buffer connection (lisp qn.ecl:lisp))
  (qn.ecl:socket-send connection buffer nil))

(defmethod %read-octets (buffer connection (lisp qn.ecl:lisp))
  (nth-value 1 (qn.ecl:socket-receive connection buffer nil)))

(defmethod %close-connection (connection (lisp qn.ecl:lisp))
  (qn.ecl:socket-close connection))

#+ecl
(setf *lisp* (make-instance 'qn.ecl:lisp))


;;; CLISP

(define-implementation-package :clisp #:qn.clisp
  (:import-from #:socket
                #:socket-status
                #:socket-connect)
  (:import-from #:ext
                #:read-byte-sequence)
  (:export #:socket-connect
           #:socket-status
           #:read-byte-sequence
           #:lisp))

(defclass qn.clisp:lisp (lisp connections-are-streams) ())

(defmethod %open-connection (host port (lisp qn.clisp:lisp))
  (qn.clisp:socket-connect port host :element-type 'octet))

(defmethod %read-octets (buffer connection (lisp qn.clisp:lisp))
  (qn.clisp:read-byte-sequence buffer connection
                                :no-hang nil
                                :interactive t))

#+clisp
(setf *lisp* (make-instance 'qn.clisp:lisp))


;;; Allegro CL

(define-implementation-package :allegro #:qn.allegro
  (:import-from #:socket
                #:make-socket)
  (:import-from #:excl
                #:read-vector)
  (:export #:make-socket
           #:read-vector
           #:lisp))

(defclass qn.allegro:lisp (lisp connections-are-streams) ())

(defmethod %open-connection (host port (lisp qn.allegro:lisp))
  (qn.allegro:make-socket :remote-host host
                           :remote-port port))

(defmethod %read-octets (buffer connection (lisp qn.allegro:lisp))
  (qn.allegro:read-vector buffer connection))

#+allegro
(setf *lisp* (make-instance 'qn.allegro:lisp))


;;; Clozure CL

(define-implementation-package :clozure #:qn.clozure
  (:import-from #:ccl
                #:make-socket
                #:socket-os-fd)
  (:export #:unread-data-available-p
           #:fd-input-available-p
           #:make-socket
           #:socket-os-fd
           #:lisp))

(defclass qn.clozure:lisp (lisp connections-are-streams) ())

#+clozure
(setf *lisp* (make-instance 'qn.clozure:lisp))

;; Essential yet unexported functions
#+clozure
(defun qn.clozure:unread-data-available-p (connection)
  (ccl::unread-data-available-p (qn.clozure:socket-os-fd connection)))

#+clozure
(defun qn.clozure:fd-input-available-p (connection)
  (ccl::fd-input-available-p (qn.clozure:socket-os-fd connection)))

(defmethod %open-connection (host port (lisp qn.clozure:lisp))
  (qn.clozure:make-socket :remote-host host
                           :remote-port port))

(defmethod %read-octets (buffer connection (lisp qn.clozure:lisp))
  (qn.clozure:fd-input-available-p connection)
  (let ((available (qn.clozure:unread-data-available-p connection)))
    (if available
        (read-sequence buffer connection :end (min available
                                                   (length buffer)))
        0)))


;;; "Fake" connection class for testing response parsing. Opens a file
;;; for reading instead of a socket. Writes are discarded.

(defpackage #:qn.fake
  (:use)
  (:export #:lisp))

(defclass qn.fake:lisp (lisp connections-are-streams) ())

(defmethod %open-connection (host port (lisp qn.fake:lisp))
  (declare (ignore port lisp))
  (open host :element-type 'octet))

(defmethod %write-octets (buffer connection (lisp qn.fake:lisp))
  (declare (ignore buffer connection)))