;;;; -*- mode: lisp -*-
;;;;
;;;; $Id: base64.lisp,v 1.3 2005/02/07 17:45:41 scaekenberghe Exp $
;;;;
;;;; S-SYSDEPS is an abtraction layer over platform dependent functionality
;;;;
;;;; Copyright (C) 2004-2006 Sven Van Caekenberghe, Beta Nine BVBA.
;;;;
;;;; You are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser General Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

(in-package :s-sysdeps)

;; loading platform specific dependencies

#+lispworks
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "comm"))

#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :sb-bsd-sockets))

;; managing processes

(defun current-process ()
  "Return the object representing the current process"
  #+lispworks mp:*current-process* 
  #+abcl (ext:current-thread)
  #+openmcl ccl:*current-process*
  #+sb-thread sb-thread:*current-thread*
  #+allegro sys:*current-process*
  #-(or lispworks abcl openmcl sb-thread allegro) nil)

(defun kill-process (process)
  "Kill the process represented by the object process"
  #+lispworks (mp:process-kill process)
  #+abcl (ext:destroy-thread process)
  #+openmcl (ccl:process-kill process)
  #+sb-thread (sb-thread:terminate-thread process)
  #+allegro (mp:process-kill process)
  #-(or lispworks abcl openmcl sb-thread allegro) process)

(defun run-process (name function &rest arguments)
  "Create and run a new process with name, executing function on arguments"
  #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments)
  #+abcl (ext:make-thread #'(lambda () (apply function arguments)) :name name)
  #+openmcl (apply #'ccl:process-run-function name function arguments)
  #+allegro (apply #'mp:process-run-function name function arguments)
  #+sb-thread (sb-thread:make-thread #'(lambda () (apply function arguments)) :name name)
  #-(or lispworks abcl openmcl allegro sb-thread) 
  (declare (ignore name)) 
  #-(or lispworks abcl openmcl allegro sb-thread)
  (apply function arguments))

(defun all-processes ()
  "Return a list of all processes currently running"
  #+lispworks (mp:list-all-processes)
  #+abcl (ext:mapcar-threads #'identity)
  #+openmcl (ccl:all-processes)
  #+sb-thread (sb-thread:list-all-threads)
  #+allegro sys:*all-processes*
  #-(or lispworks abcl openmcl sb-thread allegro) nil)

;; opening a client TCP/IP socket stream

(defun open-socket-stream (host port &key connect-timeout read-timeout write-timeout)
  "Create and open a bidirectional client TCP/IP socket stream to host:port"
  #+(or lispworks) (declare (ignore write-timeout))
  #+lispworks (comm:open-tcp-stream host port :timeout connect-timeout :read-timeout read-timeout)
  #+abcl (let ((socket (ext:make-socket host port)))
	   (ext:get-socket-stream socket))
  #+openmcl (ccl:make-socket :remote-host host :remote-port port)
  #+allegro (acl-socket:make-socket :remote-host host :remote-port port 
                                    :type :stream :address-family :internet)
  #+clisp (socket:socket-connect port host)
  #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port) 
                            :input t :output t :buffering :none)
  #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket 
                                      :type :stream :protocol :tcp)))
           (sb-bsd-sockets:socket-connect socket 
                                          (car 
                                           (sb-bsd-sockets:host-ent-addresses 
                                            (sb-bsd-sockets:get-host-by-name host))) 
                                          port)
           (sb-bsd-sockets:socket-make-stream socket 
                                              :element-type 'character 
                                              :input t :output t :buffering :none))
  #-(or lispworks abcl openmcl allegro clisp cmu sbcl) 
  (error "Opening a socket stream to ~a:~d not yet ported this lisp system" host port))

;; accessing socket stream properties

(defun get-socket-stream-property (socket-stream property)
  "Get the value of a socket stream property, one of :remote-host :remote-port :local-host :local-port"
  #+lispworks (ecase property
                ((:remote-host :remote-port) (multiple-value-bind (address port)
                                                 (comm:socket-stream-peer-address socket-stream)
                                               (if (eql property :remote-host)
                                                   (comm:ip-address-string address)
                                                 port)))
                ((:local-host :local-port) (multiple-value-bind (address port)
                                               (comm:socket-stream-peer-address socket-stream)
                                             (if (eql property :local-host)
                                                 (comm:ip-address-string address)
                                               port))))
  #-(or lispworks) 
  (declare (ignore socket-stream property))
  #-(or lispworks) 
  nil)

;; implementing a standard TCP/IP server

#+(or sb-thread cmu)
(defvar *server-processes* '()
  "The list of processes created by S-SYSDEPS")

(defun start-standard-server (&key port name connection-handler)
  "Start a server process with name, listening on port, delegating to connection-handler with stream as argument"
  #+lispworks (comm:start-up-server
               :function #'(lambda (socket-handle)
                             (let ((client-stream (make-instance 'comm:socket-stream
                                                                 ;; maybe specify a read timeout...
                                                                 :socket socket-handle
                                                                 :direction :io
                                                                 :element-type 'base-char)))
                               (funcall connection-handler client-stream)))
               :service port
               :announce t
               :wait t
               :process-name name)
  #+abcl (ext:make-thread
	  #'(lambda ()
	      (let ((server-socket (ext:make-server-socket port)))
		(unwind-protect
		     (loop
			(let* ((client-socket (ext:socket-accept server-socket))
			       (client-stream (ext:get-socket-stream client-socket)))
			  (funcall connection-handler client-stream)))
		  (ext:server-socket-close server-socket))))
	  :name name)
  #+openmcl (ccl:process-run-function
             name
             #'(lambda ()
                 (let ((server-socket (ccl:make-socket :connect :passive
                                                       :local-port port
                                                       :reuse-address t)))
                   (unwind-protect
                       (loop 
                        (let ((client-stream (ccl:accept-connection server-socket)))
                          (funcall connection-handler client-stream))) 
                     (close server-socket)))))
  #+allegro (mp:process-run-function
	     name
	     #'(lambda ()
		 (let ((server-socket (acl-socket:make-socket :connect :passive 
							      :local-port port)))
		   (unwind-protect
                       (loop
                        (let ((client-stream (acl-socket:accept-connection server-socket)))
                          (funcall connection-handler client-stream)))
                     (close server-socket)))))
  #+sb-thread (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket 
                                            :type :stream :protocol :tcp))
                     (handler-fn (lambda (fd)
                                   (declare (ignore fd))
                                   (let ((stream
                                          (sb-bsd-sockets:socket-make-stream
                                           (sb-bsd-sockets:socket-accept socket)
                                           :element-type 'character
                                           :input t
                                           :output t
                                           :buffering :none)))
                                     (funcall connection-handler stream)))))
                (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
                (sb-bsd-sockets:socket-bind socket #(0 0 0 0) port)
                (sb-bsd-sockets:socket-listen socket 15)
                (push (list name 
                            socket
                            (sb-sys:add-fd-handler 
                             (sb-bsd-sockets:socket-file-descriptor socket)
                             :input handler-fn)) 
                      *server-processes*))
  #+cmu (let* ((socket (ext:create-inet-listener port :stream :reuse-address t
                                                 :backlog 15))
               (handler-fn (lambda (fd)
                             (declare (ignore fd))
                             (let ((stream (sys:make-fd-stream
                                            (ext:accept-tcp-connection socket)
                                            :input t :output t
                                            :element-type 'character
                                            :buffering :none)))
                               (funcall connection-handler stream)))))
          (push (list name 
                      socket
                      (sys:add-fd-handler socket :input handler-fn))
                *server-processes*))
  #-(or lispworks abcl openmcl allegro sb-thread cmu) 
  (error "Starting a standard socket named ~s on port ~d using handler ~s not yet ported to this lisp system"
         name port connection-handler)) 

#+(or sb-thread cmu)
(defun stop-server (name)
  "Stop a named server"
  #+sb-thread (progn
                (destructuring-bind (name socket handler)
                    (assoc name *server-processes* :test #'string=)
                  (declare (ignore name))
                  (sb-sys:remove-fd-handler handler)
                  (sb-bsd-sockets:socket-close socket))
                (setf *server-processes* (delete name *server-processes*
                                                 :key #'car :test #'string=)))
  #+cmu (progn
          (destructuring-bind (name socket handler)
              (assoc name *server-processes* :test #'string=)
            (declare (ignore name))
            (sys:remove-fd-handler handler)
            (unix:unix-close socket))
          (setf *server-processes* (delete name *server-processes*
                                           :key #'car :test #'string=)))
  name)

;; working with process locks

(defun make-process-lock (name)
  "Create a named process lock object"
  #+lispworks (mp:make-lock :name name)
  #+abcl (ext:make-thread-lock)
  #+openmcl (ccl:make-lock name)
  #+allegro (mp:make-process-lock :name name)
  #+sb-thread (sb-thread:make-mutex :name name)
  #-(or lispworks abcl openmcl allegro sb-thread) 
  (declare (ignore name))
  #-(or lispworks abcl openmcl allegro sb-thread) 
  nil)

(defmacro with-process-lock ((lock) &body body)
  "Execute body wih the process lock grabbed, wait otherwise"
  ;; maybe it is safer to always use a timeout: 
  ;; `(mp:with-lock (,lock (format nil "Waiting for ~s" (lock-name ,lock)) 5) ,@body)
  ;; if the lock cannot be claimed in 5s, nil is returned: test it and throw a condition ?
  #+lispworks `(mp:with-lock (,lock) ,@body)
  #+abcl `(ext:with-thread-lock (,lock) ,@body)
  #+openmcl `(ccl:with-lock-grabbed (,lock) ,@body)
  #+allegro `(mp:with-process-lock (,lock) ,@body)
  #+sb-thread `(sb-thread:with-recursive-lock (,lock) ,@body)
  #-(or lispworks abcl openmcl allegro sb-thread) 
  (declare (ignore lock))
  #-(or lispworks abcl openmcl allegro sb-thread) 
  `(progn ,@body))

;;;; eof
