;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Portable TCP/IP
;;   Created: 2014-08-15
;;    Author: Gilbert Baumann <gilbert@rhodonit>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (c) copyright 2014 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(defpackage :de.bauhh.tcpip
  (:use :common-lisp)
  (:export
   #:make-listener
   #:close-listener
   #:accept-connection
   #:with-tcp-connection
   #:tcp-connect
   ))

(in-package :de.bauhh.tcpip)

;;;; -- Overview ------------------------------------------------------------------------------

;; This package wants to provide a lispy interface to TCP/IP and does
;; not want to shove BSD sockets on you. Basically you want to connect
;; to a server named example.com on port 4711. Do it:

;; (with-tcp-connection (io :host "example.com" :port 4711 :element-type '(unsigned-byte 8))
;;   ...)

;; Or you want to implement a server yourself:

;; (with-accepting-tcp-connections (io :port 4711)
;;   ...)

;;;; -- Implementation ------------------------------------------------------------------------

;; SBCL is the worst of all.

#+SBCL
(progn

  (defun make-listener (&key port (host nil) (backlog 5) (reuse-address-p t) (nodelay nil))
    (let ((socket
           (make-instance 'sb-bsd-sockets:inet-socket
                          :type :stream
                          :protocol :tcp)))
      (sb-bsd-sockets:socket-bind socket (if host
                                             (sb-bsd-sockets:host-ent-address
                                              (sb-bsd-sockets:get-host-by-name host))
                                             #(0 0 0 0))
                                  port)
      ;; (sb-bsd-sockets:sockopt-tcp-nodelay socket)
      (when reuse-address-p
        ;; not working :-/
        (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
      (when nodelay
        (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) t))
      (sb-bsd-sockets:socket-listen socket backlog)
      socket))

  (defun close-listener (listener)
    (sb-bsd-sockets:socket-close listener))

  (defun accept-connection (listener
                            &rest stream-options
                            &key (element-type 'base-char)
                              external-format
                              timeout)
    ;; with et = :default SBCL ought to create a bivalent stream.
    (declare (ignore element-type external-format))
    (let* ((socket (sb-bsd-sockets:socket-accept listener))
           (peer (sb-bsd-sockets::socket-peerstring socket)))
      ;; timeout also not working.
      (values
       (apply #'sb-bsd-sockets:socket-make-stream socket
              :input t :output t
              stream-options)
       peer))))

#+CCL
(progn
  ;; easiest of all
  
  (defun make-listener (&key port
                             (address-family :internet) (host nil) (backlog 5) (reuse-address-p t) (nodelay nil)
                             connect-timeout input-timeout output-timeout
                          (local-filename nil)) ;for unix domain sockets
    (cond ((eql address-family :unix)
           (setf address-family :file)))
    (let ((sock
           (ccl:make-socket :address-family address-family
                            :local-port port
                            :local-host host
                            :local-filename local-filename ;for :UNIX
                            :connect :passive
                            :reuse-address reuse-address-p
                            :nodelay t
                            :backlog backlog
                            :nodelay nodelay
                            :connect-timeout connect-timeout
                            :input-timeout input-timeout
                            :output-timeout output-timeout)))
      ;; Hmm.
      sock))

  (defun close-listener (listener)
    (close listener))

  (defun accept-connection (listener
                            &rest stream-options
                            &key (element-type 'base-char)
                              external-format
                              timeout)
    (declare (ignore external-format element-type))
    (let ((io (ccl:accept-connection listener :wait t :stream-args stream-options)))
      (when timeout
        (setf (ccl:stream-input-timeout io) timeout
              (ccl:stream-output-timeout io) timeout))
      (values io
              (typecase io
                (ccl::tcp-stream
                 (format nil "~A:~A" (ccl:ipaddr-to-dotted (ccl:remote-host io)) (ccl:remote-port io)))
                (t
                 nil)))))

  (defun tcp-connect (host port &key element-type external-format connect-timeout input-timeout output-timeout)
    (apply #'ccl:make-socket 
           :remote-host host
           :remote-port port
           (append (and external-format (list :external-format external-format))
                   (and element-type (list :element-type element-type))
                   (and connect-timeout (list :connect-timeout connect-timeout))
                   (and input-timeout (list :input-timeout input-timeout))
                   (and output-timeout (list :output-timeout output-timeout)))))
                     
  
  )

(defmacro with-tcp-connection ((stream host port &rest options) &body body)
  `(with-open-stream (,stream (tcp-connect ,host ,port ,@options))
     ,@body))