#|
 Ltk-remote  networking support for the Ltk library

 This software is Copyright (c) 2003 Peter Herth <herth@peter-herth.de>

 Peter Herth grants you the rights to distribute
 and use this software as governed by the terms
 of the Lisp Lesser GNU Public License
 (http://opensource.franz.com/preamble.html),
 known as the LLGPL.
 
 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 General Public License for more details.
 
|#

#+:sbcl (require 'sb-bsd-sockets)

(defpackage :ltk-remote
  (:use :common-lisp :ltk
        #+(or :cmu :scl) :ext
       #+:sbcl :sb-ext
       #+:sbcl :sb-thread
       #+:sbcl :sb-bsd-sockets)
  (:export
   #:with-remote-ltk))

(in-package ltk-remote)

;;; cmu version

#+:cmu
(defun ip-address-string (address)
  (format nil "~D.~D.~D.~D"
          (ldb (byte 8 24) address)
          (ldb (byte 8 16) address)
          (ldb (byte 8 8)  address)
          (ldb (byte 8 0)  address)))

(defvar *stop-remote* nil)

#+:cmu
(defmacro with-remote-ltk (port bindings form &rest cleanup)
  `(mp:make-process
    (lambda ()
      (setf *stop-remote* nil)
      (let ((fd (ext:create-inet-listener ,port :stream :reuse-address t)))
        (unwind-protect
             (loop
                (when (or *stop-remote* mp::*quitting-lisp*)
                  (return))
                (let ((winp (mp:process-wait-until-fd-usable fd :input 2)))
                  (when (or *stop-remote* mp::*quitting-lisp*)
                    (return))
                  (when winp
                    (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
                      (when new-fd
                        (mp:make-process
                         (lambda ()
                           (multiple-value-bind (server-address server-port)
                               (ext:get-socket-host-and-port new-fd)
                             (multiple-value-bind (remote-address remote-port)
                                 (ext:get-peer-host-and-port new-fd)
                               (flet ((host-name (address)
                                        (let ((host-entry (ext:lookup-host-entry address)))
                                          (if host-entry
                                              (ext:host-entry-name host-entry)
                                              (ip-address-string address)))))
                                 (let ((stream (sys:make-fd-stream new-fd :input t :output t))
                                       (server-name (host-name server-address))
                                       (remote-name (host-name remote-address)))
                                   (format t "Connection to ~A:~D from ~A:~D at "
                                           server-name server-port
                                           remote-name remote-port)
                                   (ext:format-universal-time t (get-universal-time)
                                                              :style :rfc1123)
                                   (setf (mp:process-name mp:*current-process*)
                                         (format nil "LTK connection to ~A:~D from ~A:~D"
                                                 server-name server-port
                                                 remote-name remote-port))
                                   (let ,bindings
                                     (ltk::call-with-ltk (lambda ()
                                                           ,form)
                                                         :stream stream)
                                     ,@cleanup))))))))))))
          (unix:unix-close fd))))
    :name (format nil "LTK connection listener on port ~D" ,port)))

#+:cmu
(defun stop-server ()
  (setf *stop-remote* t))

#+:cmu
(defun start-mp ()
   #+nil (setf mp::*idle-process* mp::*initial-process*)
   (mp::startup-idle-and-top-level-loops))


#+:cmu
(defun start-remote (port)
  (multiprocessing::make-process #'(lambda () (ltk-remote-server port))))

;;; SCL version

#+:scl
(defmacro with-remote-ltk (port bindings form &rest cleanup)
  `(thread:thread-create
    (lambda ()
      (setf *stop-remote* nil)
      (let ((fd (ext:create-inet-listener ,port :stream :reuse-address t)))
        (unwind-protect
             (loop
                (when (or *stop-remote* thread:*quitting-lisp*)
                  (return))
                (let ((winp (sys:wait-until-fd-usable fd :input 2)))
                  (when (or *stop-remote* thread:*quitting-lisp*)
                    (return))
                  (when winp
                    (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
                      (when new-fd
                        (thread:thread-create
                         (lambda ()
                           (multiple-value-bind (server-address server-port)
                               (ext:get-socket-host-and-port new-fd)
                             (multiple-value-bind (remote-address remote-port)
                                 (ext:get-peer-host-and-port new-fd)
                               (flet ((host-name (address)
                                        (let ((host-entry (ext:lookup-host-entry address)))
                                          (if host-entry
                                              (ext:host-entry-name host-entry)
                                              (ext:ip-address-string address)))))
                                 (let ((stream (sys:make-fd-stream new-fd :input t :output t))
                                       (server-name (host-name server-address))
                                       (remote-name (host-name remote-address)))
                                   (format t "Connection to ~A:~D from ~A:~D at "
                                           server-name server-port
                                           remote-name remote-port)
                                   (ext:format-universal-time t (get-universal-time)
                                                              :style :rfc1123)
                                   (setf (thread:thread-name thread:*thread*)
                                         (format nil "LTK connection to ~A:~D from ~A:~D"
                                                 server-name server-port
                                                 remote-name remote-port))
                                   (let ,bindings
                                     (ltk::call-with-ltk (lambda ()
                                                           ,form)
                                                         :stream stream)
                                     ,@cleanup))))))))))))
          (unix:unix-close fd))))
    :name (format nil "LTK connection listener on port ~D" ,port)))

#+:scl
(defun stop-server ()
  (setf *stop-remote* t))


;;; sbcl version

#+:sbcl
(defun stop-server ()
  (setf *stop-remote* t))


#+:sbcl
(defun make-socket-server (port)
  (let ((socket (make-instance 'inet-socket :type :stream :protocol :tcp)))
    (socket-bind socket #(0 0 0 0) port)
    (socket-listen socket 100)
    socket))

#+:sbcl
(defun get-connection-stream (server-socket)
  (let* ((s (socket-accept server-socket))
	     (stream (socket-make-stream s :input t :output t)))
    stream)) ;; do we need to return s as well ?

#+:sbcl
(defmacro with-remote-ltk (port bindings form &rest cleanup)
  `(make-thread
    (lambda () 
      (setf *stop-remote* nil)      
      (let ((socket (make-socket-server ,port)))
	(loop
	  (when *stop-remote*
	    (socket-close socket)
	    (return))
	  (let* ((s (socket-accept socket))
		 (stream (socket-make-stream s :input t :output t)))
	    (make-thread
             (lambda ()
               (let ,bindings
                 (ltk::call-with-ltk (lambda ()
                                       ,form)
                                     :stream stream)
                 ,@cleanup)))))
        (socket-close socket)))))
;; lispworks version
(defvar *server* nil)
#+:lispworks
(defun stop-server ()
 (mp:process-kill ltk-remote::*server*))
#+:lispworks
(require "comm")
#+:lispworks
(defmacro with-remote-ltk (port bindings form &rest cleanup)
  `(setf ltk-remote::*server*
         (comm:start-up-server :function 
                               (lambda (handle)
                                 (let ((stream (make-instance 'comm:socket-stream
                                                              :socket handle
                                                              :direction :io
                                                              :element-type
                                                              'base-char)))
                                   (mp:process-run-function
                                    (format nil "ltk-remote ~D" handle)
                                    '()
                                    (lambda ()
                                      (let ,bindings
                                        (ltk::call-with-ltk (lambda ()
                                                              ,form)
                                                            :stream stream)
                                        ,@cleanup)))))
                               :service ,port)))

;; allegro version

#+:allegro
(progn
  (require :sock)
  (use-package :socket))
#+:allegro
(defmacro with-remote-ltk (port bindings form &rest cleanup)
  `(setf ltk-remote::*server*
         (mp:process-run-function
          (format nil "ltk remote server [~a]" ,port)
          (lambda ()
            (let ((server (make-socket :type :stream :address-family :internet :connect :passive
                                       :local-host "0.0.0.0" :local-port ,port
                                       :reuse-address t :keepalive t)))
              (restart-case 
                  (unwind-protect
                       (loop
                          (let ((connection (accept-connection server)))
                            (mp:process-run-function
                             (format nil "ltk remote connection <~s>"  (ipaddr-to-hostname
                                                                        (remote-host connection)))
                             (lambda ()
                               (let ,bindings
                                 (ltk::call-with-ltk (lambda ()
                                                       ,form)
                                                     :stream connection)
                                 ,@cleanup)))))
                    (close server))
                (quit ()
                  :report "Shutdown ltk remote server"
                  nil)))))))

;;; simple test function

(defun lrtest (port)
  (with-remote-ltk
   port ()
   (let* ((txt (make-text nil :width 40 :height 10))
 	  (f (make-instance 'frame ))
 	  (b (make-instance 'button :master f :text  "Hallo"
 			    :command (lambda ()
					(append-text txt (format nil "Hallo pressed~&")))))
 	  (b2 (make-instance 'button :master f :text "Quit"
 			     :command (lambda ()
					(setf *exit-mainloop* t))))
 	  (b3 (make-instance 'button :master f :text "Clear"
 			     :command (lambda ()
				       (clear-text txt ))))
	  )
     (pack b :side "left")
     (pack b3 :side "left")
     (pack b2 :side "left")
     (pack f :side "top")
     (pack txt :side "bottom")
     )))


(defun rlb-test2 ()
  (with-remote-ltk 8080 ()
   (let* ((last nil)
	  (l (make-instance 'listbox))
	  (wf (make-instance 'frame))
	  (lbl (make-instance 'label :master wf :text "Widget:"))
	  (f (make-instance 'frame :master wf))
	  (canv (make-instance 'canvas :master f :width 100 :height 100))
	  (scanv (make-instance 'scrolled-canvas :master f))
	  (widgets (list
		    (make-instance 'button :master f :text "Button")
		    (make-instance 'label :master f :text "Label")
		    canv
		    scanv
		    ))
	;  (b (make-instance 'button :text "Show" :command ))
	  )
     (bind l "<Button-1>" (lambda (event)
                            (declare (ignore event))
			    (let ((sel (listbox-get-selection l)))
			      (format t "selection: ~a~%" sel)
			      (force-output)
			      (if (first sel)
				  (let ((w (nth (first (listbox-get-selection l)) widgets)))
				    (when last
				      (pack-forget last))
				    (pack w)
				    (setf last w))))))
     (pack l :expand 1 :fill "y")
     (pack wf :expand 1 :fill "both")
     ;(grid l 0 0)
     ;(grid wf 0 1)

     (pack lbl :side "top")
     (pack f :expand 1 :fill "both")
     (configure wf "borderwidth" 2)
     (configure wf "relief" "sunken")
     
     ;(pack b)
     (create-line canv (list 0 0 40 40 60 20 80 80 60 60 40 80 20 60 0 80 0 0))
     (create-line (canvas scanv) (mapcar (lambda (x)
					   (* x 10))
					 (list 0 0 40 40 60 20 80 80 60 60 40 80 20 60 0 80 0 0)))
     (scrollregion (canvas scanv) 0 0 800 800)
     (listbox-append l (mapcar (lambda (x) (type-of x)) widgets))

     )))