cluster.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 (in-package :cl-cluster)
  19
  20 (defclass node ()
  21   ((name :initform nil :initarg :name :accessor node-name)
  22    (type :initform nil :initarg :type :accessor node-type)
  23    (sexp :initform nil :accessor node-sexp)
  24    (lock :initform (bt:make-lock "node lock") :accessor node-lock)))
  25
  26 (defmethod print-object ((object node) stream)
  27   (format stream "#N<NODE:\"~a\">" (node-host object)))
  28
  29 (defgeneric node-alive-p (object)
  30   (:documentation "Returns T if node is alive."))
  31
  32 (defgeneric node-connect (object)
  33   (:documentation "Establish connection with remote host."))
  34
  35 (defmethod initialize-instance :after ((object node) &key connect &allow-other-keys)
  36   (when connect
  37     (node-connect object)))
  38
  39 (defgeneric node-disconnect (object)
  40   (:documentation "Close connection with remote host."))
  41
  42 (defgeneric node-send/unsafe (object msg)
  43   (:documentation "Send command to remote host."))
  44
  45 (defgeneric node-send (object msg)
  46   (:documentation "Send command to remote host (thread-safe)."))
  47
  48 (defmethod node-send (object msg)
  49   (when (not (node-alive-p object))
  50     (error (format nil "Node ~a not connected" object)))
  51   (bt:with-lock-held ((node-lock object))
  52     (node-send/unsafe object msg)))
  53
  54 (defgeneric node-recv/unsafe (object &optional non-blocking)
  55   (:documentation "Receive data from remote host.
  56 If optional argument `non-blocking' is set, don't wait for
  57 data."))
  58
  59 (defgeneric node-recv (object &optional non-blocking)
  60   (:documentation "Receive data from remote host (thread-safe).
  61 If optional argument `non-blocking' is set, don't wait for
  62 data."))
  63
  64 (defmethod node-recv (object &optional non-blocking)
  65   (when (not (node-alive-p object))
  66     (error (format nil "Node ~a not connected" object)))
  67   (bt:with-lock-held ((node-lock object))
  68     (node-recv/unsafe object non-blocking)))
  69
  70 (defgeneric node-flush/unsafe (object &optional wait-input)
  71   (:documentation "Flush available input data.
  72 Wait for input when optional argument `wait-input' is set.
  73 This is useful to skip interactive prompt."))
  74
  75 (defgeneric node-flush (object &optional wait-input)
  76   (:documentation "Flush available input data (thread-safe).
  77 Wait for input when optional argument `wait-input' is set.
  78 This is useful to skip interactive prompt."))
  79
  80 (defmethod node-flush (object &optional wait-input)
  81   (when (not (node-alive-p object))
  82     (error (format nil "Node ~a not connected" object)))
  83   (bt:with-lock-held ((node-lock object))
  84     (node-flush/unsafe object wait-input)))
  85
  86 (defgeneric node-exec (object cmd &optional guard trap-errors read-answer)
  87   (:documentation "Execute command on remote host and return result."))
  88
  89 (defmethod node-exec (object cmd &optional (guard t) (trap-errors t) (read-answer t))
  90   (declare (type string cmd))
  91   (bt:with-lock-held ((node-lock object))
  92     (when (not (node-alive-p object))
  93       (error (format nil "Node ~a not connected" object)))
  94     (node-flush/unsafe object)
  95     (setf (node-sexp object) cmd)
  96     (when guard
  97       (setq cmd (concatenate 'string
  98                              (format nil "(handler-case (eval (read-from-string ~s))" cmd)
  99                              "(error (condition) (list 'error (format nil \"~a\" condition))))")))
 100       (node-send/unsafe object cmd)
 101       (when read-answer
 102         (let ((answer (node-recv/unsafe object)))
 103           (when (and (listp answer) trap-errors (eq (car answer) 'error))
 104             (error "Error: ~a~%In form: ~a~%At node: ~a~%" (cadr answer) (node-sexp object) object))
 105           (node-flush/unsafe object t)  ; kill prompt
 106           answer))))