transport-ssh.lisp

   1 ;; Copyright 2009, 2010 Vitaly Mayatskikh <v.mayatskih@gmail.com>
   2 ;;
   3 ;; This file is a part of CL-Cluster
   4 ;;
   5 ;; CL-Cluster is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, either version 3 of the License, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; CL-Cluster is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;; (defpackage :cl-cluster-ssh
  19 ;;   (:use :cl :cl-cluster)
  20 ;;   (:export
  21 ;;    :node-ssh))
  22
  23 (in-package :cl-cluster)
  24
  25 (defparameter *ping*
  26   #+linux "/bin/ping"
  27   #+bsd "/sbin/ping")
  28
  29 (defparameter *ping-params*
  30   #+linux "-c 1 -w 1"
  31   #+bsd "-c 1 -W 1")
  32
  33 (defparameter *ssh* "/usr/bin/ssh")
  34 (defparameter *lisp-slave* "/usr/bin/sbcl --noinform --core core")
  35 (defparameter *lisp-user* "lisp")
  36
  37 (defun system (cmd args)
  38   (sb-ext:process-exit-code
  39    (sb-ext:run-program cmd (split-sequence:split-sequence #\Space args))))
  40
  41 (defun remote (cmd args)
  42   (sb-ext:run-program cmd (split-sequence:split-sequence #\Space args)
  43                       :input :stream :output :stream :wait nil))
  44
  45 (defclass node-ssh (node)
  46   ((host :initarg :host :accessor node-host)
  47    (lisp :initarg :lisp :initform *lisp-slave* :accessor node-lisp)
  48    (process :initform nil :accessor node-process)
  49    (input :initform nil :accessor node-input)
  50    (output :initform nil :accessor node-output)))
  51
  52 (defmethod print-object ((object node-ssh) stream)
  53   (format stream "#N<NODE: \"~a\" HOST:\"~a\" LISP:\"~a\">"
  54           (node-name object) (node-host object) (node-lisp object)))
  55
  56 (defmethod node-alive-p ((object node-ssh))
  57   (with-slots (process) object
  58     (and process (sb-ext:process-p process) (sb-ext:process-alive-p process))))
  59
  60 (defmethod node-connect ((object node-ssh))
  61   (bt:with-lock-held ((node-lock object))
  62     (with-slots (host lisp process input output) object
  63       (when (not (sb-ext:process-p process))
  64         (when (= 0 (system *ping* (format nil "~a ~a" *ping-params* host)))
  65           (setq process
  66                 (remote *ssh* (format nil "-l ~a ~a ~a"
  67                                       *lisp-user* host lisp))
  68                 input (sb-ext:process-input process)
  69                 output (sb-ext:process-output process))
  70           (let ((proc process))
  71             (tg:finalize object
  72                          (lambda () ;(format t "finalize ~a~%" proc)
  73                            (when proc (sb-ext:process-close proc))))))
  74         (node-flush/unsafe object t)          ; discard prompt and other trash
  75         process))))
  76
  77 (defmethod node-disconnect ((object node-ssh))
  78   (bt:with-lock-held ((node-lock object))
  79     (with-slots (host lisp process input output) object
  80       (when (node-alive-p object)
  81         (node-send/unsafe object "(quit)")
  82         (close input)
  83         (close output)
  84         (sb-ext:process-kill process 9)))))
  85
  86 (defmethod node-send/unsafe ((object node-ssh) msg)
  87   (with-slots (input) object
  88     (princ msg input)
  89     (princ #\Newline input)
  90     (force-output input)))
  91
  92 (defmethod node-recv/unsafe ((object node-ssh) &optional non-blocking)
  93   (with-slots (output) object
  94     (if non-blocking
  95         (and (listen output)
  96              (read output))
  97         (read output))))
  98
  99 (defmethod node-flush/unsafe ((object node-ssh) &optional wait-input)
 100   (when wait-input
 101     (with-slots (output) object
 102       (let ((timeout 60.0))
 103         (loop (when (or (listen output) (< (decf timeout 0.25) 0)) (return))
 104            (sleep 0.25)))))
 105   (clear-input (node-output object)))