ccl-socket-example.lisp

;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               ccl-socket-example.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    A little demo using ccl sockets and posix I/O/
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2018-09-22 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2018 - 2018
;;;;
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU Affero General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************

(eval-when (:compile-toplevel :load-toplevel :execute)

  #+ccl (progn
          (format t "; Requiring :cocoa~%")
          (force-output)
          (require :cocoa))
  #-ccl (error "Check for Cocoa and #/ reader macro.")

  (ql:quickload :cffi)
  (ql:quickload :bordeaux-threads)
  (ql:quickload :babel)
  (ql:quickload :com.informatimago.common-lisp.cesarum))

(defpackage "COM-INFORMATIMAGO.EXAMPLE.CCL.SOCKET"
  (:use "COMMON-LISP"
        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"))
(in-package "COM-INFORMATIMAGO.EXAMPLE.CCL.SOCKET")

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

(defun dump (pointer size)
  (loop
    :repeat size
    :for i :from 0
    :when (zerop (mod i 16))
      :do (format t "~&~16,'0X: " (+ i (cffi:pointer-address pointer)))
    :do (format t "~2,'0X " (cffi:mem-aref pointer :uint8 i))
    :finally (terpri)))

(cffi:defcfun ("memcmp" memcmp) :int
  (s1 :pointer)
  (s2 :pointer)
  (n :unsigned-long))

(defun strerror (errno)
  #+ccl (ccl::%strerror errno)
  #-ccl (error "Not implemented in ~A" (lisp-implementation-type)))

(defun errno ()
  #+ccl (ccl::%get-errno)
  #-ccl (error "Not implemented in ~A" (lisp-implementation-type)))

(defun posix-io-loop (fd buffer size function)
  (loop
    :for count := (funcall function fd buffer size)
    :do (if (minusp count)
              (case (- count)
                (#$EAGAIN #|let's try again|# )
                (otherwise (error "read(2) error ~D: ~A" (- count) (strerror (- count)))))
            (progn
              (cffi:incf-pointer buffer count)
              (decf size count)))
    :while (plusp size)))

(defun posix-read-loop (fd buffer size)
  (posix-io-loop fd buffer size
                 (progn #+ccl (function ccl::fd-read)
                        #-ccl (error "Not implemented in ~A" (lisp-implementation-type)))))

(defun posix-write-loop (fd buffer size)
  (posix-io-loop fd buffer size
                 (progn #+ccl (function ccl::fd-write)
                        #-ccl (error "Not implemented in ~A" (lisp-implementation-type)))))

(defun stream-fd (stream)
  (etypecase stream
    (ccl::basic-stream  (ccl::ioblock-device (ccl::basic-stream-ioblock stream)))
    (ccl::socket        (ccl:socket-os-fd stream))))

;; The protocol:

(defmacro with-serialized-integer ((var integer) &body body)
  (let ((vinteger (gensym)))
    `(let ((,vinteger ,integer))
       (cffi:with-foreign-pointer (,var 4)
         (setf (cffi:mem-ref ,var :uint8 0) (ldb (byte 8  0) ,vinteger)
               (cffi:mem-ref ,var :uint8 1) (ldb (byte 8  8) ,vinteger)
               (cffi:mem-ref ,var :uint8 2) (ldb (byte 8 16) ,vinteger)
               (cffi:mem-ref ,var :uint8 3) (ldb (byte 8 24) ,vinteger))
         ,@body))))

(defun deserialize-integer (buffer)
  (dpb (cffi:mem-ref buffer :uint8 3) (byte 8 24)
       (dpb  (cffi:mem-ref buffer :uint8 2) (byte 8 16)
             (dpb (cffi:mem-ref buffer :uint8 1) (byte 8  8)
                  (cffi:mem-ref buffer :uint8 0)))))

(defun receive-integer (stream)
  (cffi:with-foreign-pointer (buffer 4)
    (posix-read-loop (stream-fd stream) buffer 4)
    (deserialize-integer buffer)))

(defun send-buffer (stream buffer size)
  (with-serialized-integer (size-buffer size)
    (posix-write-loop (stream-fd stream) size-buffer 4))
  (posix-write-loop (stream-fd stream) buffer size)
  (force-output stream))

(defun receive-buffer (stream)
  (let* ((size (receive-integer stream))
         (buffer (cffi:foreign-alloc :uint8 :count size)))
    (handler-bind
        ((error (lambda (condition)
                  (declare (ignore condition))
                  (cffi:foreign-free buffer)
                  nil)))
      (posix-read-loop (stream-fd stream) buffer size))
    (values buffer size)))

;; The program:

(defun receive-and-display (socket controller)
  (multiple-value-bind (buffer size) (receive-buffer socket)
    (dump buffer size)
    (unwind-protect
         (display-image buffer size controller)
      (cffi:foreign-free buffer))))

(defun video-feed-controller-set-image (controller image)
  (declare (ignore controller image))
  (error "Not implemented yet"))

(defun display-image (buffer size controller)
  (let ((image (#/initWithData: (#/alloc ns:ns-image) (#/dataWithBytes:length: ns:ns-data buffer size))))
    (when (cffi:null-pointer-p image)
      (error "Invalid image format"))
    (video-feed-controller-set-image controller image)))

;; Tests

(defgeneric ipv6-address-p (address)
  (:method ((address t))
    nil)
  (:method ((address ccl::ip6-socket-address))
    address)
  (:method ((address string))
    (let ((address (ignore-errors (ccl:resolve-address :host address))))
      (and (ipv6-address-p address) address)))
  (:method ((address integer))
    (let ((address (ignore-errors (ccl:resolve-address :host (format nil "~D" address)))))
      (and (ipv6-address-p address) address))))

(defgeneric make-listening-socket (socket-kind &key &allow-other-keys)

  (:method ((socket-kind (eql :file)) &key (filename  #P"test.socket")
                                        (reuse-address nil)
                                        (backlog 5)
                                        (connect-timeout 1e6)
                                        deadline)
    (when reuse-address
      (ignore-errors (delete-file filename)))
    (ccl:make-socket :address-family :file
                     :type :stream
                     :local-filename filename
                     :connect :passive
                     :format :bivalent
                     :backlog backlog
                     :connect-timeout connect-timeout
                     :auto-close t
                     :deadline deadline))

  (:method ((socket-kind (eql :tcp)) &key (port 14000) (address nil)
                                       (reuse-address nil)
                                       (keepalive nil)
                                       (nodelay nil) (linger nil)
                                       (backlog 5) (connect-timeout 1e6)
                                       deadline)
    (check-type linger (or null integer))
    (ccl:make-socket :address-family (if (ipv6-address-p address)
                                         :internet6
                                         :internet)
                     :type :stream
                     :connect :passive
                     :format :bivalent
                     :local-address (ccl:resolve-address :host address
                                                         :port port
                                                         :socket-type :stream
                                                         :connect :passive
                                                         :address-family (if (ipv6-address-p address)
                                                                             :internet6
                                                                             :internet)
                                                         :singlep t)
                     :local-port port
                     :reuse-address reuse-address
                     :keepalive keepalive
                     :nodelay nodelay
                     :linger linger
                     :backlog backlog
                     :connect-timeout connect-timeout
                     :auto-close t
                     :deadline deadline)))

(defgeneric make-socket (socket-kind &key &allow-other-keys)

  (:method ((socket-kind (eql :file)) &key filename
                                        (backlog 5)
                                        (connect-timeout 1e6)
                                        deadline)
    (ccl:make-socket :address-family :file
                     :type :stream
                     :connect :active
                     :remote-filename filename
                     :format :bivalent
                     :backlog backlog
                     :connect-timeout connect-timeout
                     :auto-close t
                     :deadline deadline))

  (:method ((socket-kind (eql :tcp))  &key port address
                                        remote-port remote-address
                                        (keepalive nil) (reuse-address nil)
                                        (nodelay nil) (linger nil)
                                        (backlog 5) (connect-timeout 1e6)
                                        (input-timeout 1e6)
                                        (output-timeout 1e6)
                                        deadline)
    (check-type linger (or null integer))
    (ccl:make-socket :address-family (if (or (ipv6-address-p remote-address)
                                             (ipv6-address-p address))
                                         :internet6
                                         :internet)
                     :type :stream
                     :connect :active
                     :format :bivalent
                     :remote-address (ccl:resolve-address :host remote-address
                                                          :port remote-port
                                                          :socket-type :stream
                                                          :connect :active
                                                          :address-family (if (ipv6-address-p remote-address)
                                                                              :internet6
                                                                              :internet)
                                                          :singlep t)
                     :remote-port remote-port
                     :local-address (ccl:resolve-address :host address
                                                         :port port
                                                         :socket-type :datagram
                                                         :connect :active
                                                         :address-family (if (ipv6-address-p address)
                                                                             :internet6
                                                                             :internet)
                                                         :singlep t)
                     :local-port port
                     :keepalive keepalive
                     :reuse-address reuse-address
                     :nodelay nodelay
                     :linger linger
                     :backlog backlog
                     :connect-timeout connect-timeout
                     :input-timeout input-timeout
                     :output-timeout output-timeout
                     :auto-close t
                     :deadline deadline))

  (:method ((socket-kind (eql :udp)) &key port address
                                       remote-port remote-address
                                       (keepalive nil)
                                       (broadcast nil)
                                       (backlog 5)
                                       (connect-timeout 1e6)
                                       (input-timeout 1e6)
                                       (output-timeout 1e6)
                                       deadline)
    (ccl:make-socket :address-family (if (ipv6-address-p address)
                                         :internet6
                                         :internet)
                     :type :datagram
                     :connect :active
                     :format :binary
                     :remote-address (ccl:resolve-address :host remote-address
                                                          :port remote-port
                                                          :socket-type :datagram
                                                          :connect :active
                                                          :address-family (if (ipv6-address-p remote-address)
                                                                              :internet6
                                                                              :internet)
                                                          :singlep t)
                     :remote-port remote-port
                     :local-address (ccl:resolve-address :host address
                                                         :port port
                                                         :socket-type :datagram
                                                         :connect :active
                                                         :address-family (if (ipv6-address-p address)
                                                                             :internet6
                                                                             :internet)
                                                         :singlep t)
                     :local-port port
                     :keepalive keepalive
                     :broadcast broadcast
                     :backlog backlog
                     :connect-timeout connect-timeout
                     :input-timeout input-timeout
                     :output-timeout output-timeout
                     :auto-close t
                     :deadline deadline)))

(defvar *log* '())
(defvar *log-lock* (bt:make-lock "log-lock"))

(defgeneric log/socket-host (socket)
  (:method ((socket t))
    (ccl:remote-host socket))
  (:method ((socket ccl::udp-socket))
    (list :udp (ccl:local-host socket))))

(defgeneric log/socket-port (socket)
  (:method ((socket t))
    (ccl:remote-port socket))
  (:method ((socket ccl::udp-socket))
    (list :udp (ccl:local-port socket))))

(defun log/remote (socket format-specifier &rest arguments)
  (bt:with-lock-held (*log-lock*)
    (push (format nil "~42A ~12A: ~?"  (log/socket-host socket) (log/socket-port socket)
                  format-specifier arguments)
          *log*)))

(defgeneric send (socket format-specifier &rest arguments)
  (:method ((socket t) format-specifier &rest arguments)
    (format socket "~?~%" format-specifier arguments)
    (force-output socket))
  (:method ((socket ccl::udp-socket) format-specifier &rest arguments)
    (let ((buffer (babel:string-to-octets (format nil "~?~%" format-specifier arguments)
                                          :encoding :utf-8)))
      (log/remote socket "~S" (type-of buffer))
      (ccl:send-to socket buffer (length buffer)))))

(defgeneric receive (socket)
  (:method ((socket t))
    (read-line socket))
  (:method ((socket ccl::udp-socket))
    (let ((buffer (ccl:receive-from socket 4096 :offset 0)))
      (babel:octets-to-string buffer :encoding :utf-8))))

(define-test test/socket/pair-connected (client server)
  (let ((server-thread (bt:make-thread (lambda ()
                                         (sleep 1)
                                         (send client "HELO")
                                         (log/remote client "~A" (receive client))
                                         (send client "BYE")
                                         (log/remote client "~A" (receive client))
                                         (sleep 1)
                                         (close client)
                                         :server-done)
                                       :name "test/socket/pair!server-thread"))
        (client-thread (bt:make-thread (lambda ()
                                         (sleep 1)
                                         (log/remote server (receive server))
                                         (send server "How do you do?")
                                         (log/remote server (receive server))
                                         (send server "Bye!")
                                         (sleep 1)
                                         (close server)
                                         :client-done)
                                       :name "test/socket/pair!client-thread")))
    (check eql (bt:join-thread server-thread) :server-done)
    (check eql (bt:join-thread client-thread) :client-done)))

(define-test test/socket/pair (listener server)
  (test/socket/pair-connected (ccl:accept-connection listener :wait t) server))

(define-test test/socket/tcp ()
  (let ((listener (make-listening-socket :tcp        :address "localhost"        :port 14000 :reuse-address t))
        (server   (make-socket           :tcp :remote-address "localhost" :remote-port 14000)))
    (unwind-protect
         (test/socket/pair listener server)
      (close listener)
      (close server))))

(define-test test/socket/file ()
   (let ((listener (make-listening-socket :file :filename "/tmp/test.socket" :reuse-address t))
         (server   (make-socket           :file :filename "/tmp/test.socket")))
     (unwind-protect
          (test/socket/pair listener server)
       (close listener)
       (close server))))

(define-test test/socket/udp ()
  (let ((server   (make-socket :udp
                               :address "localhost" :port 14003
                               :remote-address "localhost" :remote-port 14002
                               :reuse-address t))
        (client   (make-socket :udp
                               :address "localhost" :port 14002
                               :remote-address "localhost" :remote-port 14003
                               :reuse-address t)))
    (unwind-protect
         (test/socket/pair-connected client server)
      (close server)
      (close client))))

#-(and)
(define-test test-with-socket (server client &key (socket-kind :tcp) (port 14000) (filename))
  (check-type socket-kind (member :tcp :udp :file))
  (let* ((server-lock (bt:make-lock                     "test-with-socket/server-lock"))
         (server-stop (bt:make-condition-variable :name "test-with-socket/server-stop"))
         (client-lock (bt:make-lock                     "test-with-socket/client-lock"))
         (client-stop (bt:make-condition-variable :name "test-with-socket/client-stop"))
         (server      (bt:make-thread (lambda ()
                                        #-(and)
                                        (loop
                                           (let ((listener (ccl:make-socket )))))
                                        (sleep 1))

                                      :name "test-with-socket/server"))
         (client      (bt:make-thread (lambda ()
                                        (sleep 1) ;; leave some time to the server
                                        )
                                      :name "test-with-socket/client"))     )



    )
  )

(defvar *jpeg-file*  #P"~/Pictures/20180321--pascal-bourguignon--cropped.jpg")
(defvar *tempfile-pathname* #P"/tmp/test.data")

;; (lisp-array-to-foreign array pointer array-type)
;; (foreign-array-to-lisp pointer array-type)

(defun test-send-buffer/file ()
  (let* ((bytes (com.informatimago.common-lisp.cesarum.file:binary-file-contents *jpeg-file*))
         (size  (length bytes))
         (buffer (cffi:foreign-alloc :uint8 :count size)))
    (cffi:lisp-array-to-foreign bytes buffer `(:array :uint8 ,size))
    ;; (dump buffer size)
    (with-open-file (out *tempfile-pathname*
                         :direction :output
                         :element-type 'octet
                         :if-does-not-exist :create
                         :if-exists :supersede)
      (send-buffer out buffer size))
    (values buffer size)))

(defun test-receive-buffer/file ()
  (with-open-file (inp *tempfile-pathname*
                       :direction :input
                       :element-type 'octet)
    (multiple-value-bind (buffer size) (receive-buffer inp)
      ;; (dump buffer size)
      (values buffer size))))

(define-test test/send-receive/file ()
  (multiple-value-bind (buffer-out size-out) (test-send-buffer/file)
    (multiple-value-bind (buffer-inp size-inp) (test-receive-buffer/file)
      (assert (= size-out size-inp))
      (assert (= 0 (memcmp buffer-out buffer-inp size-out))))))

(defun dump-log ()
  (let ((log *log*))
    (setf *log* '())
    (map nil 'write-line (nreverse log))
    (values)))

(define-test test/all ()
  (test/socket/file)  (dump-log)
  (test/socket/tcp)   (dump-log)
  ;; (test/socket/udp)   (dump-log)
  (test/send-receive/file)
  :success)

;;;; THE END ;;;;