cluster.lisp

   1 ;; Copyright 2009 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 (in-package :cl-cluster)
  19
  20 (defparameter *ping* "/bin/ping")
  21 (defparameter *ssh* "/usr/bin/ssh")
  22 (defparameter *lisp-slave* "/usr/bin/sbcl --noinform")
  23 (defparameter *lisp-user* "lisp")
  24
  25 (defun system (cmd args)
  26   (sb-ext:process-exit-code
  27    (sb-ext:run-program cmd (split-sequence:split-sequence #\Space args))))
  28
  29 (defun remote (cmd args)
  30   (sb-ext:run-program cmd (split-sequence:split-sequence #\Space args)
  31                       :input :stream :output :stream :wait nil))
  32
  33 (defclass node ()
  34   ((host :initarg :host :accessor node-host)
  35    (lisp :initarg :lisp :initform *lisp-slave* :accessor node-lisp)
  36    (process :initform nil :accessor node-process)
  37    (input :initform nil :accessor node-input)
  38    (output :initform nil :accessor node-output)
  39    (sexp :initform nil :accessor node-sexp)
  40    (lock :initform (bt:make-lock "node lock") :accessor node-lock)))
  41
  42 (defmethod print-object ((object node) stream)
  43   (format stream "#N<HOST:\"~a\" LISP:\"~a\">" (node-host object) (node-lisp object)))
  44
  45 (defgeneric node-alive-p (object)
  46   (:documentation "Returns T if node is alive."))
  47
  48 (defmethod node-alive-p ((object node))
  49   (with-slots (process) object
  50     (and process (sb-ext:process-p process) (sb-ext:process-alive-p process))))
  51
  52 (defgeneric node-connect (object)
  53   (:documentation "Establish connection with remote host."))
  54
  55 (defmethod node-connect ((object node))
  56   (bt:with-lock-held ((node-lock object))
  57     (with-slots (host lisp process input output) object
  58       (when (not (sb-ext:process-p process))
  59         (when (= 0 (system *ping* (format nil "-c 1 -w 1 ~a" host)))
  60           (setq process
  61                 (remote *ssh* (format nil "-l ~a ~a ~a"
  62                                       *lisp-user* host lisp))
  63                 input (sb-ext:process-input process)
  64                 output (sb-ext:process-output process))
  65           (let ((proc process))
  66             (tg:finalize object
  67                          (lambda () ;(format t "finalize ~a~%" proc)
  68                            (when proc (sb-ext:process-close proc))))))
  69         (node-flush/unsafe object t)          ; discard prompt and other trash
  70         process))))
  71
  72 (defmethod initialize-instance :after ((object node) &key connect &allow-other-keys)
  73   (when connect
  74     (node-connect object)))
  75
  76 (defgeneric node-disconnect (object)
  77   (:documentation "Close connection with remote host."))
  78
  79 (defmethod node-disconnect ((object node))
  80   (bt:with-lock-held ((node-lock object))
  81     (with-slots (host lisp process input output) object
  82       (when (node-alive-p object)
  83         (node-send/unsafe object "(quit)")
  84         (close input)
  85         (close output)
  86         (sb-ext:process-kill process 9)))))
  87
  88 (defgeneric node-send/unsafe (object msg)
  89   (:documentation "Send command to remote host."))
  90
  91 (defmethod node-send/unsafe ((object node) msg)
  92   (when (not (node-alive-p object))
  93     (error (format nil "Node ~a not connected" object)))
  94   (with-slots (input) object
  95     (princ msg input)
  96     (princ #\Newline input)
  97     (force-output input)))
  98
  99 (defgeneric node-send (object msg)
 100   (:documentation "Send command to remote host (thread-safe)."))
 101
 102 (defmethod node-send ((object node) msg)
 103   (bt:with-lock-held ((node-lock object))
 104     (node-send/unsafe object msg)))
 105
 106 (defgeneric node-recv/unsafe (object &optional non-blocking)
 107   (:documentation "Receive data from remote host.
 108 If optional argument `non-blocking' is set, don't wait for
 109 data."))
 110
 111 (defmethod node-recv/unsafe ((object node) &optional non-blocking)
 112   (when (not (node-alive-p object))
 113     (error (format nil "Node ~a not connected" object)))
 114   (with-slots (output) object
 115     (if non-blocking
 116         (and (listen output)
 117              (read output))
 118         (read output))))
 119
 120 (defgeneric node-recv (object &optional non-blocking)
 121   (:documentation "Receive data from remote host (thread-safe).
 122 If optional argument `non-blocking' is set, don't wait for
 123 data."))
 124
 125 (defmethod node-recv ((object node) &optional non-blocking)
 126   (bt:with-lock-held ((node-lock object))
 127     (node-recv/unsafe object non-blocking)))
 128
 129 (defgeneric node-flush/unsafe (object &optional wait-input)
 130   (:documentation "Flush available input data.
 131 Wait for input when optional argument `wait-input' is set.
 132 This is useful to skip interactive prompt."))
 133
 134 (defmethod node-flush/unsafe ((object node) &optional wait-input)
 135   (when wait-input
 136     (with-slots (output) object
 137       (let ((timeout 60.0))
 138         (loop (when (or (listen output) (< (decf timeout 0.25) 0)) (return))
 139            (sleep 0.25)))))
 140   (clear-input (node-output object)))
 141
 142 (defgeneric node-flush (object &optional wait-input)
 143   (:documentation "Flush available input data (thread-safe).
 144 Wait for input when optional argument `wait-input' is set.
 145 This is useful to skip interactive prompt."))
 146
 147 (defmethod node-flush ((object node) &optional wait-input)
 148   (bt:with-lock-held ((node-lock object))
 149     (node-flush/unsafe object wait-input)))
 150
 151 (defgeneric node-exec (object cmd &optional trap-errors)
 152   (:documentation "Execute command on remote host and return result."))
 153
 154 (defmethod node-exec ((object node) cmd &optional (trap-errors t))
 155   (declare (type string cmd))
 156   (bt:with-lock-held ((node-lock object))
 157     (node-flush/unsafe object)
 158     (setf (node-sexp object) cmd)
 159     (when trap-errors
 160       (setq cmd (concatenate 'string
 161                              (format nil "(handler-case (eval (read-from-string ~s))" cmd)
 162                              "(error (condition) (list 'error (format nil \"~a\" condition))))")))
 163       (node-send/unsafe object cmd)
 164     (let ((answer (node-recv/unsafe object)))
 165       (when (and (listp answer) trap-errors (eq (car answer) 'error))
 166         (error "Error: ~a~%In form: ~a~%At node: ~a~%" (cadr answer) (node-sexp object) object))
 167       (node-flush/unsafe object t)      ; kill prompt
 168       answer)))
 169
 170 (defmacro with-remote (node &body body)
 171   "Execute body at remote host."
 172   `(node-exec ,node (format nil "~s" '(progn ,@body))))
 173
 174 (defmacro rplet (node (&rest bindings) &body body)
 175   "Let-like macro for remote lisp. Evaluate vars using pmap."
 176   (let ((syms (mapcar (lambda (x)
 177                         (gensym (string (car x))))
 178                       bindings)))
 179     `(node-exec ,node
 180                 ,(if (null syms) `(format nil "~s" '(progn ,@body))
 181                      `(format nil "(let ~s ~s)"
 182                               (let ,(loop for (nil exp) in bindings
 183                                        for sym in syms
 184                                        collect `(,sym (pexec ,exp)))
 185                                 (list ,@(loop for (var nil) in bindings
 186                                            for sym in syms
 187                                            collect `(list ',var (yield ,sym)))))
 188                               '(progn ,@body))))))