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-send/unsafe (object msg)
  77   (:documentation "Send command to remote host."))
  78
  79 (defmethod node-send/unsafe ((object node) msg)
  80   (when (not (node-alive-p object))
  81     (error (format nil "Node ~a not connected" object)))
  82   (with-slots (input) object
  83     (princ msg input)
  84     (princ #\Newline input)
  85     (force-output input)))
  86
  87 (defgeneric node-send (object msg)
  88   (:documentation "Send command to remote host (thread-safe)."))
  89
  90 (defmethod node-send ((object node) msg)
  91   (bt:with-lock-held ((node-lock object))
  92     (node-send/unsafe object msg)))
  93
  94 (defgeneric node-recv/unsafe (object &optional non-blocking)
  95   (:documentation "Receive data from remote host.
  96 If optional argument `non-blocking' is set, don't wait for
  97 data."))
  98
  99 (defmethod node-recv/unsafe ((object node) &optional non-blocking)
 100   (when (not (node-alive-p object))
 101     (error (format nil "Node ~a not connected" object)))
 102   (with-slots (output) object
 103     (if non-blocking
 104         (and (listen output)
 105              (read output))
 106         (read output))))
 107
 108 (defgeneric node-recv (object &optional non-blocking)
 109   (:documentation "Receive data from remote host (thread-safe).
 110 If optional argument `non-blocking' is set, don't wait for
 111 data."))
 112
 113 (defmethod node-recv ((object node) &optional non-blocking)
 114   (bt:with-lock-held ((node-lock object))
 115     (node-recv/unsafe object non-blocking)))
 116
 117 (defgeneric node-flush/unsafe (object &optional wait-input)
 118   (:documentation "Flush available input data.
 119 Wait for input when optional argument `wait-input' is set.
 120 This is useful to skip interactive prompt."))
 121
 122 (defmethod node-flush/unsafe ((object node) &optional wait-input)
 123   (when wait-input
 124     (with-slots (output) object
 125       (let ((timeout 60.0))
 126         (loop (when (or (listen output) (< (decf timeout 0.25) 0)) (return))
 127            (sleep 0.25)))))
 128   (clear-input (node-output object)))
 129
 130 (defgeneric node-flush (object &optional wait-input)
 131   (:documentation "Flush available input data (thread-safe).
 132 Wait for input when optional argument `wait-input' is set.
 133 This is useful to skip interactive prompt."))
 134
 135 (defmethod node-flush ((object node) &optional wait-input)
 136   (bt:with-lock-held ((node-lock object))
 137     (node-flush/unsafe object wait-input)))
 138
 139 (defgeneric node-exec (object cmd &optional trap-errors)
 140   (:documentation "Execute command on remote host and return result."))
 141
 142 (defmethod node-exec ((object node) cmd &optional (trap-errors t))
 143   (declare (type string cmd))
 144   (bt:with-lock-held ((node-lock object))
 145     (node-flush/unsafe object)
 146     (setf (node-sexp object) cmd)
 147     (when trap-errors
 148       (setq cmd (concatenate 'string "(handler-case (eval (read-from-string \"" cmd "\")) "
 149                              " (error (condition) (list 'error (format nil \"~a\" condition))))")))
 150     (node-send/unsafe object cmd)
 151     (let ((answer (node-recv/unsafe object)))
 152       (when (and (listp answer) trap-errors (eq (car answer) 'error))
 153         (error "Error: ~a~%In form: ~a~%At node: ~a~%" (cadr answer) (node-sexp object) object))
 154       (node-flush/unsafe object t)      ; kill prompt
 155       answer)))
 156
 157 (defmacro with-remote (node &body body)
 158   "Execute body at remote host."
 159   `(node-exec ,node (format nil "~s" '(progn ,@body))))
 160
 161 (macrolet ((defrlet (name f doc)
 162              `(defmacro ,name (node vars &body body)
 163                 ,doc
 164                 (let ((v (loop :for i :in vars
 165                             :collect (car i) :into x
 166                             :collect (cadr i) :into y
 167                             :finally (return (list (null x) x y)))))
 168                   `(node-exec ,node
 169                               ,(if (car v) `(format nil "~s" '(progn ,@body))
 170                                    `(format nil "(let ~s ~s)"
 171                                             (mapcar #'list ',(cadr v)
 172                                                     (,,f #'eval ',(caddr v)))
 173                                             '(progn ,@body))))))))
 174   (defrlet rlet 'mapcar "Let-like macro for remote lisp. Evaluate vars using mapcar.")
 175   (defrlet rplet 'pmap "Let-like macro for remote lisp. Evaluate vars using pmap."))